Compare commits

..
2 Commits
Author SHA1 Message Date
John Roberts dfb0be2c0e migration 2022-03-20 14:50:16 +04:00
John Roberts 2e808192de use server IP addresses 2022-03-20 14:48:09 +04:00
103 changed files with 2567 additions and 12246 deletions
+2 -4
View File
@@ -19,9 +19,9 @@ jobs:
- name: Setup Stack
uses: haskell/actions/setup@v1
with:
ghc-version: "8.10.7"
ghc-version: '8.10.7'
enable-stack: true
stack-version: "latest"
stack-version: 'latest'
- name: Cache dependencies
uses: actions/cache@v2
@@ -36,7 +36,6 @@ jobs:
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')
@@ -74,7 +73,6 @@ jobs:
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 }}
-2
View File
@@ -4,5 +4,3 @@
*.session.sql
tests/tmp
dist-newstyle/
src/tor
-106
View File
@@ -1,107 +1,9 @@
# 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.
@@ -111,29 +13,24 @@ 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.
@@ -146,16 +43,13 @@ Security and privacy improvements:
- Server identity verification via server offline certificate fingerprints included in SMP server addresses.
New functionality:
- Support for notification servers with new SMP commands: `NKEY`/`NID`, `NSUB`/`NMSG`.
Efficiency improvements:
- Binary protocol encodings to reduce overhead from circa 15% to approximately 3.7% of transmitted application message size, with only 2.2% overhead for SMP protocol messages.
- More performant cryptographic algorithms.
For more information about SimpleX:
- [SimpleX overview](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md).
- [SimpleX chat v1 announcement](https://github.com/simplex-chat/simplex-chat/blob/master/blog/20220112-simplex-chat-v1-released.md).
+18 -49
View File
@@ -11,7 +11,7 @@ If you have a server deployed please deploy a new server to a new host and retir
## Message broker for unidirectional (simplex) queues
SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](./protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](./protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers.
SMP protocol is inspired by [Redis serialization protocol](https://redis.io/topics/protocol), but it is much simpler - it currently has only 10 client commands and 8 server responses.
@@ -27,19 +27,17 @@ SimpleXMQ is implemented in Haskell - it benefits from robust software transacti
### SMP server
[SMP server](./apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution without any dependencies, including low power/low memory devices.
To initialize the server use `smp-server init -n <fqdn>` (or `smp-server init --ip <ip>` for IP based address) command - it will generate keys and certificates for TLS transport. The fingerprint of offline certificate is used as part of the server address to protect client/server connection against man-in-the-middle attacks: `smp://<fingerprint>@<hostname>[:5223]`.
To initialize the server use `smp-server init` command - it will generate keys and certificates for TLS transport. The fingerprint of offline certificate is used as part of the server address to protect client/server connection against man-in-the-middle attacks: `smp://<fingerprint>@<hostname>[:5223]`.
SMP server uses in-memory persistence with an optional append-only log of created queues that allows to re-start the server without losing the connections. This log is compacted on every server restart, permanently removing suspended and removed queues.
To enable store log, initialize server using `smp-server -l` command, or modify `smp-server.ini` created during initialization (uncomment `enable: on` option in the store log section). Use `smp-server --help` for other usage tips.
Starting from version 2.3.0, when store log is enabled, the server would also enable saving undelivered messages on exit and restoring them on start. This can be disabled via a separate setting `restore_messages` in `smp-server.ini` file. Saving messages would only work if the server is stopped with SIGINT signal (keyboard interrupt), if it is stopped with SIGTERM signal the messages would not be saved.
> **Please note:** On initialization SMP server creates a chain of two certificates: a self-signed CA certificate ("offline") and a server certificate used for TLS handshake ("online"). **You should store CA certificate private key securely and delete it from the server. If server TLS credential is compromised this key can be used to sign a new one, keeping the same server identity and established connections.** CA private key location by default is `/etc/opt/simplex/ca.key`.
SMP server implements [SMP protocol](./protocol/simplex-messaging.md).
SMP server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
#### Running SMP server on MacOS
@@ -62,21 +60,20 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
### SMP client library
[SMP client](./src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
[SMP client](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
- execute commands with a functional API.
- receive messages and other notifications via STM queue.
- automatically send keep-alive commands.
### SMP agent
[SMP agent library](./src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
[SMP agent library](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
Haskell type [ACommand](./src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
Haskell type [ACommand](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
See [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI for the example of integrating SMP agent into another application.
[SMP agent executable](./apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](./protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
[SMP agent executable](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
## Using SMP server and SMP agent
@@ -90,35 +87,7 @@ You can either run your own SMP server locally or deploy using [Linode StackScri
It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI.
## Deploy SMP server on Linux
You can run your SMP server as a Linux process, optionally using a service manager for booting and restarts.
- For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
If you're using other Linux distribution and the binary is incompatible with it, you can build from source using [Haskell stack](https://docs.haskellstack.org/en/stable/README/):
```shell
curl -sSL https://get.haskellstack.org/ | sh
...
stack install
```
- Initialize SMP server with `smp-server init [-l] -n <fqdn>` or `smp-server init [-l] --ip <ip>` - depending on how you initialize it, either FQDN or IP will be used for server's address.
- Run `smp-server start` to start SMP server, or you can configure a service manager to run it as a service.
See [this section](#smp-server) for more information. Run `smp-server -h` and `smp-server init -h` for explanation of commands and options.
<img alt="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
@@ -129,11 +98,11 @@ Deployment on Linode is performed via StackScripts, which serve as recipes for L
- Create a Linode account or login with an already existing one.
- Open [SMP server StackScript](https://cloud.linode.com/stackscripts/748014) and click "Deploy New Linode".
- You can optionally configure the following parameters:
- SMP Server store log flag for queue persistence on server restart, recommended.
- [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) to attach server address etc. as tags to Linode and to add A record to your 2nd level domain (e.g. `example.com` [domain should be created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scopes:
- read/write for "linodes"
- read/write for "domains"
- Domain name to use instead of Linode IP address, e.g. `smp1.example.com`.
- SMP Server store log flag for queue persistence on server restart, recommended.
- [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) to attach server address etc. as tags to Linode and to add A record to your 2nd level domain (e.g. `example.com` [domain should be created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scopes:
- read/write for "linodes"
- read/write for "domains"
- Domain name to use instead of Linode IP address, e.g. `smp1.example.com`.
- Choose the region and plan, Shared CPU Nanode with 1Gb is sufficient.
- Provide ssh key to be able to connect to your Linode via ssh. If you haven't provided a Linode API token this step is required to login to your Linode and get the server's fingerprint either from the welcome message or from the file `/etc/opt/simplex/fingerprint` after server starts. See [Linode's guide on ssh](https://www.linode.com/docs/guides/use-public-key-authentication-with-ssh/) .
- Deploy your Linode. After it starts wait for SMP server to start and for tags to appear (if a Linode API token was provided). It may take up to 5 minutes depending on the connection speed on the Linode. Connecting Linode IP address to provided domain name may take some additional time.
@@ -142,7 +111,7 @@ Deployment on Linode is performed via StackScripts, which serve as recipes for L
Please submit an [issue](https://github.com/simplex-chat/simplexmq/issues) if any problems occur.
[<img alt="DigitalOcean" src="/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
[<img alt="DigitalOcean" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
## Deploy SMP server on DigitalOcean
@@ -170,12 +139,12 @@ smp-server init [-l] -n <fqdn>
## SMP server design
![SMP server design](./design/server.svg)
![SMP server design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/server.svg)
## SMP agent design
![SMP agent design](./design/agent2.svg)
![SMP agent design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/agent2.svg)
## License
[AGPL v3](./LICENSE)
[AGPL v3](https://github.com/simplex-chat/simplexmq/blob/master/LICENSE)
-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.1.3",
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"
}
}
+2 -10
View File
@@ -11,15 +11,7 @@ import Simplex.Messaging.Agent.Server (runSMPAgent)
import Simplex.Messaging.Transport (TLS, Transport (..))
cfg :: AgentConfig
cfg = defaultAgentConfig
servers :: InitialAgentServers
servers =
InitialAgentServers
{ smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
ntf = [],
netCfg = NetworkConfig {socksProxy = Nothing, tcpTimeout = 5000000}
}
cfg = defaultAgentConfig {initialSMPServers = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"]}
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -28,4 +20,4 @@ main :: IO ()
main = do
putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
setLogLevel LogInfo -- LogError
withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg servers
withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg
+303 -93
View File
@@ -1,109 +1,319 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# 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 Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight)
import Data.Ini (Ini, lookupValue, readIniFile)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.X509.Validation (Fingerprint (..))
import Network.Socket (HostName, ServiceName)
import Options.Applicative
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Server (runSMPServer)
import Simplex.Messaging.Server.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 (..), TLS, Transport (..), simplexMQVersion)
import Simplex.Messaging.Transport.Server (loadFingerprint)
import Simplex.Messaging.Transport.WebSockets (WS)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive)
import System.Exit (exitFailure)
import System.FilePath (combine)
import System.IO (BufferMode (..), IOMode (..), hGetLine, hSetBuffering, stderr, stdout, withFile)
import System.Process (readCreateProcess, shell)
import Text.Read (readMaybe)
cfgPath :: FilePath
cfgPath = "/etc/opt/simplex"
cfgDir :: FilePath
cfgDir = "/etc/opt/simplex"
logPath :: FilePath
logPath = "/var/opt/simplex"
logDir :: FilePath
logDir = "/var/opt/simplex"
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
iniFile :: FilePath
iniFile = combine cfgDir "smp-server.ini"
storeLogFile :: FilePath
storeLogFile = combine logDir "smp-server-store.log"
caKeyFile :: FilePath
caKeyFile = combine cfgDir "ca.key"
caCrtFile :: FilePath
caCrtFile = combine cfgDir "ca.crt"
serverKeyFile :: FilePath
serverKeyFile = combine cfgDir "server.key"
serverCrtFile :: FilePath
serverCrtFile = combine cfgDir "server.crt"
fingerprintFile :: FilePath
fingerprintFile = combine cfgDir "fingerprint"
main :: IO ()
main = do
setLogLevel 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
getCliCommand >>= \case
Init opts ->
doesFileExist iniFile >>= \case
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `smp-server start`."
_ -> initializeServer opts
Start ->
doesFileExist iniFile >>= \case
True -> readIniFile iniFile >>= either exitError (runServer . mkIniOptions)
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `smp-server init`."
Delete -> cleanup >> putStrLn "Deleted configuration and log files"
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
}
exitError :: String -> IO ()
exitError msg = putStrLn msg >> exitFailure
data CliCommand
= Init InitOptions
| Start
| Delete
data InitOptions = InitOptions
{ enableStoreLog :: Bool,
signAlgorithm :: SignAlgorithm,
ip :: HostName,
fqdn :: Maybe HostName
}
deriving (Show)
data SignAlgorithm = ED448 | ED25519
deriving (Read, Show)
getCliCommand :: IO CliCommand
getCliCommand =
customExecParser
(prefs showHelpOnEmpty)
( info
(helper <*> versionOption <*> cliCommandP)
(header version <> fullDesc)
)
where
versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
cliCommandP :: Parser CliCommand
cliCommandP =
hsubparser
( command "init" (info initP (progDesc $ "Initialize server - creates " <> cfgDir <> " and " <> logDir <> " directories and configuration files"))
<> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
)
where
initP :: Parser CliCommand
initP =
Init
<$> ( InitOptions
<$> switch
( long "store-log"
<> short 'l'
<> help "Enable store log for SMP queues persistence"
)
<*> option
(maybeReader readMaybe)
( long "sign-algorithm"
<> short 'a'
<> help "Signature algorithm used for TLS certificates: ED25519, ED448"
<> value ED448
<> showDefault
<> metavar "ALG"
)
<*> strOption
( long "ip"
<> help
"Server IP address used as Subject Alternative Name for TLS online certificate, \
\also used as Common Name if FQDN is not supplied"
<> value "127.0.0.1"
<> showDefault
<> metavar "IP"
)
<*> (optional . strOption)
( long "fqdn"
<> short 'n'
<> help "Server FQDN used as Common Name and Subject Alternative Name for TLS online certificate"
<> showDefault
<> metavar "FQDN"
)
)
initializeServer :: InitOptions -> IO ()
initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
cleanup
createDirectoryIfMissing True cfgDir
createDirectoryIfMissing True logDir
createX509
fp <- saveFingerprint
createIni
putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `smp-server start` to start server."
printServiceInfo fp
warnCAPrivateKeyFile
where
createX509 = do
createOpensslCaConf
createOpensslServerConf
-- CA certificate (identity/offline)
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile
run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile
-- server certificate (online)
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile
run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile
run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile
where
run cmd = void $ readCreateProcess (shell cmd) ""
opensslCaConfFile = combine cfgDir "openssl_ca.conf"
opensslServerConfFile = combine cfgDir "openssl_server.conf"
serverCsrFile = combine cfgDir "server.csr"
createOpensslCaConf =
writeFile
opensslCaConfFile
"[req]\n\
\distinguished_name = req_distinguished_name\n\
\prompt = no\n\n\
\[req_distinguished_name]\n\
\CN = SMP server CA\n\
\O = SimpleX\n\n\
\[v3]\n\
\subjectKeyIdentifier = hash\n\
\authorityKeyIdentifier = keyid:always\n\
\basicConstraints = critical,CA:true\n"
-- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
-- IP and FQDN can't both be used as server address interchangeably even if IP is added
-- as Subject Alternative Name, unless the following validation hook is disabled:
-- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
createOpensslServerConf =
writeFile
opensslServerConfFile
( "[req]\n\
\distinguished_name = req_distinguished_name\n\
\prompt = no\n\n\
\[req_distinguished_name]\n"
<> ("CN = " <> cn <> "\n\n")
<> "[v3]\n\
\basicConstraints = CA:FALSE\n\
\keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
\extendedKeyUsage = serverAuth\n"
)
where
cn = fromMaybe ip fqdn
saveFingerprint = do
Fingerprint fp <- loadFingerprint caCrtFile
withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
pure fp
createIni = do
writeFile iniFile $
"[STORE_LOG]\n\
\# The server uses STM memory to store SMP queues and messages,\n\
\# that will be lost on restart (e.g., as with redis).\n\
\# This option enables saving SMP queues to append only log,\n\
\# and restoring them when the server is started.\n\
\# Log is compacted on start (deleted queues are removed).\n\
\# The messages in the queues are not logged.\n"
<> ("enable: " <> (if enableStoreLog then "on" else "off # on") <> "\n\n")
<> "[TRANSPORT]\n\
\port: 5223\n\
\websockets: off\n"
warnCAPrivateKeyFile =
putStrLn $
"----------\n\
\You should store CA private key securely and delete it from the server.\n\
\If server TLS credential is compromised this key can be used to sign a new one, \
\keeping the same server identity and established connections.\n\
\CA private key location:\n"
<> caKeyFile
<> "\n----------"
data IniOptions = IniOptions
{ enableStoreLog :: Bool,
port :: ServiceName,
enableWebsockets :: Bool
}
-- TODO ? properly parse ini as a whole
mkIniOptions :: Ini -> IniOptions
mkIniOptions ini =
IniOptions
{ enableStoreLog = (== "on") $ strict "STORE_LOG" "enable",
port = T.unpack $ strict "TRANSPORT" "port",
enableWebsockets = (== "on") $ strict "TRANSPORT" "websockets"
}
where
strict :: String -> String -> T.Text
strict section key =
fromRight (error ("no key " <> key <> " in section " <> section)) $
lookupValue (T.pack section) (T.pack key) ini
runServer :: IniOptions -> IO ()
runServer IniOptions {enableStoreLog, port, enableWebsockets} = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
fp <- checkSavedFingerprint
printServiceInfo fp
storeLog <- openStoreLog
let cfg = mkServerConfig storeLog
printServerConfig cfg
runSMPServer cfg
where
checkSavedFingerprint = do
savedFingerprint <- loadSavedFingerprint
Fingerprint fp <- loadFingerprint caCrtFile
when (B.pack savedFingerprint /= strEncode fp) $
exitError "Stored fingerprint is invalid."
pure fp
mkServerConfig storeLog =
ServerConfig
{ transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets],
tbqSize = 16,
serverTbqSize = 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,
storeLog
}
openStoreLog :: IO (Maybe (StoreLog 'ReadMode))
openStoreLog =
if enableStoreLog
then Just <$> openReadStoreLog storeLogFile
else pure Nothing
printServerConfig ServerConfig {storeLog, transports} = do
putStrLn $ case storeLog of
Just s -> "Store log: " <> storeLogFilePath s
Nothing -> "Store log disabled."
forM_ transports $ \(p, ATransport t) ->
putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
cleanup :: IO ()
cleanup = do
deleteDirIfExists cfgDir
deleteDirIfExists logDir
where
deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)
printServiceInfo :: ByteString -> IO ()
printServiceInfo fpStr = do
putStrLn version
B.putStrLn $ "Fingerprint: " <> strEncode fpStr
version :: String
version = "SMP server v" <> simplexMQVersion
loadSavedFingerprint :: IO String
loadSavedFingerprint = withFile fingerprintFile ReadMode hGetLine
+1 -1
View File
@@ -2,5 +2,5 @@ packages: .
source-repository-package
type: git
location: https://github.com/simplex-chat/aeson.git
location: git://github.com/simplex-chat/aeson.git
tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7
-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

+8 -32
View File
@@ -1,7 +1,7 @@
name: simplexmq
version: 3.1.0
version: 1.0.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:
@@ -28,10 +28,9 @@ dependencies:
- asn1-types == 0.3.*
- async == 2.2.*
- attoparsec == 0.14.*
- base >= 4.14 && < 5
- base >= 4.7 && < 5
- base64-bytestring >= 1.0 && < 1.3
- bytestring == 0.10.*
- case-insensitive == 1.2.*
- composition == 1.0.*
- constraints >= 0.12 && < 0.14
- containers == 0.6.*
@@ -42,28 +41,21 @@ dependencies:
- directory == 1.3.*
- 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 == 3.1.*
- network-transport == 0.5.*
- optparse-applicative >= 0.15 && < 0.17
- QuickCheck == 2.14.*
- process == 1.6.*
- random >= 1.1 && < 1.3
- simple-logger == 0.1.*
- socks == 0.6.*
- sqlite-simple == 0.4.*
- stm == 2.5.*
- template-haskell == 2.16.*
- text == 1.2.*
- time == 1.9.*
- time-compat == 1.9.*
- time-manager == 0.0.*
- tls >= 1.6.0 && < 1.7
- tls >= 1.5.7 && < 1.6
- transformers == 0.5.*
- unliftio == 0.2.*
- unliftio-core == 0.2.*
@@ -72,17 +64,6 @@ dependencies:
- x509-store == 1.6.*
- x509-validation == 1.6.*
flags:
swift:
description: Enable swift JSON format
manual: True
default: False
when:
- condition: flag(swift)
cpp-options:
- -DswiftJSON
library:
source-dirs: src
@@ -91,14 +72,9 @@ executables:
source-dirs: apps/smp-server
main: Main.hs
dependencies:
- simplexmq
ghc-options:
- -threaded
ntf-server:
source-dirs: apps/ntf-server
main: Main.hs
dependencies:
- ini == 0.4.*
- optparse-applicative >= 0.15 && < 0.17
- process == 1.6.*
- simplexmq
ghc-options:
- -threaded
@@ -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>...
+43 -96
View File
@@ -24,7 +24,6 @@
- [Subscribe to queue](#subscribe-to-queue)
- [Secure queue command](#secure-queue-command)
- [Enable notifications command](#enable-notifications-command)
- [Disable notifications command](#disable-notifications-command)
- [Acknowledge message delivery](#acknowledge-message-delivery)
- [Suspend queue](#suspend-queue)
- [Delete queue](#delete-queue)
@@ -51,8 +50,6 @@ It's designed with the focus on communication security and integrity, under the
It is designed as a low level protocol for other application protocols to solve the problem of secure and private message transmission, making [MITM attack][1] very difficult at any part of the message transmission system.
This document describes SMP protocol versions 3 and 4, the previous versions are discontinued.
## Introduction
The objective of Simplex Messaging Protocol (SMP) is to facilitate the secure and private unidirectional transfer of messages from senders to recipients via persistent simplex queues managed by the message broker (server).
@@ -149,61 +146,61 @@ To create and start using a simplex queue Alice and Bob follow these steps:
1. Alice creates a simplex queue on the server:
1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Appendix A](#appendix-a)).
1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Appendix A](#appendix-a)).
2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before for Bob to encrypt the messages.
2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before for Bob to encrypt the messages.
3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to sign commands and to decrypt the transmissions received from the server.
3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to sign commands and to decrypt the transmissions received from the server.
4. Generates one more random key pair (recipient DH key - `RDHK`) to negotiate symmetric key that will be used by the server to encrypt message bodies delivered to Alice (to avoid shared cipher-text inside transport connection).
4. Generates one more random key pair (recipient DH key - `RDHK`) to negotiate symmetric key that will be used by the server to encrypt message bodies delivered to Alice (to avoid shared cipher-text inside transport connection).
5. Sends `"NEW"` command to the server to create a simplex queue (see `create` in [Create queue command](#create-queue-command)). This command contains previously generated unique "public" keys `RK` and `RDHK`. `RK` will be used to verify the following commands related to the same queue signed by its private counterpart, for example to subscribe to the messages received to this queue or to update the queue, e.g. by setting the key required to send the messages (initially Alice creates the queue that accepts unsigned messages, so anybody could send the message via this queue if they knew the queue sender's ID and server address).
5. Sends `"NEW"` command to the server to create a simplex queue (see `create` in [Create queue command](#create-queue-command)). This command contains previously generated unique "public" keys `RK` and `RDHK`. `RK` will be used to verify the following commands related to the same queue signed by its private counterpart, for example to subscribe to the messages received to this queue or to update the queue, e.g. by setting the key required to send the messages (initially Alice creates the queue that accepts unsigned messages, so anybody could send the message via this queue if they knew the queue sender's ID and server address).
6. The server sends `"IDS"` response with queue IDs (`queueIds`):
6. The server sends `"IDS"` response with queue IDs (`queueIds`):
- Recipient ID `RID` for Alice to manage the queue and to receive the messages.
- Recipient ID `RID` for Alice to manage the queue and to receive the messages.
- Sender ID `SID` for Bob to send messages to the queue.
- Sender ID `SID` for Bob to send messages to the queue.
- Server public DH key (`SDHK`) to negotiate a shared secret for message body encryption, that Alice uses to derive a shared secret with the server `SS`.
- Server public DH key (`SDHK`) to negotiate a shared secret for message body encryption, that Alice uses to derive a shared secret with the server `SS`.
2. Alice sends an out-of-band message to Bob via the alternative channel that both Alice and Bob trust (see [protocol abstract](#simplex-messaging-protocol-abstract)). The message must include:
- Unique "public" key (`EK`) that Bob must use for E2E key agreement.
- Unique "public" key (`EK`) that Bob must use for E2E key agreement.
- SMP server hostname and information to open secure encrypted transport connection (see [Appendix A](#appendix-a)).
- SMP server hostname and information to open secure encrypted transport connection (see [Appendix A](#appendix-a)).
- Sender queue ID `SID` for Bob to use.
- Sender queue ID `SID` for Bob to use.
3. Bob, having received the out-of-band message from Alice, connects to the queue:
1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to sign messages sent to Alice's server.
1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to sign messages sent to Alice's server.
2. Prepares the confirmation message for Alice to secure the queue. This message includes:
2. Prepares the confirmation message for Alice to secure the queue. This message includes:
- Previously generated "public" key `SK` that will be used by Alice's server to authenticate Bob's messages, once the queue is secured.
- Previously generated "public" key `SK` that will be used by Alice's server to authenticate Bob's messages, once the queue is secured.
- Optionally, any additional information (application specific, e.g. Bob's profile name and details).
- Optionally, any additional information (application specific, e.g. Bob's profile name and details).
3. Encrypts the confirmation body with the "public" key `EK` (that Alice provided via the out-of-band message).
3. Encrypts the confirmation body with the "public" key `EK` (that Alice provided via the out-of-band message).
4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be signed - signed messages will be rejected until Alice secures the queue (below).
4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be signed - signed messages will be rejected until Alice secures the queue (below).
4. Alice receives Bob's message from the server using recipient queue ID `RID` (possibly, via the same transport connection she already has opened - see `message` in [Deliver queue message](#deliver-queue-message)):
1. She decrypts received message body using the secret `SS`.
1. She decrypts received message body using the secret `SS`.
2. She decrypts received message with [key agreed with sender using] "private" key `EK`.
2. She decrypts received message with [key agreed with sender using] "private" key `EK`.
3. Even though anybody could have sent the message to the queue with ID `SID` before it is secured (e.g. if communication is compromised), Alice would ignore all messages until the decryption succeeds (i.e. the result contains the expected message format). Optionally, in the client application, she also may identify Bob using the information provided, but it is out of scope of SMP protocol.
3. Even though anybody could have sent the message to the queue with ID `SID` before it is secured (e.g. if communication is compromised), Alice would ignore all messages until the decryption succeeds (i.e. the result contains the expected message format). Optionally, in the client application, she also may identify Bob using the information provided, but it is out of scope of SMP protocol.
5. Alice secures the queue `RID` with `"KEY"` command so only Bob can send messages to it (see [Secure queue command](#secure-queue-command)):
1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests signed by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob.
1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests signed by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob.
2. From this moment the server will accept only signed commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has).
2. From this moment the server will accept only signed commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has).
3. Once queue is secured, Alice deletes `SID` and `SK` - even if Alice's client is compromised in the future, the attacker would not be able to send messages pretending to be Bob.
3. Once queue is secured, Alice deletes `SID` and `SK` - even if Alice's client is compromised in the future, the attacker would not be able to send messages pretending to be Bob.
6. The simplex queue `RID` is now ready to be used.
@@ -217,21 +214,21 @@ Bob now can securely send messages to Alice:
1. Bob sends the message:
1. He encrypts the message to Alice with "public" key `EK` (provided by Alice, only known to Bob, used only for one simplex queue).
1. He encrypts the message to Alice with "public" key `EK` (provided by Alice, only known to Bob, used only for one simplex queue).
2. He signs `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue).
2. He signs `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue).
3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will authenticate using the "public" key `SK` (that Alice earlier received from Bob and provided to the server via `"KEY"` command).
3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will authenticate using the "public" key `SK` (that Alice earlier received from Bob and provided to the server via `"KEY"` command).
2. Alice receives the message(s):
1. She signs `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)).
1. She signs `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)).
2. The server, having authenticated Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)).
2. The server, having authenticated Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)).
3. She decrypts Bob's message(s) with the "private" key `EK` (that only she has).
3. She decrypts Bob's message(s) with the "private" key `EK` (that only she has).
4. She acknowledges the message reception to the server with `"ACK"` so that the server can delete the message and deliver the next messages.
4. She acknowledges the message reception to the server with `"ACK"` so that the server can delete the message and deliver the next messages.
This flow is show on sequence diagram below.
@@ -358,22 +355,18 @@ To protect the privacy of the recipients, there are several commands in SMP prot
The clients can optionally instruct a dedicated push notification server to subscribe to notifications and deliver push notifications to the device, which can then retrieve the messages in the background and send local notifications to the user - this is out of scope of SMP protocol. The commands that SMP protocol provides to allow it:
- `enableNotifications` (`"NKEY"`) with `notifierId` (`"NID"`) response - see [Enable notifications command](#enable-notifications-command).
- `disableNotifications` (`"NDEL"`) - see [Disable notifications command](#disable-notifications-command).
- `subscribeNotifications` (`"NSUB"`) - see [Subscribe to queue notifications](#subscribe-to-queue-notifications).
- `messageNotification` (`"NMSG"`) - see [Deliver message notification](#deliver-message-notification).
[`SEND` command](#send-message) includes the notification flag to instruct SMP server whether to send the notification - this flag is forwarded to the recepient inside encrypted envelope, together with the timestamp and the message body, so even if TLS is compromised this flag cannot be used for traffic correlation.
## SMP Transmission andtransport block structure
## SMP Transmission structure
Each transport block (SMP transmission) has a fixed size of 16384 bytes for traffic uniformity.
From SMP version 4 each block can contain multiple transmissions, version 3 blocks have 1 transmission.
Some parts of SMP transmission are padded to a fixed size; this padding is uniformly added as a word16 encoded in network byte order - see `paddedString` syntax.
In places where some part of the transmission should be padded, the syntax for `paddedNotation` is used:
```abnf
```
paddedString = originalLength string pad
originalLength = 2*2 OCTET
pad = N*N"#" ; where N = paddedLength - originalLength - 2
@@ -383,9 +376,9 @@ paddedNotation = <padded(string, paddedLength)>
; paddedLength - required length after padding, including 2 bytes for originalLength
```
Each transmission/block for SMP v3 between the client and the server must have this format/syntax:
Each transmission between the client and the server must have this format/syntax:
```abnf
```
paddedTransmission = <padded(transmission), 16384>
transmission = [signature] SP signed
signed = sessionIdentifier SP [corrId] SP [queueId] SP smpCommand
@@ -402,23 +395,13 @@ encoded = <base64 encoded binary>
`base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9]
Transport block for SMP v4 has this syntax:
```abnf
paddedTransportBlock = <padded(transportBlock), 16384>
transportBlock = transmissionCount transmissions
transmissionCount = 1*1 OCTET ; equal or greater than 1
transmissions = transmissionLength transmission [transmissions]
transmissionLength = 2*2 OCTET ; word16 encoded in network byte order
```
## SMP commands
Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
```abnf
smpCommand = ping / recipientCmd / send / subscribeNotifications / serverMsg
recipientCmd = create / subscribe / secure / enableNotifications / disableNotifications /
recipientCmd = create / subscribe / secure / enableNotifications /
acknowledge / suspend / delete
serverMsg = queueIds / message / notifierId / messageNotification /
unsubscribed / ok / error
@@ -519,42 +502,22 @@ Once the queue is secured only signed messages can be sent to it.
This command is sent by the recipient to the server to add notifier's key to the queue, to allow push notifications server to receive notifications when the message arrives, via a separate queue ID, without receiving message content.
```abnf
enableNotifications = %s"NKEY " notifierKey recipientNotificationDhPublicKey
enableNotifications = %s"NKEY " notifierKey
notifierKey = length x509encoded
; the notifier's Ed25519 or Ed448 public key public key to verify NSUB command for this queue
recipientNotificationDhPublicKey = length x509encoded
; the recipient's Curve25519 key for DH exchange to derive the secret
; that the server will use to encrypt notification metadata (encryptedNMsgMeta in NMSG)
; using [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305).
```
The server will respond with `notifierId` response if notifications were enabled and the notifier's key was successfully added to the queue:
```abnf
notifierId = %s"NID " notifierId srvNotificationDhPublicKey
notifierId = %s"NID " notifierId
notifierId = length *OCTET ; 16-24 bytes
srvNotificationDhPublicKey = length x509encoded
; the server's Curve25519 key for DH exchange to derive the secret
; that the server will use to encrypt notification metadata to the recipient (encryptedNMsgMeta in NMSG)
```
This response is sent with the recipient's queue ID (the third part of the transmission).
To receive the message notifications, `subscribeNotifications` command ("NSUB") must be sent signed with the notifier's key.
#### Disable notifications command
This command is sent by the recipient to the server to remove notifier's credentials from the queue:
```abnf
disableNotifications = %s"NDEL"
```
The server must respond `ok` to this command if it was successful.
Once notifier's credentials are removed server will no longer send "NMSG" for this queue to notifier.
#### Acknowledge message delivery
The recipient should send the acknowledgement of message delivery once the message was stored in the client, to notify the server that the message should be deleted:
@@ -602,9 +565,7 @@ Currently SMP defines only one command that can be used by senders - `send` mess
This command is sent to the server by the sender both to confirm the queue after the sender received out-of-band message from the recipient and to send messages after the queue is secured:
```abnf
send = %s"SEND " msgFlags SP smpEncMessage
msgFlags = notificationFlag reserved
notificationFlag = %s"T" / %s"F"
send = %s"SEND " smpEncMessage
smpEncMessage = smpPubHeader sentMsgBody ; message up to 16088 bytes
smpPubHeader = smpClientVersion ("1" senderPublicDhKey / "0")
smpClientVersion = word16
@@ -746,11 +707,9 @@ See its syntax in [Create queue command](#create-queue-command)
The server must deliver messages to all subscribed simplex queues on the currently open transport connection. The syntax for the message delivery is:
```abnf
message = %s"MSG " msgId encryptedRcvMsgBody
message = %s"MSG " msgId SP timestamp SP encryptedMsgBody
encryptedMsgBody = <encrypt paddedSentMsgBody> ; server-encrypted padded sent msgBody
paddedSentMsgBody = <padded(sentMsgBody, maxMessageLength + 2)> ; maxMessageLength = 16088
encryptedRcvMsgBody = <encrypt rcvMsgBody> ; server-encrypted meta-data and padded sent msgBody
rcvMsgBody = timestamp msgFlags SP paddedSentMsgBody
msgId = length 24*24OCTET
timestamp = 8*8OCTET
```
@@ -776,19 +735,10 @@ See its syntax in [Enable notifications command](#enable-notifications-command)
The server must deliver message notifications to all simplex queues that were subscribed with `subscribeNotifications` command ("NSUB") on the currently open transport connection. The syntax for the message notification delivery is:
```abnf
messageNotification = %s"NMSG " nmsgNonce encryptedNMsgMeta
encryptedNMsgMeta = <encrypted message metadata passed in notification>
; metadata E2E encrypted between server and recipient containing server's message ID and timestamp (allows extension),
; to be passed to the recipient by the notifier for them to decrypt
; with key negotiated in NKEY and NID commands using nmsgNonce
nmsgNonce = <nonce used in NaCl crypto_box encryption scheme>
; nonce used by the server for encryption of message metadata, to be passed to the recipient by the notifier
; for them to use in decryption of E2E encrypted metadata
messageNotification = %s"NMSG"
```
Message notification does not contain any message data or non E2E encrypted metadata.
Message notification does not contain any message data or meta-data, it only notifies that the message is available.
#### Subscription END notification
@@ -820,7 +770,7 @@ The syntax for error responses:
```abnf
error = %s"ERR " errorType
errorType = %s"BLOCK" / %s"SESSION" / %s"CMD " cmdError / %s"AUTH" / %s"LARGE_MSG" /%s"INTERNAL"
cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_ENTITY"
cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_QUEUE"
```
Server implementations must aim to respond within the same time for each command in all cases when `"ERR AUTH"` response is required to prevent timing attacks (e.g., the server should perform signature verification even when the queue does not exist on the server or the signature of different size is sent, using any RSA key with the same size as the signature size).
@@ -842,7 +792,6 @@ ok = %s"OK"
Both the recipient and the sender can use TCP or some other, possibly higher level, transport protocol to communicate with the server. The default TCP port for SMP server is 5223.
For scenarios when meta-data privacy is critical, it is recommended that clients:
- communicating over Tor network,
- establish a separate connection for each SMP queue,
- send noise traffic (using PING command).
@@ -850,14 +799,12 @@ For scenarios when meta-data privacy is critical, it is recommended that clients
In addition to that, the servers can be deployed as Tor onion services.
The transport protocol should provide the following:
- server authentication (by matching server certificate hash with `serverIdentity`),
- forward secrecy (by encrypting the traffic using ephemeral keys agreed during transport handshake),
- integrity (preventing data modification by the attacker without detection),
- unique channel binding (`sessionIdentifier`) to include in the signed part of SMP transmissions.
By default, the client and server communicate using [TLS 1.3 protocol][13] restricted to:
- TLS_CHACHA20_POLY1305_SHA256 cipher suite (for better performance on mobile devices),
- ed25519 and ed448 EdDSA algorithms for signatures,
- x25519 and x448 ECDHE groups for key exchange.
+2 -2
View File
@@ -13,6 +13,6 @@ Change controller: Evgeny Poberezkin <ep@simplex.chat>
References:
The syntax for connection requests in the latest version of SimpleX Agent Protocol:
https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#connection-request
https://github.com/simplex-chat/simplexmq/blob/v5/protocol/agent-protocol.md#connection-request
SimpleX Messaging Protocol:
https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
https://github.com/simplex-chat/simplexmq/blob/v5/protocol/simplex-messaging.md
+1 -1
View File
@@ -13,4 +13,4 @@ Change controller: Evgeny Poberezkin <ep@simplex.chat>
References:
The syntax for message queue URIs in the latest version of SimpleX Messaging Protocol:
https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#smp-queue-uri
https://github.com/simplex-chat/simplexmq/blob/v5/protocol/simplex-messaging.md#smp-queue-uri
@@ -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.
-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
+4 -2
View File
@@ -86,6 +86,10 @@ smp-server init "${init_opts[@]}"
fingerprint=$(cat /etc/opt/simplex/fingerprint)
# Determine server address to specify in welcome script and Linode tag
# ! If FQDN was provided and used as part of server initialization, server's certificate will not pass validation at client
# ! if client tries to connect by server's IP address, so we have to specify FQDN as server address in Linode tag and
# ! in welcome script regardless of creation of A record in Linode
# ! https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
if [[ -n "$FQDN" ]]; then
server_address=$FQDN
else
@@ -153,8 +157,6 @@ Description=SMP server
[Service]
Type=simple
ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex/smp-server.log 2>&1"
KillSignal=SIGINT
TimeoutStopSec=infinity
Restart=always
RestartSec=10
LimitNOFILE=1000000
-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
+14 -144
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 3.1.0
version: 1.0.3
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -27,17 +27,11 @@ extra-source-files:
README.md
CHANGELOG.md
flag swift
description: Enable swift JSON format
manual: True
default: False
library
exposed-modules:
Simplex.Messaging.Agent
Simplex.Messaging.Agent.Client
Simplex.Messaging.Agent.Env.SQLite
Simplex.Messaging.Agent.NtfSubSupervisor
Simplex.Messaging.Agent.Protocol
Simplex.Messaging.Agent.QueryString
Simplex.Messaging.Agent.RetryInterval
@@ -47,44 +41,23 @@ library
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.M20220320_server_ips
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.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
@@ -102,10 +75,9 @@ library
, asn1-types ==0.3.*
, async ==2.2.*
, attoparsec ==0.14.*
, base >=4.14 && <5
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
@@ -117,26 +89,19 @@ library
, 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 ==3.1.*
, network-transport ==0.5.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, socks ==0.6.*
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
, text ==1.2.*
, time ==1.9.*
, time-compat ==1.9.*
, time-manager ==0.0.*
, tls >=1.6.0 && <1.7
, tls >=1.5.7 && <1.6
, transformers ==0.5.*
, unliftio ==0.2.*
, unliftio-core ==0.2.*
@@ -144,70 +109,6 @@ library
, x509 ==1.7.*
, x509-store ==1.6.*
, x509-validation ==1.6.*
if flag(swift)
cpp-options: -DswiftJSON
default-language: Haskell2010
executable ntf-server
main-is: Main.hs
other-modules:
Paths_simplexmq
hs-source-dirs:
apps/ntf-server
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
build-depends:
QuickCheck ==2.14.*
, aeson ==2.0.*
, ansi-terminal >=0.10 && <0.12
, asn1-encoding ==0.9.*
, asn1-types ==0.3.*
, async ==2.2.*
, attoparsec ==0.14.*
, base >=4.14 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
, cryptonite >=0.27 && <0.30
, cryptostore ==0.2.*
, data-default ==0.7.*
, direct-sqlite ==2.3.*
, directory ==1.3.*
, filepath ==1.4.*
, generic-random >=1.3 && <1.5
, http-types ==0.12.*
, http2 ==3.0.*
, ini ==0.4.*
, iso8601-time ==0.1.*
, memory ==0.15.*
, mtl ==2.2.*
, network >=3.1.2.7 && <3.2
, network-transport ==0.5.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
, text ==1.2.*
, time ==1.9.*
, time-compat ==1.9.*
, time-manager ==0.0.*
, tls >=1.6.0 && <1.7
, transformers ==0.5.*
, unliftio ==0.2.*
, unliftio-core ==0.2.*
, websockets ==0.12.*
, x509 ==1.7.*
, x509-store ==1.6.*
, x509-validation ==1.6.*
if flag(swift)
cpp-options: -DswiftJSON
default-language: Haskell2010
executable smp-agent
@@ -225,10 +126,9 @@ executable smp-agent
, asn1-types ==0.3.*
, async ==2.2.*
, attoparsec ==0.14.*
, base >=4.14 && <5
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
@@ -240,27 +140,20 @@ executable smp-agent
, 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 ==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.*
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
, text ==1.2.*
, time ==1.9.*
, time-compat ==1.9.*
, time-manager ==0.0.*
, tls >=1.6.0 && <1.7
, tls >=1.5.7 && <1.6
, transformers ==0.5.*
, unliftio ==0.2.*
, unliftio-core ==0.2.*
@@ -268,8 +161,6 @@ executable smp-agent
, x509 ==1.7.*
, x509-store ==1.6.*
, x509-validation ==1.6.*
if flag(swift)
cpp-options: -DswiftJSON
default-language: Haskell2010
executable smp-server
@@ -287,10 +178,9 @@ executable smp-server
, asn1-types ==0.3.*
, async ==2.2.*
, attoparsec ==0.14.*
, base >=4.14 && <5
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
@@ -302,27 +192,23 @@ executable smp-server
, 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 ==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.*
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
, text ==1.2.*
, time ==1.9.*
, time-compat ==1.9.*
, time-manager ==0.0.*
, tls >=1.6.0 && <1.7
, tls >=1.5.7 && <1.6
, transformers ==0.5.*
, unliftio ==0.2.*
, unliftio-core ==0.2.*
@@ -330,8 +216,6 @@ executable smp-server
, x509 ==1.7.*
, x509-store ==1.6.*
, x509-validation ==1.6.*
if flag(swift)
cpp-options: -DswiftJSON
default-language: Haskell2010
test-suite smp-server-test
@@ -342,14 +226,10 @@ test-suite smp-server-test
AgentTests.ConnectionRequestTests
AgentTests.DoubleRatchetTests
AgentTests.FunctionalAPITests
AgentTests.NotificationTests
AgentTests.SchemaDump
AgentTests.SQLiteTests
CoreTests.EncodingTests
CoreTests.ProtocolErrorTests
CoreTests.VersionRangeTests
NtfClient
NtfServerTests
ServerTests
SMPAgentClient
SMPClient
@@ -366,10 +246,9 @@ test-suite smp-server-test
, asn1-types ==0.3.*
, async ==2.2.*
, attoparsec ==0.14.*
, base >=4.14 && <5
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, bytestring ==0.10.*
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
@@ -383,28 +262,21 @@ test-suite smp-server-test
, 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 ==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.*
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
, text ==1.2.*
, time ==1.9.*
, time-compat ==1.9.*
, time-manager ==0.0.*
, timeit ==2.0.*
, tls >=1.6.0 && <1.7
, tls >=1.5.7 && <1.6
, transformers ==0.5.*
, unliftio ==0.2.*
, unliftio-core ==0.2.*
@@ -412,6 +284,4 @@ test-suite smp-server-test
, x509 ==1.7.*
, x509-store ==1.6.*
, x509-validation ==1.6.*
if flag(swift)
cpp-options: -DswiftJSON
default-language: Haskell2010
File diff suppressed because it is too large Load Diff
+209 -553
View File
@@ -1,48 +1,30 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Simplex.Messaging.Agent.Client
( AgentClient (..),
newAgentClient,
AgentMonad,
withAgentLock,
closeAgentClient,
closeProtocolServerClients,
newRcvQueue,
subscribeQueue,
subscribeQueues,
getQueueMessage,
decryptSMPMessage,
addSubscription,
getSubscriptions,
sendConfirmation,
sendInvitation,
RetryInterval (..),
secureQueue,
enableQueueNotifications,
disableQueueNotifications,
sendAgentMessage,
agentNtfRegisterToken,
agentNtfVerifyToken,
agentNtfCheckToken,
agentNtfReplaceToken,
agentNtfDeleteToken,
agentNtfEnableCron,
agentNtfCreateSubscription,
agentNtfCheckSubscription,
agentNtfDeleteSubscription,
agentCbEncrypt,
agentCbDecrypt,
cryptoError,
@@ -51,220 +33,188 @@ module Simplex.Messaging.Agent.Client
deleteQueue,
logServer,
removeSubscription,
hasActiveSubscription,
agentDbPath,
AgentOperation (..),
AgentOpState (..),
AgentState (..),
agentOperations,
agentOperationBracket,
beginAgentOperation,
endAgentOperation,
suspendSendingAndDatabase,
suspendOperation,
notifySuspended,
whenSuspending,
withStore,
withStore',
storeError,
)
where
import Control.Concurrent (forkIO)
import Control.Concurrent.Async (Async, uninterruptibleCancel)
import Control.Concurrent.STM (retry, stateTVar)
import Control.Concurrent.STM (stateTVar)
import Control.Logger.Simple
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Data.Bifunctor (bimap, first, second)
import Data.Bifunctor (first)
import Data.ByteString.Base64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (partitionEithers)
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 (listToMaybe)
import Data.Maybe (isNothing)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text.Encoding
import Data.Tuple (swap)
import Data.Word (Word16)
import qualified Database.SQLite.Simple as DB
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), withTransaction)
import Simplex.Messaging.Client
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Notifications.Client
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Parsers (parse)
import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, MsgFlags (..), MsgId, NotifierId, NtfPrivateSignKey, NtfPublicVerifyKey, NtfServer, ProtoServer, ProtocolServer (..), QueueId, QueueIdsKeys (..), RcvMessage (..), RcvNtfPublicDhKey, SMPMsgMeta (..), SndPublicVerifyKey)
import Simplex.Messaging.Protocol (QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util
import Simplex.Messaging.Util (bshow, liftEitherError, liftError, tryError)
import Simplex.Messaging.Version
import System.Timeout (timeout)
import UnliftIO (async)
import UnliftIO.Exception (Exception, IOException)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
type ClientVar msg = TMVar (Either AgentErrorType (ProtocolClient msg))
type SMPClientVar = TMVar (Either AgentErrorType SMPClient)
type NtfClientVar = TMVar (Either AgentErrorType NtfClient)
data AgentClient = AgentClient
{ active :: TVar Bool,
rcvQ :: TBQueue (ATransmission 'Client),
{ rcvQ :: TBQueue (ATransmission 'Client),
subQ :: TBQueue (ATransmission 'Agent),
msgQ :: TBQueue (ServerTransmission BrokerMsg),
msgQ :: TBQueue SMPServerTransmission,
smpServers :: TVar (NonEmpty SMPServer),
smpClients :: TMap SMPServer SMPClientVar,
ntfServers :: TVar [NtfServer],
ntfClients :: TMap NtfServer NtfClientVar,
useNetworkConfig :: TVar NetworkConfig,
subscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
pendingSubscrSrvrs :: TMap SMPServer (TMap ConnId RcvQueue),
subscrConns :: TMap ConnId SMPServer,
connMsgsQueued :: TMap ConnId Bool,
smpQueueMsgQueues :: TMap (ConnId, SMPServer, SMP.SenderId) (TQueue InternalId),
smpQueueMsgDeliveries :: TMap (ConnId, SMPServer, SMP.SenderId) (Async ()),
ntfNetworkOp :: TVar AgentOpState,
rcvNetworkOp :: TVar AgentOpState,
msgDeliveryOp :: TVar AgentOpState,
sndNetworkOp :: TVar AgentOpState,
databaseOp :: TVar AgentOpState,
agentState :: TVar AgentState,
getMsgLocks :: TMap (SMPServer, SMP.RecipientId) (TMVar ()),
smpClients :: TVar (Map SMPServer SMPClientVar),
subscrSrvrs :: TVar (Map SMPServer (Map ConnId RcvQueue)),
pendingSubscrSrvrs :: TVar (Map SMPServer (Map ConnId RcvQueue)),
subscrConns :: TVar (Map ConnId SMPServer),
connMsgsQueued :: TVar (Map ConnId Bool),
smpQueueMsgQueues :: TVar (Map (ConnId, SMPServer, SMP.SenderId) (TQueue InternalId)),
smpQueueMsgDeliveries :: TVar (Map (ConnId, SMPServer, SMP.SenderId) (Async ())),
reconnections :: TVar [Async ()],
asyncClients :: TVar [Async ()],
clientId :: Int,
agentEnv :: Env,
smpSubscriber :: Async (),
lock :: TMVar ()
}
data AgentOperation = AONtfNetwork | AORcvNetwork | AOMsgDelivery | AOSndNetwork | AODatabase
deriving (Eq, Show)
agentOpSel :: AgentOperation -> (AgentClient -> TVar AgentOpState)
agentOpSel = \case
AONtfNetwork -> ntfNetworkOp
AORcvNetwork -> rcvNetworkOp
AOMsgDelivery -> msgDeliveryOp
AOSndNetwork -> sndNetworkOp
AODatabase -> databaseOp
agentOperations :: [AgentClient -> TVar AgentOpState]
agentOperations = [ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp]
data AgentOpState = AgentOpState {opSuspended :: Bool, opsInProgress :: Int}
data AgentState = ASActive | ASSuspending | ASSuspended
deriving (Eq, Show)
newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
newAgentClient :: Env -> STM AgentClient
newAgentClient agentEnv = do
let qSize = tbqSize $ config agentEnv
active <- newTVar True
rcvQ <- newTBQueue qSize
subQ <- newTBQueue qSize
msgQ <- newTBQueue qSize
smpServers <- newTVar smp
smpClients <- TM.empty
ntfServers <- newTVar ntf
ntfClients <- TM.empty
useNetworkConfig <- newTVar netCfg
subscrSrvrs <- TM.empty
pendingSubscrSrvrs <- TM.empty
subscrConns <- TM.empty
connMsgsQueued <- TM.empty
smpQueueMsgQueues <- TM.empty
smpQueueMsgDeliveries <- TM.empty
ntfNetworkOp <- newTVar $ AgentOpState False 0
rcvNetworkOp <- newTVar $ AgentOpState False 0
msgDeliveryOp <- newTVar $ AgentOpState False 0
sndNetworkOp <- newTVar $ AgentOpState False 0
databaseOp <- newTVar $ AgentOpState False 0
agentState <- newTVar ASActive
getMsgLocks <- TM.empty
smpServers <- newTVar $ initialSMPServers (config agentEnv)
smpClients <- newTVar M.empty
subscrSrvrs <- newTVar M.empty
pendingSubscrSrvrs <- newTVar M.empty
subscrConns <- newTVar M.empty
connMsgsQueued <- newTVar M.empty
smpQueueMsgQueues <- newTVar M.empty
smpQueueMsgDeliveries <- newTVar M.empty
reconnections <- newTVar []
asyncClients <- newTVar []
clientId <- stateTVar (clientCounter agentEnv) $ \i -> let i' = i + 1 in (i', i')
clientId <- stateTVar (clientCounter agentEnv) $ \i -> (i + 1, i + 1)
lock <- newTMVar ()
return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, useNetworkConfig, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
return AgentClient {rcvQ, subQ, msgQ, smpServers, smpClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, asyncClients, clientId, agentEnv, smpSubscriber = undefined, lock}
agentDbPath :: AgentClient -> FilePath
agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath
-- | Agent monad with MonadReader Env and MonadError AgentErrorType
type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
class ProtocolServerClient msg where
getProtocolServerClient :: AgentMonad m => AgentClient -> ProtoServer msg -> m (ProtocolClient msg)
clientProtocolError :: ErrorType -> AgentErrorType
newtype InternalException e = InternalException {unInternalException :: e}
deriving (Eq, Show)
instance ProtocolServerClient BrokerMsg where
getProtocolServerClient = getSMPServerClient
clientProtocolError = SMP
instance Exception e => Exception (InternalException e)
instance ProtocolServerClient NtfResponse where
getProtocolServerClient = getNtfServerClient
clientProtocolError = NTF
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)
getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient
getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
atomically (getClientVar srv smpClients)
>>= either
(newProtocolClient c srv smpClients connectClient reconnectClient)
(waitForProtocolClient smpCfg)
getSMPServerClient c@AgentClient {smpClients, msgQ} srv =
atomically getClientVar >>= either newSMPClient waitForSMPClient
where
getClientVar :: STM (Either SMPClientVar SMPClientVar)
getClientVar = maybe (Left <$> newClientVar) (pure . Right) . M.lookup srv =<< readTVar smpClients
newClientVar :: STM SMPClientVar
newClientVar = do
smpVar <- newEmptyTMVar
modifyTVar smpClients $ M.insert srv smpVar
pure smpVar
waitForSMPClient :: TMVar (Either AgentErrorType SMPClient) -> m SMPClient
waitForSMPClient smpVar = do
SMPClientConfig {tcpTimeout} <- asks $ smpCfg . config
smpClient_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar smpVar)
liftEither $ case smpClient_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
Nothing -> Left $ BROKER TIMEOUT
newSMPClient :: TMVar (Either AgentErrorType SMPClient) -> m SMPClient
newSMPClient smpVar = tryConnectClient pure tryConnectAsync
where
tryConnectClient :: (SMPClient -> m a) -> m () -> m a
tryConnectClient successAction retryAction =
tryError 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 == BROKER NETWORK || e == BROKER TIMEOUT
then retryAction
else atomically $ do
putTMVar smpVar (Left e)
modifyTVar smpClients $ M.delete srv
throwError e
tryConnectAsync :: m ()
tryConnectAsync = do
a <- async connectAsync
atomically $ modifyTVar (asyncClients c) (a :)
connectAsync :: m ()
connectAsync = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
connectClient :: m SMPClient
connectClient = do
cfg <- atomically . updateClientConfig c =<< asks (smpCfg . config)
cfg <- asks $ smpCfg . config
u <- askUnliftIO
liftEitherError (protocolClientError SMP) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u)
liftEitherError smpClientError (getSMPClient srv cfg msgQ $ clientDisconnected u)
`E.catch` internalError
where
internalError :: IOException -> m SMPClient
internalError = throwError . INTERNAL . show
clientDisconnected :: UnliftIO m -> IO ()
clientDisconnected u = do
removeClientAndSubs >>= (`forM_` serverDown u)
removeClientSubs >>= (`forM_` serverDown u)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
removeClientAndSubs :: IO (Maybe (Map ConnId RcvQueue))
removeClientAndSubs = atomically $ do
TM.delete srv smpClients
TM.lookupDelete srv (subscrSrvrs c) >>= mapM updateSubs
removeClientSubs :: IO (Maybe (Map ConnId RcvQueue))
removeClientSubs = atomically $ do
modifyTVar smpClients $ M.delete srv
cs <- M.lookup srv <$> readTVar (subscrSrvrs c)
modifyTVar (subscrSrvrs c) $ M.delete srv
modifyTVar (subscrConns c) $ maybe id (deleteKeys . M.keysSet) cs
mapM_ (modifyTVar (pendingSubscrSrvrs c) . addPendingSubs) cs
return cs
where
updateSubs cVar = do
cs <- readTVar cVar
modifyTVar' (subscrConns c) (`M.withoutKeys` M.keysSet cs)
addPendingSubs cVar cs
pure cs
addPendingSubs cVar cs = do
let ps = pendingSubscrSrvrs c
TM.lookup srv ps >>= \case
Just v -> TM.union cs v
_ -> TM.insert srv cVar ps
addPendingSubs :: Map ConnId RcvQueue -> Map SMPServer (Map ConnId RcvQueue) -> Map SMPServer (Map ConnId RcvQueue)
addPendingSubs cs = M.alter (Just . addSubs cs) srv
addSubs cs = maybe cs (M.union cs)
deleteKeys :: Ord k => Set k -> Map k a -> Map k a
deleteKeys ks m = S.foldr' M.delete m ks
serverDown :: UnliftIO m -> Map ConnId RcvQueue -> IO ()
serverDown u cs = unless (M.null cs) $
whenM (readTVarIO active) $ do
let conns = M.keys cs
unless (null conns) . notifySub "" $ DOWN srv conns
atomically $ mapM_ (releaseGetLock c) cs
unliftIO u reconnectServer
serverDown u cs = unless (M.null cs) $ do
mapM_ (notifySub DOWN) $ M.keysSet cs
unliftIO u reconnectServer
reconnectServer :: m ()
reconnectServer = do
a <- async tryReconnectClient
atomically $ modifyTVar' (reconnections c) (a :)
atomically $ modifyTVar (reconnections c) (a :)
tryReconnectClient :: m ()
tryReconnectClient = do
@@ -273,129 +223,40 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
reconnectClient `catchError` const loop
reconnectClient :: m ()
reconnectClient =
withAgentLock c $
atomically (TM.lookup srv (pendingSubscrSrvrs c) >>= mapM readTVar)
>>= mapM_ resubscribe
where
resubscribe :: Map ConnId RcvQueue -> m ()
resubscribe qs = do
(errs, oks) <- M.mapEither id <$> subscribeQueues c srv qs
liftIO . unless (M.null oks) . notifySub "" . UP srv $ M.keys oks
let (tempErrs, finalErrs) = M.partition temporaryAgentError errs
liftIO . mapM_ (\(connId, e) -> notifySub connId $ ERR e) $ M.assocs finalErrs
mapM_ throwError . listToMaybe $ M.elems tempErrs
reconnectClient = do
withAgentLock c . withSMP c srv $ \smp -> do
subs <- readTVarIO $ subscrConns c
cs <- M.lookup srv <$> readTVarIO (pendingSubscrSrvrs c)
forM_ (maybe [] M.toList cs) $ \(connId, rq@RcvQueue {rcvPrivateKey, rcvId}) ->
when (isNothing $ M.lookup connId subs) $ do
subscribeSMPQueue smp rcvPrivateKey rcvId
`catchError` \case
e@SMPResponseTimeout -> throwError e
e@SMPNetworkError -> throwError e
e -> liftIO $ notifySub (ERR $ smpClientError e) connId
addSubscription c rq connId
liftIO $ notifySub UP connId
notifySub :: ConnId -> ACommand 'Agent -> IO ()
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
notifySub :: ACommand 'Agent -> ConnId -> IO ()
notifySub cmd connId = atomically $ writeTBQueue (subQ c) ("", connId, cmd)
getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfServer -> m NtfClient
getNtfServerClient c@AgentClient {active, ntfClients} srv = do
unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped"
atomically (getClientVar srv ntfClients)
>>= either
(newProtocolClient c srv ntfClients connectClient $ pure ())
(waitForProtocolClient ntfCfg)
where
connectClient :: m NtfClient
connectClient = do
cfg <- atomically . updateClientConfig c =<< asks (ntfCfg . config)
liftEitherError (protocolClientError NTF) (getProtocolClient srv cfg Nothing clientDisconnected)
clientDisconnected :: IO ()
clientDisconnected = do
atomically $ TM.delete srv ntfClients
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
getClientVar :: forall a s. ProtocolServer s -> TMap (ProtocolServer s) (TMVar a) -> STM (Either (TMVar a) (TMVar a))
getClientVar srv clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv clients
where
newClientVar :: STM (TMVar a)
newClientVar = do
var <- newEmptyTMVar
TM.insert srv var clients
pure var
waitForProtocolClient :: AgentMonad m => (AgentConfig -> ProtocolClientConfig) -> ClientVar msg -> m (ProtocolClient msg)
waitForProtocolClient clientConfig clientVar = do
ProtocolClientConfig {tcpTimeout} <- asks $ clientConfig . config
client_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar clientVar)
liftEither $ case client_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
Nothing -> Left $ BROKER TIMEOUT
newProtocolClient ::
forall msg m.
AgentMonad m =>
AgentClient ->
ProtoServer msg ->
TMap (ProtoServer msg) (ClientVar msg) ->
m (ProtocolClient msg) ->
m () ->
ClientVar msg ->
m (ProtocolClient msg)
newProtocolClient c srv clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync
where
tryConnectClient :: (ProtocolClient msg -> m a) -> m () -> m a
tryConnectClient successAction retryAction =
tryError connectClient >>= \r -> case r of
Right client -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
atomically $ putTMVar clientVar r
successAction client
Left e -> do
if temporaryAgentError e
then retryAction
else atomically $ do
putTMVar clientVar (Left e)
TM.delete srv clients
throwError e
tryConnectAsync :: m ()
tryConnectAsync = do
a <- async connectAsync
atomically $ modifyTVar' (asyncClients c) (a :)
connectAsync :: m ()
connectAsync = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
updateClientConfig :: AgentClient -> ProtocolClientConfig -> STM ProtocolClientConfig
updateClientConfig AgentClient {useNetworkConfig} cfg = do
NetworkConfig {socksProxy, tcpTimeout} <- readTVar useNetworkConfig
pure (cfg :: ProtocolClientConfig) {socksProxy, tcpTimeout}
closeAgentClient :: MonadIO m => AgentClient -> m ()
closeAgentClient :: MonadUnliftIO m => AgentClient -> m ()
closeAgentClient c = liftIO $ do
atomically $ writeTVar (active c) False
closeProtocolServerClients c smpCfg smpClients
closeProtocolServerClients c ntfCfg ntfClients
closeSMPServerClients c
cancelActions $ reconnections c
cancelActions $ asyncClients c
cancelActions $ smpQueueMsgDeliveries c
clear subscrSrvrs
clear pendingSubscrSrvrs
clear subscrConns
clear connMsgsQueued
clear smpQueueMsgQueues
clear getMsgLocks
where
clear :: (AgentClient -> TMap k a) -> IO ()
clear sel = atomically $ writeTVar (sel c) M.empty
closeProtocolServerClients :: AgentClient -> (AgentConfig -> ProtocolClientConfig) -> (AgentClient -> TMap (ProtoServer msg) (ClientVar msg)) -> IO ()
closeProtocolServerClients c cfgSel clientsSel =
readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
closeSMPServerClients :: AgentClient -> IO ()
closeSMPServerClients c = readTVarIO (smpClients c) >>= mapM_ (forkIO . closeClient)
where
cs = clientsSel c
ProtocolClientConfig {tcpTimeout} = cfgSel . config $ agentEnv c
closeClient cVar =
tcpTimeout `timeout` atomically (readTMVar cVar) >>= \case
Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
closeClient smpVar =
atomically (readTMVar smpVar) >>= \case
Right smp -> closeSMPClient smp `E.catch` \(_ :: E.SomeException) -> pure ()
_ -> pure ()
cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel >> atomically (writeTVar as mempty)
cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
cancelActions as = readTVarIO as >>= mapM_ uninterruptibleCancel
withAgentLock :: MonadUnliftIO m => AgentClient -> m a -> m a
withAgentLock AgentClient {lock} =
@@ -403,40 +264,40 @@ withAgentLock AgentClient {lock} =
(void . atomically $ takeTMVar lock)
(atomically $ putTMVar lock ())
withClient_ :: forall a m msg. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> (ProtocolClient msg -> m a) -> m a
withClient_ c srv action = (getProtocolServerClient c srv >>= action) `catchError` logServerError
withSMP_ :: forall a m. AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
withSMP_ c srv action =
(getSMPServerClient c srv >>= action) `catchError` logServerError
where
logServerError :: AgentErrorType -> m a
logServerError e = do
logServer "<--" c srv "" $ bshow e
throwError e
withLogClient_ :: (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> QueueId -> ByteString -> (ProtocolClient msg -> m a) -> m a
withLogClient_ c srv qId cmdStr action = do
withLogSMP_ :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> m a) -> m a
withLogSMP_ c srv qId cmdStr action = do
logServer "-->" c srv qId cmdStr
res <- withClient_ c srv action
res <- withSMP_ c srv action
logServer "<--" c srv qId "OK"
return res
withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
withClient c srv action = withClient_ c srv $ liftClient (clientProtocolError @msg) . action
withSMP :: AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
withSMP c srv action = withSMP_ c srv $ liftSMP . action
withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtoServer msg -> QueueId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ liftClient (clientProtocolError @msg) . action
withLogSMP :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
withLogSMP c srv qId cmdStr action = withLogSMP_ c srv qId cmdStr $ liftSMP . action
liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> ExceptT ProtocolClientError IO a -> m a
liftClient = liftError . protocolClientError
liftSMP :: AgentMonad m => ExceptT SMPClientError IO a -> m a
liftSMP = liftError smpClientError
protocolClientError :: (ErrorType -> AgentErrorType) -> ProtocolClientError -> AgentErrorType
protocolClientError protocolError_ = \case
PCEProtocolError e -> protocolError_ e
PCEResponseError e -> BROKER $ RESPONSE e
PCEUnexpectedResponse _ -> BROKER UNEXPECTED
PCEResponseTimeout -> BROKER TIMEOUT
PCENetworkError -> BROKER NETWORK
PCETransportError e -> BROKER $ TRANSPORT e
e@PCESignatureError {} -> INTERNAL $ show e
e@PCEIOError {} -> INTERNAL $ show e
smpClientError :: SMPClientError -> AgentErrorType
smpClientError = \case
SMPServerError e -> SMP e
SMPResponseError e -> BROKER $ RESPONSE e
SMPUnexpectedResponse -> BROKER UNEXPECTED
SMPResponseTimeout -> BROKER TIMEOUT
SMPNetworkError -> BROKER NETWORK
SMPTransportError e -> BROKER $ TRANSPORT e
e -> INTERNAL $ show e
newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri)
newRcvQueue c srv =
@@ -455,7 +316,7 @@ newRcvQueue_ a c srv = do
(e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
logServer "-->" c srv "" "NEW"
QIK {rcvId, sndId, rcvPublicDhKey} <-
withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
let rq =
RcvQueue
@@ -466,105 +327,58 @@ newRcvQueue_ a c srv = do
e2ePrivKey,
e2eDhSecret = Nothing,
sndId = Just sndId,
status = New,
clientNtfCreds = Nothing
status = New
}
pure (rq, SMPQueueUri srv sndId SMP.smpClientVRange e2eDhKey)
subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
whenM (atomically . TM.member (server, rcvId) $ getMsgLocks c) . throwError $ CMD PROHIBITED
atomically $ addPendingSubscription c rq connId
withLogClient c server rcvId "SUB" $ \smp ->
liftIO (runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq connId)
>>= either throwError pure
addPendingSubscription c rq connId
withLogSMP c server rcvId "SUB" $ \smp -> do
liftIO (runExceptT $ subscribeSMPQueue smp rcvPrivateKey rcvId) >>= \case
Left e -> do
atomically . when (e /= SMPNetworkError && e /= SMPResponseTimeout) $
removePendingSubscription c server connId
throwError e
Right _ -> addSubscription c rq connId
processSubResult :: AgentClient -> RcvQueue -> ConnId -> Either ProtocolClientError () -> IO (Either ProtocolClientError ())
processSubResult c rq@RcvQueue {server} connId r = do
case r of
Left e ->
atomically . unless (temporaryClientError e) $
removePendingSubscription c server connId
_ -> addSubscription c rq connId
pure r
temporaryClientError :: ProtocolClientError -> Bool
temporaryClientError = \case
PCENetworkError -> True
PCEResponseTimeout -> True
_ -> False
temporaryAgentError :: AgentErrorType -> Bool
temporaryAgentError = \case
BROKER NETWORK -> True
BROKER TIMEOUT -> True
_ -> False
-- | subscribe multiple queues - all passed queues should be on the same server
subscribeQueues :: AgentMonad m => AgentClient -> SMPServer -> Map ConnId RcvQueue -> m (Map ConnId (Either AgentErrorType ()))
subscribeQueues c srv qs = do
(errs, qs_) <- partitionEithers <$> mapM checkQueue (M.assocs qs)
forM_ qs_ $ atomically . uncurry (addPendingSubscription c) . swap
case L.nonEmpty qs_ of
Just qs' -> do
smp_ <- tryError (getSMPServerClient c srv)
M.fromList . (errs <>) <$> case smp_ of
Left e -> pure $ map (second . const $ Left e) qs_
Right smp -> do
logServer "-->" c srv (bshow (length qs_) <> " queues") "SUB"
let qs2 = L.map (queueCreds . snd) qs'
rs' :: [((ConnId, RcvQueue), Either ProtocolClientError ())] <-
liftIO $ zip qs_ . L.toList <$> subscribeSMPQueues smp qs2
forM_ rs' $ \((connId, rq), r) -> liftIO $ processSubResult c rq connId r
pure $ map (bimap fst (first $ protocolClientError SMP)) rs'
_ -> pure $ M.fromList errs
where
checkQueue rq@(connId, RcvQueue {rcvId, server}) = do
prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c
pure $ if prohibited || srv /= server then Left (connId, Left $ CMD PROHIBITED) else Right rq
queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
addSubscription :: MonadIO m => AgentClient -> RcvQueue -> ConnId -> m ()
addSubscription :: MonadUnliftIO m => AgentClient -> RcvQueue -> ConnId -> m ()
addSubscription c rq@RcvQueue {server} connId = atomically $ do
TM.insert connId server $ subscrConns c
modifyTVar (subscrConns c) $ M.insert connId server
addSubs_ (subscrSrvrs c) rq connId
removePendingSubscription c server connId
hasActiveSubscription :: AgentClient -> ConnId -> STM Bool
hasActiveSubscription c connId = TM.member connId (subscrConns c)
addPendingSubscription :: MonadUnliftIO m => AgentClient -> RcvQueue -> ConnId -> m ()
addPendingSubscription c rq connId =
atomically $ addSubs_ (pendingSubscrSrvrs c) rq connId
addPendingSubscription :: AgentClient -> RcvQueue -> ConnId -> STM ()
addPendingSubscription = addSubs_ . pendingSubscrSrvrs
addSubs_ :: TVar (Map SMPServer (Map ConnId RcvQueue)) -> RcvQueue -> ConnId -> STM ()
addSubs_ ss rq@RcvQueue {server} connId = modifyTVar ss $ M.alter (Just . addSub) server
where
addSub = maybe (M.singleton connId rq) (M.insert connId rq)
addSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> RcvQueue -> ConnId -> STM ()
addSubs_ ss rq@RcvQueue {server} connId =
TM.lookup server ss >>= \case
Just m -> TM.insert connId rq m
_ -> TM.singleton connId rq >>= \m -> TM.insert server m ss
removeSubscription :: AgentClient -> ConnId -> STM ()
removeSubscription c@AgentClient {subscrConns} connId = do
server_ <- TM.lookupDelete connId subscrConns
removeSubscription :: MonadUnliftIO m => AgentClient -> ConnId -> m ()
removeSubscription c@AgentClient {subscrConns} connId = atomically $ do
server_ <- stateTVar subscrConns $ \cs -> (M.lookup connId cs, M.delete connId cs)
mapM_ (\server -> removeSubs_ (subscrSrvrs c) server connId) server_
removePendingSubscription :: AgentClient -> SMPServer -> ConnId -> STM ()
removePendingSubscription = removeSubs_ . pendingSubscrSrvrs
removePendingSubscription c = removeSubs_ (pendingSubscrSrvrs c)
removeSubs_ :: TMap SMPServer (TMap ConnId RcvQueue) -> SMPServer -> ConnId -> STM ()
removeSubs_ ss server connId =
TM.lookup server ss >>= mapM_ (TM.delete connId)
removeSubs_ :: TVar (Map SMPServer (Map ConnId RcvQueue)) -> SMPServer -> ConnId -> STM ()
removeSubs_ ss server connId = modifyTVar ss $ M.update delSub server
where
delSub :: Map ConnId RcvQueue -> Maybe (Map ConnId RcvQueue)
delSub cs =
let cs' = M.delete connId cs
in if M.null cs' then Nothing else Just cs'
getSubscriptions :: AgentClient -> STM (Set ConnId)
getSubscriptions AgentClient {subscrConns} = do
m <- readTVar subscrConns
pure $ M.keysSet m
logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> QueueId -> ByteString -> m ()
logServer :: AgentMonad m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
logServer dir AgentClient {clientId} srv qId cmdStr =
logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
showServer :: ProtocolServer s -> ByteString
showServer ProtocolServer {host, port} =
showServer :: SMPServer -> ByteString
showServer SMPServer {host, port} =
B.pack $ host <> if null port then "" else ':' : port
logSecret :: ByteString -> ByteString
@@ -572,124 +386,51 @@ logSecret bs = encode $ B.take 3 bs
sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation =
withLogClient_ c server sndId "SEND <CONF>" $ \smp -> do
withLogSMP_ c server sndId "SEND <CONF>" $ \smp -> do
let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation
msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
liftClient SMP $ sendSMPMessage smp Nothing sndId (SMP.MsgFlags {notification = True}) msg
liftSMP $ sendSMPMessage smp Nothing sndId msg
sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> Compatible Version -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) (Compatible agentVersion) connReq connInfo =
withLogClient_ c smpServer senderId "SEND <INV>" $ \smp -> do
sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) connReq connInfo =
withLogSMP_ c smpServer senderId "SEND <INV>" $ \smp -> do
msg <- mkInvitation
liftClient SMP $ sendSMPMessage smp Nothing senderId MsgFlags {notification = True} msg
liftSMP $ sendSMPMessage smp Nothing senderId msg
where
mkInvitation :: m ByteString
-- this is only encrypted with per-queue E2E, not with double ratchet
mkInvitation = do
let agentEnvelope = AgentInvitation {agentVersion, connReq, connInfo}
let agentEnvelope = AgentInvitation {agentVersion = smpAgentVersion, connReq, connInfo}
agentCbEncryptOnce dhPublicKey . smpEncode $
SMP.ClientMessage SMP.PHEmpty $ smpEncode agentEnvelope
getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMeta)
getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
atomically createTakeGetLock
(v, msg_) <- withLogClient c server rcvId "GET" $ \smp ->
(thVersion smp,) <$> getSMPMessage smp rcvPrivateKey rcvId
mapM (decryptMeta v) msg_
where
decryptMeta v msg@SMP.RcvMessage {msgId} = SMP.rcvMessageMeta msgId <$> decryptSMPMessage v rq msg
createTakeGetLock = TM.alterF takeLock (server, rcvId) $ getMsgLocks c
where
takeLock l_ = do
l <- maybe (newTMVar ()) pure l_
takeTMVar l
pure $ Just l
decryptSMPMessage :: AgentMonad m => Version -> RcvQueue -> SMP.RcvMessage -> m SMP.ClientRcvMsgBody
decryptSMPMessage v rq SMP.RcvMessage {msgId, msgTs, msgFlags, msgBody = SMP.EncRcvMsgBody body}
| v == 1 || v == 2 = SMP.ClientRcvMsgBody msgTs msgFlags <$> decrypt body
| otherwise = liftEither . parse SMP.clientRcvMsgBodyP (AGENT A_MESSAGE) =<< decrypt body
where
decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId)
secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey =
withLogClient c server rcvId "KEY <key>" $ \smp ->
withLogSMP c server rcvId "KEY <key>" $ \smp ->
secureSMPQueue smp rcvPrivateKey rcvId senderKey
enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (NotifierId, RcvNtfPublicDhKey)
enableQueueNotifications c RcvQueue {server, rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
withLogClient c server rcvId "NKEY <nkey>" $ \smp ->
enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
disableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> m ()
disableQueueNotifications c RcvQueue {server, rcvId, rcvPrivateKey} =
withLogClient c server rcvId "NDEL" $ \smp ->
disableSMPQueueNotifications smp rcvPrivateKey rcvId
sendAck :: AgentMonad m => AgentClient -> RcvQueue -> MsgId -> m ()
sendAck c rq@RcvQueue {server, rcvId, rcvPrivateKey} msgId = do
withLogClient c server rcvId "ACK" $ \smp ->
ackSMPMessage smp rcvPrivateKey rcvId msgId
atomically $ releaseGetLock c rq
releaseGetLock :: AgentClient -> RcvQueue -> STM ()
releaseGetLock c RcvQueue {server, rcvId} =
TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ())
sendAck :: AgentMonad m => AgentClient -> RcvQueue -> m ()
sendAck c RcvQueue {server, rcvId, rcvPrivateKey} =
withLogSMP c server rcvId "ACK" $ \smp ->
ackSMPMessage smp rcvPrivateKey rcvId
suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
withLogClient c server rcvId "OFF" $ \smp ->
withLogSMP c server rcvId "OFF" $ \smp ->
suspendSMPQueue smp rcvPrivateKey rcvId
deleteQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
withLogClient c server rcvId "DEL" $ \smp ->
withLogSMP c server rcvId "DEL" $ \smp ->
deleteSMPQueue smp rcvPrivateKey rcvId
sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> MsgFlags -> ByteString -> m ()
sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} msgFlags agentMsg =
withLogClient_ c server sndId "SEND <MSG>" $ \smp -> do
sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} agentMsg =
withLogSMP_ c server sndId "SEND <MSG>" $ \smp -> do
let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
liftClient SMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msgFlags msg
agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519)
agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
withClient c ntfServer $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
agentNtfVerifyToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> m ()
agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code =
withLogClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code
agentNtfCheckToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m NtfTknStatus
agentNtfCheckToken c tknId NtfToken {ntfServer, ntfPrivKey} =
withLogClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId
agentNtfReplaceToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> DeviceToken -> m ()
agentNtfReplaceToken c tknId NtfToken {ntfServer, ntfPrivKey} token =
withLogClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token
agentNtfDeleteToken :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> m ()
agentNtfDeleteToken c tknId NtfToken {ntfServer, ntfPrivKey} =
withLogClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> Word16 -> m ()
agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval =
withLogClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> NtfPrivateSignKey -> m NtfSubscriptionId
agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =
withLogClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
agentNtfCheckSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId -> NtfToken -> m NtfSubStatus
agentNtfCheckSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
withLogClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
agentNtfDeleteSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId -> NtfToken -> m ()
agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
withLogClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
liftSMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg
agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
agentCbEncrypt SndQueue {e2eDhSecret} e2ePubKey msg = do
@@ -728,89 +469,4 @@ cryptoError = \case
C.CryptoHeaderError _ -> AGENT A_ENCRYPTION
C.AESDecryptError -> AGENT A_ENCRYPTION
C.CBDecryptError -> AGENT A_ENCRYPTION
C.CERatchetDuplicateMessage -> AGENT A_DUPLICATE
e -> INTERNAL $ show e
endAgentOperation :: AgentClient -> AgentOperation -> STM ()
endAgentOperation c op = endOperation c op $ case op of
AONtfNetwork -> pure ()
AORcvNetwork ->
suspendOperation c AOMsgDelivery $
suspendSendingAndDatabase c
AOMsgDelivery ->
suspendSendingAndDatabase c
AOSndNetwork ->
suspendOperation c AODatabase $
notifySuspended c
AODatabase ->
notifySuspended c
suspendSendingAndDatabase :: AgentClient -> STM ()
suspendSendingAndDatabase c =
suspendOperation c AOSndNetwork $
suspendOperation c AODatabase $
notifySuspended c
suspendOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
suspendOperation c op endedAction = do
n <- stateTVar (agentOpSel op c) $ \s -> (opsInProgress s, s {opSuspended = True})
-- unsafeIOToSTM $ putStrLn $ "suspendOperation_ " <> show op <> " " <> show n
when (n == 0) $ whenSuspending c endedAction
notifySuspended :: AgentClient -> STM ()
notifySuspended c = do
-- unsafeIOToSTM $ putStrLn "notifySuspended"
writeTBQueue (subQ c) ("", "", SUSPENDED)
writeTVar (agentState c) ASSuspended
endOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
endOperation c op endedAction = do
(suspended, n) <- stateTVar (agentOpSel op c) $ \s ->
let n = max 0 (opsInProgress s - 1)
in ((opSuspended s, n), s {opsInProgress = n})
-- unsafeIOToSTM $ putStrLn $ "endOperation: " <> show op <> " " <> show suspended <> " " <> show n
when (suspended && n == 0) $ whenSuspending c endedAction
whenSuspending :: AgentClient -> STM () -> STM ()
whenSuspending c = whenM ((== ASSuspending) <$> readTVar (agentState c))
beginAgentOperation :: AgentClient -> AgentOperation -> STM ()
beginAgentOperation c op = do
let opVar = agentOpSel op c
s <- readTVar opVar
-- unsafeIOToSTM $ putStrLn $ "beginOperation? " <> show op <> " " <> show (opsInProgress s)
when (opSuspended s) retry
-- unsafeIOToSTM $ putStrLn $ "beginOperation! " <> show op <> " " <> show (opsInProgress s + 1)
writeTVar opVar $! s {opsInProgress = opsInProgress s + 1}
agentOperationBracket :: MonadUnliftIO m => AgentClient -> AgentOperation -> m a -> m a
agentOperationBracket c op action =
E.bracket
(atomically $ beginAgentOperation c op)
(\_ -> atomically $ endAgentOperation c op)
(const action)
withStore' :: AgentMonad m => AgentClient -> (DB.Connection -> IO a) -> m a
withStore' c action = withStore c $ fmap Right . action
withStore :: AgentMonad m => AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> m a
withStore c action = do
st <- asks store
liftEitherError storeError . agentOperationBracket c AODatabase $
withTransaction st action `E.catch` handleInternal
where
handleInternal :: E.SomeException -> IO (Either StoreError a)
handleInternal = pure . Left . SEInternal . bshow
storeError :: StoreError -> AgentErrorType
storeError = \case
SEConnNotFound -> CONN NOT_FOUND
SEConnDuplicate -> CONN DUPLICATE
SEBadConnType CRcv -> CONN SIMPLEX
SEBadConnType CSnd -> CONN SIMPLEX
SEInvitationNotFound -> CMD PROHIBITED
-- this error is never reported as store error,
-- it is used to wrap agent operations when "transaction-like" store access is needed
-- NOTE: network IO should NOT be used inside AgentStoreMonad
SEAgentError e -> e
e -> INTERNAL $ show e
+22 -104
View File
@@ -1,171 +1,89 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
module Simplex.Messaging.Agent.Env.SQLite
( AgentMonad,
AgentConfig (..),
InitialAgentServers (..),
NetworkConfig (..),
( AgentConfig (..),
defaultAgentConfig,
defaultReconnectInterval,
Env (..),
newSMPAgentEnv,
NtfSupervisor (..),
NtfSupervisorCommand (..),
)
where
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Crypto.Random
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import Data.List.NonEmpty (NonEmpty)
import Data.Time.Clock (NominalDiffTime, nominalDay)
import Data.Word (Word16)
import GHC.Generics (Generic)
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)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (TLS, Transport (..))
import Simplex.Messaging.Transport.Client (SocksProxy, 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 NetworkConfig = NetworkConfig
{ socksProxy :: Maybe SocksProxy,
tcpTimeout :: Int
}
deriving (Show, Generic, FromJSON)
instance ToJSON NetworkConfig where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data AgentConfig = AgentConfig
{ tcpPort :: ServiceName,
initialSMPServers :: NonEmpty SMPServer,
cmdSignAlg :: C.SignAlg,
connIdBytes :: Int,
tbqSize :: Natural,
dbFile :: FilePath,
dbPoolSize :: Int,
yesToMigrations :: Bool,
smpCfg :: ProtocolClientConfig,
ntfCfg :: ProtocolClientConfig,
smpCfg :: SMPClientConfig,
reconnectInterval :: RetryInterval,
helloTimeout :: NominalDiffTime,
ntfCron :: Word16,
ntfWorkerDelay :: Int,
ntfSMPWorkerDelay :: Int,
ntfSubCheckInterval :: NominalDiffTime,
ntfMaxMessages :: Int,
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
smpAgentVersion :: Version,
smpAgentVRange :: VersionRange
certificateFile :: FilePath
}
defaultReconnectInterval :: RetryInterval
defaultReconnectInterval =
RetryInterval
{ initialInterval = second,
increaseAfter = 10 * second,
maxInterval = 10 * second
}
where
second = 1_000_000
defaultAgentConfig :: AgentConfig
defaultAgentConfig =
AgentConfig
{ tcpPort = "5224",
initialSMPServers = undefined, -- TODO move it elsewhere?
cmdSignAlg = C.SignAlg C.SEd448,
connIdBytes = 12,
tbqSize = 64,
dbFile = "smp-agent.db",
dbPoolSize = 4,
yesToMigrations = False,
smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
reconnectInterval = defaultReconnectInterval,
smpCfg = smpDefaultConfig,
reconnectInterval =
RetryInterval
{ initialInterval = second,
increaseAfter = 10 * second,
maxInterval = 10 * second
},
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",
smpAgentVersion = currentSMPAgentVersion,
smpAgentVRange = supportedSMPAgentVRange
certificateFile = "/etc/opt/simplex-agent/agent.crt"
}
where
second = 1_000_000
data Env = Env
{ config :: AgentConfig,
store :: SQLiteStore,
idsDrg :: TVar ChaChaDRG,
clientCounter :: TVar Int,
randomServer :: TVar StdGen,
ntfSupervisor :: NtfSupervisor
randomServer :: TVar StdGen
}
newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
newSMPAgentEnv config@AgentConfig {dbFile, yesToMigrations} = do
newSMPAgentEnv config@AgentConfig {dbFile, dbPoolSize, yesToMigrations} = do
idsDrg <- newTVarIO =<< drgNew
store <- liftIO $ createSQLiteStore dbFile Migrations.app yesToMigrations
store <- liftIO $ createSQLiteStore dbFile dbPoolSize Migrations.app yesToMigrations
clientCounter <- newTVarIO 0
randomServer <- newTVarIO =<< liftIO newStdGen
ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor}
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, store, idsDrg, clientCounter, randomServer}
@@ -1,359 +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 $
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 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 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 $ 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)
+36 -129
View File
@@ -7,7 +7,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -32,8 +31,8 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
module Simplex.Messaging.Agent.Protocol
( -- * Protocol parameters
currentSMPAgentVersion,
supportedSMPAgentVRange,
smpAgentVersion,
smpAgentVRange,
e2eEncConnInfoLength,
e2eEncUserMsgLength,
@@ -44,15 +43,13 @@ module Simplex.Messaging.Agent.Protocol
SAParty (..),
MsgHash,
MsgMeta (..),
ConnectionStats (..),
SMPConfirmation (..),
AgentMsgEnvelope (..),
AgentMessage (..),
AgentMessageType (..),
APrivHeader (..),
AMessage (..),
SMPServer,
pattern SMPServer,
SMPServer (..),
SrvLoc (..),
SMPQueueUri (..),
SMPQueueInfo (..),
@@ -83,8 +80,6 @@ module Simplex.Messaging.Agent.Protocol
QueueStatus (..),
ACorrId,
AgentMsgId,
NotificationsMode (..),
NotificationInfo (..),
-- * Encode/decode
serializeCommand,
@@ -113,7 +108,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Base64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Composition ((.:), (.:.))
import Data.Composition ((.:))
import Data.Functor (($>))
import Data.Int (Int64)
import Data.Kind (Type)
@@ -121,12 +116,9 @@ import qualified Data.List.NonEmpty as L
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.System (SystemTime)
import Data.Time.ISO8601
import Data.Type.Equality
import Data.Typeable ()
import Database.SQLite.Simple.FromField
import Database.SQLite.Simple.ToField
import GHC.Generics (Generic)
import Generic.Random (genericArbitraryU)
import Simplex.Messaging.Agent.QueryString
@@ -138,13 +130,10 @@ import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol
( ErrorType,
MsgBody,
MsgFlags,
MsgId,
NMsgMeta,
SMPServer,
SMPServer (..),
SndPublicVerifyKey,
SrvLoc (..),
pattern SMPServer,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
@@ -154,11 +143,11 @@ import Test.QuickCheck (Arbitrary (..))
import Text.Read
import UnliftIO.Exception (Exception)
currentSMPAgentVersion :: Version
currentSMPAgentVersion = 2
smpAgentVersion :: Version
smpAgentVersion = 1
supportedSMPAgentVRange :: VersionRange
supportedSMPAgentVRange = mkVersionRange 1 currentSMPAgentVersion
smpAgentVRange :: VersionRange
smpAgentVRange = mkVersionRange 1 smpAgentVersion
-- it is shorter to allow all handshake headers,
-- including E2E (double-ratchet) parameters and
@@ -209,79 +198,32 @@ data ACommand (p :: AParty) where
NEW :: AConnectionMode -> ACommand Client -- response INV
INV :: AConnectionRequestUri -> ACommand Agent
JOIN :: AConnectionRequestUri -> ConnInfo -> ACommand Client -- response OK
CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
CONF :: ConfirmationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
LET :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
REQ :: InvitationId -> L.NonEmpty SMPServer -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
REQ :: InvitationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
ACPT :: InvitationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
RJCT :: InvitationId -> ACommand Client
INFO :: ConnInfo -> ACommand Agent
CON :: ACommand Agent -- notification that connection is established
SUB :: ACommand Client
END :: ACommand Agent
DOWN :: SMPServer -> [ConnId] -> ACommand Agent
UP :: SMPServer -> [ConnId] -> ACommand Agent
SEND :: MsgFlags -> MsgBody -> ACommand Client
DOWN :: ACommand Agent
UP :: ACommand Agent
SEND :: MsgBody -> ACommand Client
MID :: AgentMsgId -> ACommand Agent
SENT :: AgentMsgId -> ACommand Agent
MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent
MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent
MSG :: MsgMeta -> MsgBody -> ACommand Agent
ACK :: AgentMsgId -> ACommand Client
OFF :: ACommand Client
DEL :: ACommand Client
CHK :: ACommand Client
STAT :: ConnectionStats -> ACommand Agent
OK :: ACommand Agent
ERR :: AgentErrorType -> ACommand Agent
SUSPENDED :: ACommand Agent
deriving instance Eq (ACommand p)
deriving instance Show (ACommand p)
data ConnectionStats = ConnectionStats
{ rcvServers :: [SMPServer],
sndServers :: [SMPServer]
}
deriving (Eq, Show, Generic)
instance StrEncoding ConnectionStats where
strEncode ConnectionStats {rcvServers, sndServers} =
"rcv=" <> strEncodeList rcvServers <> " snd=" <> strEncodeList sndServers
strP = do
rcvServers <- "rcv=" *> strListP
sndServers <- " snd=" *> strListP
pure ConnectionStats {rcvServers, sndServers}
instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions
data NotificationsMode = NMPeriodic | NMInstant
deriving (Eq, Show)
instance StrEncoding NotificationsMode where
strEncode = \case
NMPeriodic -> "PERIODIC"
NMInstant -> "INSTANT"
strP =
A.takeTill (== ' ') >>= \case
"PERIODIC" -> pure NMPeriodic
"INSTANT" -> pure NMInstant
_ -> fail "bad NotificationsMode"
instance ToJSON NotificationsMode where
toEncoding = strToJEncoding
toJSON = strToJSON
instance ToField NotificationsMode where toField = toField . strEncode
instance FromField NotificationsMode where fromField = blobFieldDecoder $ parseAll strP
data NotificationInfo = NotificationInfo
{ ntfConnId :: ConnId,
ntfTs :: SystemTime,
ntfMsgMeta :: Maybe NMsgMeta
}
deriving (Show)
data ConnectionMode = CMInvitation | CMContact
deriving (Eq, Show)
@@ -342,9 +284,7 @@ data SMPConfirmation = SMPConfirmation
-- | sender's DH public key for simple per-queue e2e encryption
e2ePubKey :: C.PublicKeyX25519,
-- | sender's information to be associated with the connection, e.g. sender's profile information
connInfo :: ConnInfo,
-- | optional reply queues included in confirmation (added in agent protocol v2)
smpReplyQueues :: [SMPQueueInfo]
connInfo :: ConnInfo
}
deriving (Show)
@@ -390,40 +330,31 @@ instance Encoding AgentMsgEnvelope where
-- SMP agent message formats (after double ratchet decryption,
-- or in case of AgentInvitation - in plain text body)
data AgentMessage
= AgentConnInfo ConnInfo
| -- AgentConnInfoReply is only used in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
-- It makes REPLY message unnecessary.
AgentConnInfoReply (L.NonEmpty SMPQueueInfo) ConnInfo
| AgentMessage APrivHeader AMessage
data AgentMessage = AgentConnInfo ConnInfo | AgentMessage APrivHeader AMessage
deriving (Show)
instance Encoding AgentMessage where
smpEncode = \case
AgentConnInfo cInfo -> smpEncode ('I', Tail cInfo)
AgentConnInfoReply smpQueues cInfo -> smpEncode ('D', smpQueues, Tail cInfo) -- 'D' stands for "duplex"
AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg)
smpP =
smpP >>= \case
'I' -> AgentConnInfo . unTail <$> smpP
'D' -> AgentConnInfoReply <$> smpP <*> (unTail <$> smpP)
'M' -> AgentMessage <$> smpP <*> smpP
_ -> fail "bad AgentMessage"
data AgentMessageType = AM_CONN_INFO | AM_CONN_INFO_REPLY | AM_HELLO_ | AM_REPLY_ | AM_A_MSG_
data AgentMessageType = AM_CONN_INFO | AM_HELLO_ | AM_REPLY_ | AM_A_MSG_
deriving (Eq, Show)
instance Encoding AgentMessageType where
smpEncode = \case
AM_CONN_INFO -> "C"
AM_CONN_INFO_REPLY -> "D"
AM_HELLO_ -> "H"
AM_REPLY_ -> "R"
AM_A_MSG_ -> "M"
smpP =
A.anyChar >>= \case
'C' -> pure AM_CONN_INFO
'D' -> pure AM_CONN_INFO_REPLY
'H' -> pure AM_HELLO_
'R' -> pure AM_REPLY_
'M' -> pure AM_A_MSG_
@@ -432,14 +363,8 @@ instance Encoding AgentMessageType where
agentMessageType :: AgentMessage -> AgentMessageType
agentMessageType = \case
AgentConnInfo _ -> AM_CONN_INFO
AgentConnInfoReply {} -> AM_CONN_INFO_REPLY
AgentMessage _ aMsg -> case aMsg of
-- HELLO is used both in v1 and in v2, but differently.
-- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times,
-- until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it.
-- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured.
HELLO -> AM_HELLO_
-- REPLY is only used in v1
REPLY _ -> AM_REPLY_
A_MSG _ -> AM_A_MSG_
@@ -614,6 +539,7 @@ data SMPQueueUri = SMPQueueUri
}
deriving (Eq, Show)
-- TODO change SMP queue URI format to include version range and allow unknown parameters
instance StrEncoding SMPQueueUri where
-- v1 uses short SMP queue URI format
strEncode SMPQueueUri {smpServer = srv, senderId = qId, clientVRange = _vr, dhPublicKey = k} =
@@ -758,15 +684,13 @@ data AgentErrorType
CONN {connErr :: ConnectionErrorType}
| -- | SMP protocol errors forwarded to agent clients
SMP {smpErr :: ErrorType}
| -- | NTF protocol errors forwarded to agent clients
NTF {ntfErr :: ErrorType}
| -- | SMP server errors
BROKER {brokerErr :: BrokerErrorType}
| -- | errors of other agents
AGENT {agentErr :: SMPAgentError}
| -- | agent implementation or dependency errors
INTERNAL {internalErr :: String}
deriving (Eq, Generic, Show, Exception)
deriving (Eq, Generic, Read, Show, Exception)
instance ToJSON AgentErrorType where
toJSON = J.genericToJSON $ sumTypeJSON id
@@ -837,8 +761,6 @@ data SMPAgentError
A_VERSION
| -- | cannot decrypt message
A_ENCRYPTION
| -- | duplicate message - this error is detected by ratchet decryption - this message will be ignored and not shown
A_DUPLICATE
deriving (Eq, Generic, Read, Show, Exception)
instance ToJSON SMPAgentError where
@@ -850,7 +772,6 @@ instance StrEncoding AgentErrorType where
"CMD " *> (CMD <$> parseRead1)
<|> "CONN " *> (CONN <$> parseRead1)
<|> "SMP " *> (SMP <$> strP)
<|> "NTF " *> (NTF <$> strP)
<|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> strP)
<|> "BROKER TRANSPORT " *> (BROKER . TRANSPORT <$> transportErrorP)
<|> "BROKER " *> (BROKER <$> parseRead1)
@@ -860,7 +781,6 @@ instance StrEncoding AgentErrorType where
CMD e -> "CMD " <> bshow e
CONN e -> "CONN " <> bshow e
SMP e -> "SMP " <> strEncode e
NTF e -> "NTF " <> strEncode e
BROKER (RESPONSE e) -> "BROKER RESPONSE " <> strEncode e
BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e
BROKER e -> "BROKER " <> bshow e
@@ -891,8 +811,8 @@ commandP =
<|> "INFO " *> infoCmd
<|> "SUB" $> ACmd SClient SUB
<|> "END" $> ACmd SAgent END
<|> "DOWN " *> downsResp
<|> "UP " *> upsResp
<|> "DOWN" $> ACmd SAgent DOWN
<|> "UP" $> ACmd SAgent UP
<|> "SEND " *> sendCmd
<|> "MID " *> msgIdResp
<|> "SENT " *> sentResp
@@ -901,8 +821,6 @@ commandP =
<|> "ACK " *> ackCmd
<|> "OFF" $> ACmd SClient OFF
<|> "DEL" $> ACmd SClient DEL
<|> "CHK" $> ACmd SClient CHK
<|> "STAT " *> statResp
<|> "ERR " *> agentError
<|> "CON" $> ACmd SAgent CON
<|> "OK" $> ACmd SAgent OK
@@ -910,22 +828,18 @@ commandP =
newCmd = ACmd SClient . NEW <$> strP
invResp = ACmd SAgent . INV <$> strP
joinCmd = ACmd SClient .: JOIN <$> strP_ <*> A.takeByteString
confMsg = ACmd SAgent .:. CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> A.takeByteString
confMsg = ACmd SAgent .: CONF <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
letCmd = ACmd SClient .: LET <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
reqMsg = ACmd SAgent .:. REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> A.takeByteString
reqMsg = ACmd SAgent .: REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
acptCmd = ACmd SClient .: ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
rjctCmd = ACmd SClient . RJCT <$> A.takeByteString
infoCmd = ACmd SAgent . INFO <$> A.takeByteString
downsResp = ACmd SAgent .: DOWN <$> strP_ <*> connections
upsResp = ACmd SAgent .: UP <$> strP_ <*> connections
sendCmd = ACmd SClient .: SEND <$> smpP <* A.space <*> A.takeByteString
sendCmd = ACmd SClient . SEND <$> A.takeByteString
msgIdResp = ACmd SAgent . MID <$> A.decimal
sentResp = ACmd SAgent . SENT <$> A.decimal
msgErrResp = ACmd SAgent .: MERR <$> A.decimal <* A.space <*> strP
message = ACmd SAgent .:. MSG <$> msgMetaP <* A.space <*> smpP <* A.space <*> A.takeByteString
message = ACmd SAgent .: MSG <$> msgMetaP <* A.space <*> A.takeByteString
ackCmd = ACmd SClient . ACK <$> A.decimal
statResp = ACmd SAgent . STAT <$> strP
connections = strP `A.sepBy'` A.char ','
msgMetaP = do
integrity <- strP
recipient <- " R=" *> partyMeta A.decimal
@@ -944,35 +858,30 @@ serializeCommand = \case
NEW cMode -> "NEW " <> strEncode cMode
INV cReq -> "INV " <> strEncode cReq
JOIN cReq cInfo -> B.unwords ["JOIN", strEncode cReq, serializeBinary cInfo]
CONF confId srvs cInfo -> B.unwords ["CONF", confId, strEncodeList srvs, serializeBinary cInfo]
CONF confId cInfo -> B.unwords ["CONF", confId, serializeBinary cInfo]
LET confId cInfo -> B.unwords ["LET", confId, serializeBinary cInfo]
REQ invId srvs cInfo -> B.unwords ["REQ", invId, strEncode srvs, serializeBinary cInfo]
REQ invId cInfo -> B.unwords ["REQ", invId, serializeBinary cInfo]
ACPT invId cInfo -> B.unwords ["ACPT", invId, serializeBinary cInfo]
RJCT invId -> "RJCT " <> invId
INFO cInfo -> "INFO " <> serializeBinary cInfo
SUB -> "SUB"
END -> "END"
DOWN srv conns -> B.unwords ["DOWN", strEncode srv, connections conns]
UP srv conns -> B.unwords ["UP", strEncode srv, connections conns]
SEND msgFlags msgBody -> "SEND " <> smpEncode msgFlags <> " " <> serializeBinary msgBody
DOWN -> "DOWN"
UP -> "UP"
SEND msgBody -> "SEND " <> serializeBinary msgBody
MID mId -> "MID " <> bshow mId
SENT mId -> "SENT " <> bshow mId
MERR mId e -> B.unwords ["MERR", bshow mId, strEncode e]
MSG msgMeta msgFlags msgBody -> B.unwords ["MSG", serializeMsgMeta msgMeta, smpEncode msgFlags, serializeBinary msgBody]
MSG msgMeta msgBody -> B.unwords ["MSG", serializeMsgMeta msgMeta, serializeBinary msgBody]
ACK mId -> "ACK " <> bshow mId
OFF -> "OFF"
DEL -> "DEL"
CHK -> "CHK"
STAT srvs -> "STAT " <> strEncode srvs
CON -> "CON"
ERR e -> "ERR " <> strEncode e
OK -> "OK"
SUSPENDED -> "SUSPENDED"
where
showTs :: UTCTime -> ByteString
showTs = B.pack . formatISO8601Millis
connections :: [ConnId] -> ByteString
connections = B.intercalate "," . map strEncode
serializeMsgMeta :: MsgMeta -> ByteString
serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
B.unwords
@@ -1024,8 +933,6 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
ACPT {} -> Right cmd
-- ERROR response does not always have connId
ERR _ -> Right cmd
DOWN {} -> Right cmd
UP {} -> Right cmd
-- other responses must have connId
_
| B.null connId -> Left $ CMD NO_CONN
@@ -1033,12 +940,12 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
cmdWithMsgBody :: ACommand p -> m (Either AgentErrorType (ACommand p))
cmdWithMsgBody = \case
SEND msgFlags body -> SEND msgFlags <$$> getBody body
MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
SEND body -> SEND <$$> getBody body
MSG msgMeta body -> MSG msgMeta <$$> getBody body
JOIN qUri cInfo -> JOIN qUri <$$> getBody cInfo
CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
CONF confId cInfo -> CONF confId <$$> getBody cInfo
LET confId cInfo -> LET confId <$$> getBody cInfo
REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
REQ invId cInfo -> REQ invId <$$> getBody cInfo
ACPT invId cInfo -> ACPT invId <$$> getBody cInfo
INFO cInfo -> INFO <$$> getBody cInfo
cmd -> pure $ Right cmd
+6 -6
View File
@@ -31,17 +31,17 @@ import UnliftIO.STM
-- | Runs an SMP agent as a TCP service using passed configuration.
--
-- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> m ()
runSMPAgent t cfg initServers = do
runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> m ()
runSMPAgent t cfg = do
started <- newEmptyTMVarIO
runSMPAgentBlocking t started cfg initServers
runSMPAgentBlocking t started cfg
-- | Runs an SMP agent as a TCP service using passed configuration with signalling.
--
-- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
-- and when it is disconnected from the TCP socket once the server thread is killed (False).
runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> InitialAgentServers -> m ()
runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers = do
runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> m ()
runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} = do
runReaderT (smpAgent t) =<< newSMPAgentEnv cfg
where
smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()
@@ -50,7 +50,7 @@ runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertifica
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
runTransportServer started tcpPort tlsServerParams $ \(h :: c) -> do
liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
c <- getAgentClient initServers
c <- getAgentClient
logConnection c True
race_ (connectClient h c) (runAgentClient c)
`E.finally` disconnectAgentClient c
+55 -44
View File
@@ -9,7 +9,9 @@
module Simplex.Messaging.Agent.Store where
import Control.Concurrent.STM (TVar)
import Control.Exception (Exception)
import Crypto.Random (ChaChaDRG)
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import Data.Kind (Type)
@@ -17,21 +19,61 @@ 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.Crypto.Ratchet (RatchetX448, SkippedMsgDiff, SkippedMsgKeys)
import Simplex.Messaging.Protocol
( MsgBody,
MsgFlags,
MsgId,
NotifierId,
NtfPrivateSignKey,
NtfPublicVerifyKey,
RcvDhSecret,
RcvNtfDhSecret,
RcvPrivateSignKey,
SndPrivateSignKey,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Version
-- * Store management
-- | Store class type. Defines store access methods for implementations.
class Monad m => MonadAgentStore s m where
-- Queue and Connection management
createRcvConn :: s -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId
createSndConn :: s -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId
getConn :: s -> ConnId -> m SomeConn
getRcvConn :: s -> SMPServer -> SMP.RecipientId -> m SomeConn
deleteConn :: s -> ConnId -> m ()
upgradeRcvConnToDuplex :: s -> ConnId -> SndQueue -> m ()
upgradeSndConnToDuplex :: s -> ConnId -> RcvQueue -> m ()
setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m ()
setRcvQueueConfirmedE2E :: s -> RcvQueue -> C.DhSecretX25519 -> m ()
setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()
-- Confirmations
createConfirmation :: s -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
acceptConfirmation :: s -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
getAcceptedConfirmation :: s -> ConnId -> m AcceptedConfirmation
removeConfirmations :: s -> ConnId -> m ()
-- Invitations - sent via Contact connections
createInvitation :: s -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
getInvitation :: s -> InvitationId -> m Invitation
acceptInvitation :: s -> InvitationId -> ConnInfo -> m ()
deleteInvitation :: s -> ConnId -> InvitationId -> m ()
-- Msg management
updateRcvIds :: s -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
createRcvMsg :: s -> ConnId -> RcvMsgData -> m ()
updateSndIds :: s -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)
createSndMsg :: s -> ConnId -> SndMsgData -> m ()
getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, (AgentMessageType, MsgBody, InternalTs))
getPendingMsgs :: s -> ConnId -> m [InternalId]
checkRcvMsg :: s -> ConnId -> InternalId -> m ()
deleteMsg :: s -> ConnId -> InternalId -> m ()
-- Double ratchet persistence
createRatchetX3dhKeys :: s -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> m ()
getRatchetX3dhKeys :: s -> ConnId -> m (C.PrivateKeyX448, C.PrivateKeyX448)
createRatchet :: s -> ConnId -> RatchetX448 -> m ()
getRatchet :: s -> ConnId -> m RatchetX448
getSkippedMsgKeys :: s -> ConnId -> m SkippedMsgKeys
updateRatchet :: s -> ConnId -> RatchetX448 -> SkippedMsgDiff -> m ()
-- * Queue types
@@ -51,20 +93,7 @@ data RcvQueue = RcvQueue
-- | sender queue ID
sndId :: Maybe SMP.SenderId,
-- | queue status
status :: QueueStatus,
-- | credentials used in context of notifications
clientNtfCreds :: Maybe ClientNtfCreds
}
deriving (Eq, Show)
data ClientNtfCreds = ClientNtfCreds
{ -- | key pair to be used by the notification server to sign transmissions
ntfPublicKey :: NtfPublicVerifyKey,
ntfPrivateKey :: NtfPrivateSignKey,
-- | queue ID to be used by the notification server for NSUB command
notifierId :: NotifierId,
-- | shared DH secret used to encrypt/decrypt notification metadata (NMsgMeta) from server to recipient
rcvNtfDhSecret :: RcvNtfDhSecret
status :: QueueStatus
}
deriving (Eq, Show)
@@ -144,11 +173,7 @@ instance Eq SomeConn where
deriving instance Show SomeConn
data ConnData = ConnData
{ connId :: ConnId,
connAgentVersion :: Version,
duplexHandshake :: Maybe Bool -- added in agent protocol v2
}
newtype ConnData = ConnData {connId :: ConnId}
deriving (Eq, Show)
-- * Confirmation types
@@ -195,42 +220,30 @@ type PrevRcvMsgHash = MsgHash
-- | Corresponds to `last_snd_msg_hash` in `connections` table
type PrevSndMsgHash = MsgHash
-- * Message data containers
-- * Message data containers - used on Msg creation to reduce number of parameters
data RcvMsgData = RcvMsgData
{ msgMeta :: MsgMeta,
msgType :: AgentMessageType,
msgFlags :: MsgFlags,
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
}
data PendingMsgData = PendingMsgData
{ msgId :: InternalId,
msgType :: AgentMessageType,
msgFlags :: MsgFlags,
msgBody :: MsgBody,
internalTs :: InternalTs
data PendingMsg = PendingMsg
{ connId :: ConnId,
msgId :: InternalId
}
deriving (Show)
@@ -298,6 +311,4 @@ data StoreError
SEX3dhKeysNotFound
| -- | Used in `getMsg` that is not implemented/used. TODO remove.
SENotImplemented
| -- | Used to wrap agent errors inside store operations to avoid race conditions
SEAgentError AgentErrorType
deriving (Eq, Show, Exception)
File diff suppressed because it is too large Load Diff
@@ -16,8 +16,8 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations
where
import Control.Monad (forM_)
import Data.Function (on)
import Data.List (intercalate, sortBy)
import Data.Ord (comparing)
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (Connection, Only (..), Query (..))
@@ -26,9 +26,7 @@ import Database.SQLite.Simple.QQ (sql)
import qualified Database.SQLite3 as SQLite3
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.M20220320_server_ips
data Migration = Migration {name :: String, up :: Text}
deriving (Show)
@@ -37,14 +35,12 @@ 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)
("20220320_server_ips", m20220320_server_ips)
]
-- | The list of migrations in ascending order by date
app :: [Migration]
app = sortBy (comparing name) $ map migration schemaMigrations
app = sortBy (compare `on` name) $ map migration schemaMigrations
where
migration (name, query) = Migration {name = name, up = fromQuery query}
@@ -0,0 +1,14 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220320_server_ips where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220320_server_ips :: Query
m20220320_server_ips =
[sql|
UPDATE servers SET host = '178.79.168.175' WHERE host = 'smp8.simplex.im';
UPDATE servers SET host = '178.79.169.107' WHERE host = 'smp9.simplex.im';
UPDATE servers SET host = '45.33.54.229' WHERE host = 'smp10.simplex.im';
|]
@@ -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,194 +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
) 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
) 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;
+145 -244
View File
@@ -1,12 +1,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@@ -25,33 +23,27 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
module Simplex.Messaging.Client
( -- * Connect (disconnect) client to (from) SMP server
ProtocolClient (thVersion, sessionId),
SMPClient,
getProtocolClient,
closeProtocolClient,
getSMPClient,
closeSMPClient,
-- * SMP protocol command functions
createSMPQueue,
subscribeSMPQueue,
subscribeSMPQueues,
getSMPMessage,
subscribeSMPQueueNotifications,
secureSMPQueue,
enableSMPQueueNotifications,
disableSMPQueueNotifications,
enableSMPQueuesNtfs,
disableSMPQueuesNtfs,
sendSMPMessage,
ackSMPMessage,
suspendSMPQueue,
deleteSMPQueue,
sendProtocolCommand,
sendSMPCommand,
-- * Supporting types and client configuration
ProtocolClientError (..),
ProtocolClientConfig (..),
defaultClientConfig,
ServerTransmission,
SMPClientError (..),
SMPClientConfig (..),
smpDefaultConfig,
SMPServerTransmission,
)
where
@@ -60,116 +52,96 @@ import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (rights)
import Data.Functor (($>))
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 Network.Socket (ServiceName)
import Numeric.Natural
import qualified Simplex.Messaging.Crypto as C
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, runTransportClient)
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Protocol
import Simplex.Messaging.Transport (ATransport (..), THandle (..), TLS, TProxy, Transport (..), TransportError, clientHandshake)
import Simplex.Messaging.Transport.Client (runTransportClient)
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (bshow, liftError, raceAny_)
import Simplex.Messaging.Version
import System.Timeout (timeout)
-- | 'SMPClient' is a handle used to send commands to a specific SMP server.
--
-- The only exported selector is blockSize that is negotiated
-- with the server during the TCP transport handshake.
--
-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
data ProtocolClient msg = ProtocolClient
data SMPClient = SMPClient
{ action :: Async (),
connected :: TVar Bool,
sessionId :: SessionId,
thVersion :: Version,
protocolServer :: ProtoServer msg,
sessionId :: ByteString,
smpServer :: SMPServer,
tcpTimeout :: Int,
clientCorrId :: TVar Natural,
sentCommands :: TMap CorrId (Request msg),
sndQ :: TBQueue (NonEmpty (SentRawTransmission)),
rcvQ :: TBQueue (NonEmpty (SignedTransmission msg)),
msgQ :: Maybe (TBQueue (ServerTransmission msg))
sentCommands :: TVar (Map CorrId Request),
sndQ :: TBQueue SentRawTransmission,
rcvQ :: TBQueue (SignedTransmission BrokerMsg),
msgQ :: TBQueue SMPServerTransmission
}
type SMPClient = ProtocolClient SMP.BrokerMsg
-- | Type for client command data
type ClientCommand msg = (Maybe C.APrivateSignKey, QueueId, ProtoCommand msg)
-- | Type synonym for transmission from some SPM server queue.
type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg)
type SMPServerTransmission = (SMPServer, RecipientId, BrokerMsg)
-- | 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),
-- | timeout of TCP commands (microseconds)
tcpTimeout :: Int,
-- | TCP keep-alive options, Nothing to skip enabling keep-alive
tcpKeepAlive :: Maybe KeepAliveOpts,
-- | use SOCKS5 proxy
socksProxy :: Maybe SocksProxy,
-- | period for SMP ping commands (microseconds)
smpPing :: Int,
-- | SMP client-server protocol version range
smpServerVRange :: VersionRange
smpPing :: Int
}
-- | Default protocol client configuration.
defaultClientConfig :: ProtocolClientConfig
defaultClientConfig =
ProtocolClientConfig
-- | Default SMP client configuration.
smpDefaultConfig :: SMPClientConfig
smpDefaultConfig =
SMPClientConfig
{ qSize = 64,
defaultTransport = ("443", transport @TLS),
tcpTimeout = 5_000_000,
tcpKeepAlive = Just defaultKeepAliveOpts,
socksProxy = Nothing,
smpPing = 600_000_000, -- 10min
smpServerVRange = supportedSMPServerVRange
defaultTransport = ("5223", transport @TLS),
tcpTimeout = 4_000_000,
smpPing = 30_000_000
}
data Request msg = Request
data Request = Request
{ queueId :: QueueId,
responseVar :: TMVar (Response msg)
responseVar :: TMVar Response
}
type Response msg = Either ProtocolClientError msg
type Response = Either SMPClientError BrokerMsg
-- | 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)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, socksProxy, smpPing, smpServerVRange} msgQ disconnected =
(atomically mkProtocolClient >>= runClient useTransport)
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)
getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing} msgQ disconnected =
atomically mkSMPClient >>= runClient useTransport
where
mkProtocolClient :: STM (ProtocolClient msg)
mkProtocolClient = do
mkSMPClient :: STM SMPClient
mkSMPClient = do
connected <- newTVar False
clientCorrId <- newTVar 0
sentCommands <- TM.empty
sentCommands <- newTVar M.empty
sndQ <- newTBQueue qSize
rcvQ <- newTBQueue qSize
return
ProtocolClient
SMPClient
{ action = undefined,
sessionId = undefined,
thVersion = undefined,
connected,
protocolServer,
smpServer,
tcpTimeout,
clientCorrId,
sentCommands,
@@ -178,106 +150,101 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
msgQ
}
runClient :: (ServiceName, ATransport) -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
runClient :: (ServiceName, ATransport) -> SMPClient -> IO (Either SMPClientError SMPClient)
runClient (port', ATransport t) c = do
thVar <- newEmptyTMVarIO
action <-
async $
runTransportClient socksProxy (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
`finally` atomically (putTMVar thVar $ Left PCENetworkError)
runTransportClient (host smpServer) port' (keyHash smpServer) (client t c thVar)
`finally` atomically (putTMVar thVar $ Left SMPNetworkError)
th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
pure $ case th_ of
Just (Right THandle {sessionId, thVersion}) -> Right c {action, sessionId, thVersion}
Just (Right THandle {sessionId}) -> Right c {action, sessionId}
Just (Left e) -> Left e
Nothing -> Left PCENetworkError
Nothing -> Left SMPNetworkError
useTransport :: (ServiceName, ATransport)
useTransport = case port protocolServer of
useTransport = case port smpServer of
"" -> defaultTransport cfg
"80" -> ("80", transport @WS)
p -> (p, transport @TLS)
client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError (THandle c)) -> c -> IO ()
client _ c thVar h =
runExceptT (protocolClientHandshake @msg h (keyHash protocolServer) smpServerVRange) >>= \case
Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
Right th@THandle {sessionId, thVersion} -> do
runExceptT (clientHandshake h $ keyHash smpServer) >>= \case
Left e -> atomically . putTMVar thVar . Left $ SMPTransportError e
Right th@THandle {sessionId} -> do
atomically $ do
writeTVar (connected c) True
putTMVar thVar $ Right th
let c' = c {sessionId, thVersion} :: ProtocolClient msg
-- TODO remove ping if 0 is passed (or Nothing?)
let c' = c {sessionId} :: SMPClient
raceAny_ [send c' th, process c', receive c' th, ping c']
`finally` disconnected
send :: Transport c => ProtocolClient msg -> THandle c -> IO ()
send ProtocolClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
send :: Transport c => SMPClient -> THandle c -> IO ()
send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
receive :: Transport c => ProtocolClient msg -> THandle c -> IO ()
receive ProtocolClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
receive :: Transport c => SMPClient -> THandle c -> IO ()
receive SMPClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
ping :: ProtocolClient msg -> IO ()
ping :: SMPClient -> IO ()
ping c = forever $ do
threadDelay smpPing
runExceptT $ sendProtocolCommand c Nothing "" protocolPing
runExceptT $ sendSMPCommand c Nothing "" PING
process :: ProtocolClient msg -> IO ()
process c = forever $ atomically (readTBQueue $ rcvQ c) >>= mapM_ (processMsg c)
processMsg :: ProtocolClient msg -> SignedTransmission msg -> IO ()
processMsg c@ProtocolClient {sentCommands} (_, _, (corrId, qId, respOrErr)) =
process :: SMPClient -> IO ()
process SMPClient {rcvQ, sentCommands} = forever $ do
(_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
if B.null $ bs corrId
then sendMsg respOrErr
then sendMsg qId respOrErr
else do
atomically (TM.lookup corrId sentCommands) >>= \case
Nothing -> sendMsg respOrErr
cs <- readTVarIO sentCommands
case M.lookup corrId cs of
Nothing -> sendMsg qId respOrErr
Just Request {queueId, responseVar} -> atomically $ do
TM.delete corrId sentCommands
modifyTVar sentCommands $ M.delete corrId
putTMVar responseVar $
if queueId == qId
then case respOrErr of
Left e -> Left $ PCEResponseError e
Right r -> case protocolError r of
Just e -> Left $ PCEProtocolError e
_ -> Right r
else Left . PCEUnexpectedResponse $ bshow respOrErr
where
sendMsg :: Either ErrorType msg -> IO ()
sendMsg = \case
Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c qId msg) msgQ
-- TODO send everything else to errQ and log in agent
_ -> return ()
Left e -> Left $ SMPResponseError e
Right (ERR e) -> Left $ SMPServerError e
Right r -> Right r
else Left SMPUnexpectedResponse
-- | Disconnects client from the server and terminates client threads.
closeProtocolClient :: ProtocolClient msg -> IO ()
closeProtocolClient = uninterruptibleCancel . action
sendMsg :: QueueId -> Either ErrorType BrokerMsg -> IO ()
sendMsg qId = \case
Right cmd -> atomically $ writeTBQueue msgQ (smpServer, qId, cmd)
-- TODO send everything else to errQ and log in agent
_ -> return ()
-- | Disconnects SMP client from the server and terminates client threads.
closeSMPClient :: SMPClient -> IO ()
closeSMPClient = uninterruptibleCancel . action
-- | SMP client error type.
data ProtocolClientError
data SMPClientError
= -- | Correctly parsed SMP server ERR response.
-- This error is forwarded to the agent client as `ERR SMP err`.
PCEProtocolError ErrorType
SMPServerError ErrorType
| -- | Invalid server response that failed to parse.
-- Forwarded to the agent client as `ERR BROKER RESPONSE`.
PCEResponseError ErrorType
SMPResponseError ErrorType
| -- | Different response from what is expected to a certain SMP command,
-- e.g. server should respond `IDS` or `ERR` to `NEW` command,
-- other responses would result in this error.
-- Forwarded to the agent client as `ERR BROKER UNEXPECTED`.
PCEUnexpectedResponse ByteString
SMPUnexpectedResponse
| -- | Used for TCP connection and command response timeouts.
-- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
PCEResponseTimeout
SMPResponseTimeout
| -- | Failure to establish TCP connection.
-- Forwarded to the agent client as `ERR BROKER NETWORK`.
PCENetworkError
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.
@@ -288,181 +255,115 @@ createSMPQueue ::
RcvPrivateSignKey ->
RcvPublicVerifyKey ->
RcvPublicDhKey ->
ExceptT ProtocolClientError IO QueueIdsKeys
ExceptT SMPClientError IO QueueIdsKeys
createSMPQueue c rpKey rKey dhKey =
sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
IDS qik -> pure qik
r -> throwE . PCEUnexpectedResponse $ bshow r
_ -> throwE SMPUnexpectedResponse
-- | Subscribe to the SMP queue.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
subscribeSMPQueue c rpKey rId =
subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId =
sendSMPCommand c (Just rpKey) rId SUB >>= \case
OK -> return ()
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Subscribe to multiple SMP queues batching commands if supported.
subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM response . L.zip qs
where
cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
response ((_, rId), r) = case r of
Right OK -> pure $ Right ()
Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r'
Left e -> pure $ Left e
writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
serverTransmission ProtocolClient {protocolServer, thVersion, sessionId} entityId message =
(protocolServer, thVersion, sessionId, entityId, message)
-- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
--
-- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO (Maybe RcvMessage)
getSMPMessage c rpKey rId =
sendSMPCommand c (Just rpKey) rId GET >>= \case
OK -> pure Nothing
cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
r -> throwE . PCEUnexpectedResponse $ bshow r
cmd@MSG {} ->
lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)
_ -> throwE SMPUnexpectedResponse
-- | Subscribe to the SMP queue notifications.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT ProtocolClientError IO ()
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()
subscribeSMPQueueNotifications = okSMPCommand NSUB
-- | Secure the SMP queue by adding a sender public key.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT ProtocolClientError IO ()
secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO ()
secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
-- | Enable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> ExceptT ProtocolClientError IO (NotifierId, RcvNtfPublicDhKey)
enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Enable notifications for the multiple queues for push notifications server.
enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either ProtocolClientError (NotifierId, RcvNtfPublicDhKey)))
enableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
where
cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
response = \case
Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
Right r -> Left . PCEUnexpectedResponse $ bshow r
Left e -> Left e
-- | Disable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
disableSMPQueueNotifications = okSMPCommand NDEL
-- | Disable notifications for multiple queues for push notifications server.
disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
disableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
where
cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient NDEL)) qs
response = \case
Right OK -> Right ()
Right r -> Left . PCEUnexpectedResponse $ bshow r
Left e -> Left e
enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> ExceptT SMPClientError IO NotifierId
enableSMPQueueNotifications c rpKey rId notifierKey =
sendSMPCommand c (Just rpKey) rId (NKEY notifierKey) >>= \case
NID nId -> pure nId
_ -> throwE SMPUnexpectedResponse
-- | Send SMP message.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT ProtocolClientError IO ()
sendSMPMessage c spKey sId flags msg =
sendSMPCommand c spKey sId (SEND flags msg) >>= \case
sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO ()
sendSMPMessage c spKey sId msg =
sendSMPCommand c spKey sId (SEND msg) >>= \case
OK -> pure ()
r -> throwE . PCEUnexpectedResponse $ bshow r
_ -> throwE SMPUnexpectedResponse
-- | Acknowledge message delivery (server deletes the message).
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT ProtocolClientError IO ()
ackSMPMessage c rpKey rId msgId =
sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId =
sendSMPCommand c (Just rpKey) rId ACK >>= \case
OK -> return ()
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
r -> throwE . PCEUnexpectedResponse $ bshow r
cmd@MSG {} ->
lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)
_ -> throwE SMPUnexpectedResponse
-- | Irreversibly suspend SMP queue.
-- The existing messages from the queue will still be delivered.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
suspendSMPQueue = okSMPCommand OFF
-- | Irreversibly delete SMP queue and all messages in it.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
deleteSMPQueue = okSMPCommand DEL
okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT ProtocolClientError IO ()
okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
okSMPCommand cmd c pKey qId =
sendSMPCommand c (Just pKey) qId cmd >>= \case
OK -> return ()
r -> throwE . PCEUnexpectedResponse $ bshow r
_ -> throwE SMPUnexpectedResponse
-- | Send SMP command
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg
sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
-- | Send multiple commands with batching and collect responses
sendProtocolCommands :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either ProtocolClientError msg))
sendProtocolCommands c@ProtocolClient {sndQ, tcpTimeout} cs = do
ts <- mapM (runExceptT . mkTransmission c) cs
mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts
forConcurrently ts $ \case
Right (_, r) -> withTimeout . atomically $ takeTMVar r
Left e -> pure $ Left e
-- TODO sign all requests (SEND of SMP confirmation would be signed with the same key that is passed to the recipient)
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeout} pKey qId cmd = do
corrId <- lift_ getNextCorrId
t <- signTransmission $ encodeTransmission sessionId (corrId, qId, cmd)
ExceptT $ sendRecv corrId t
where
withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
lift_ :: STM a -> ExceptT SMPClientError IO a
lift_ action = ExceptT $ Right <$> atomically action
-- | Send Protocol command
sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg
sendProtocolCommand c@ProtocolClient {sndQ, tcpTimeout} pKey qId cmd = do
(t, r) <- mkTransmission c (pKey, qId, cmd)
ExceptT $ sendRecv t r
where
-- two separate "atomically" needed to avoid blocking
sendRecv :: SentRawTransmission -> TMVar (Response msg) -> IO (Response msg)
sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout (atomically $ takeTMVar r)
where
withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
mkTransmission :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> ClientCommand msg -> ExceptT ProtocolClientError IO (SentRawTransmission, TMVar (Response msg))
mkTransmission ProtocolClient {clientCorrId, sessionId, thVersion, sentCommands} (pKey, qId, cmd) = do
corrId <- liftIO $ atomically getNextCorrId
t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
r <- liftIO . atomically $ mkRequest corrId
pure (t, r)
where
getNextCorrId :: STM CorrId
getNextCorrId = do
i <- stateTVar clientCorrId $ \i -> (i, i + 1)
pure . CorrId $ bshow i
signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
signTransmission :: ByteString -> ExceptT SMPClientError IO SentRawTransmission
signTransmission t = case pKey of
Nothing -> pure (Nothing, t)
Nothing -> return (Nothing, t)
Just pk -> do
sig <- liftError PCESignatureError $ C.sign pk t
sig <- liftError SMPSignatureError $ C.sign pk t
return (Just sig, t)
mkRequest :: CorrId -> STM (TMVar (Response msg))
mkRequest corrId = do
-- two separate "atomically" needed to avoid blocking
sendRecv :: CorrId -> SentRawTransmission -> IO Response
sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
where
withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a
send :: CorrId -> SentRawTransmission -> STM (TMVar Response)
send corrId t = do
r <- newEmptyTMVar
TM.insert corrId (Request qId r) sentCommands
pure r
modifyTVar sentCommands . M.insert corrId $ Request qId r
writeTBQueue sndQ t
return r
-303
View File
@@ -1,303 +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.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 {tcpTimeout} = smpCfg agentCfg
smpClient_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar smpVar)
liftEither $ case smpClient_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
Nothing -> Left PCEResponseTimeout
newSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
newSMPClient smpVar = tryConnectClient pure tryConnectAsync
where
tryConnectClient :: (SMPClient -> ExceptT ProtocolClientError IO a) -> ExceptT ProtocolClientError IO () -> ExceptT ProtocolClientError IO a
tryConnectClient successAction retryAction =
tryE connectClient >>= \r -> case r of
Right smp -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
atomically $ putTMVar smpVar r
successAction smp
Left e -> do
if e == PCENetworkError || e == PCEResponseTimeout
then retryAction
else atomically $ do
putTMVar smpVar (Left e)
TM.delete srv smpClients
throwE e
tryConnectAsync :: ExceptT ProtocolClientError IO ()
tryConnectAsync = do
a <- async connectAsync
atomically $ modifyTVar' (asyncClients ca) (a :)
connectAsync :: ExceptT ProtocolClientError IO ()
connectAsync =
withRetryInterval (reconnectInterval agentCfg) $ \loop ->
void $ tryConnectClient (const reconnectClient) loop
connectClient :: ExceptT ProtocolClientError IO SMPClient
connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
clientDisconnected :: IO ()
clientDisconnected = do
removeClientAndSubs >>= (`forM_` serverDown)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateSignKey))
removeClientAndSubs = atomically $ do
TM.delete srv smpClients
TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs
where
updateSubs sVar = do
ss <- readTVar sVar
addPendingSubs sVar ss
pure ss
addPendingSubs sVar ss = do
let ps = pendingSrvSubs ca
TM.lookup srv ps >>= \case
Just v -> TM.union ss v
_ -> TM.insert srv sVar ps
serverDown :: Map SMPSub C.APrivateSignKey -> IO ()
serverDown ss = unless (M.null ss) . void . runExceptT $ do
notify . CADisconnected srv $ M.keysSet ss
reconnectServer
reconnectServer :: ExceptT ProtocolClientError IO ()
reconnectServer = do
a <- async tryReconnectClient
atomically $ modifyTVar' (reconnections ca) (a :)
tryReconnectClient :: ExceptT ProtocolClientError IO ()
tryReconnectClient = do
withRetryInterval (reconnectInterval agentCfg) $ \loop ->
reconnectClient `catchE` const loop
reconnectClient :: ExceptT ProtocolClientError IO ()
reconnectClient = do
withSMP ca srv $ \smp -> do
notify $ CAReconnected srv
cs <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
forConcurrently_ (maybe [] M.assocs cs) $ \sub@(s, _) ->
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} =
B.pack $ host <> if null port then "" else ':' : port
smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId
where
subscribe_ = case party of
SPRecipient -> subscribeSMPQueue
SPNotifier -> subscribeSMPQueueNotifications
addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
addSubscription ca srv sub = do
addSub_ (srvSubs ca) srv sub
removePendingSubscription ca srv $ fst sub
addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
addPendingSubscription = addSub_ . pendingSrvSubs
addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
addSub_ subs srv (s, key) =
TM.lookup srv subs >>= \case
Just m -> TM.insert s key m
_ -> TM.singleton s key >>= \v -> TM.insert srv v subs
removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
removeSubscription = removeSub_ . srvSubs
removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
removePendingSubscription = removeSub_ . pendingSrvSubs
removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM ()
removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateSignKey)
getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s
hasSub :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM Bool
hasSub subs srv s = maybe (pure False) (TM.member s) =<< TM.lookup srv subs
+10 -103
View File
@@ -8,7 +8,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -53,7 +52,6 @@ module Simplex.Messaging.Crypto
CryptoPublicKey (..),
CryptoPrivateKey (..),
KeyPair,
ASignatureKeyPair,
DhSecret (..),
DhSecretX25519,
ADhSecret (..),
@@ -102,14 +100,9 @@ module Simplex.Messaging.Crypto
-- * NaCl crypto_box
CbNonce (unCbNonce),
cbEncrypt,
cbEncryptMaxLenBS,
cbDecrypt,
cbNonce,
randomCbNonce,
pseudoRandomCbNonce,
-- * pseudo-random bytes
pseudoRandomBytes,
-- * SHA256 hash
sha256Hash,
@@ -120,17 +113,9 @@ module Simplex.Messaging.Crypto
-- * Cryptography error type
CryptoError (..),
-- * Limited size ByteStrings
MaxLenBS,
pattern MaxLenBS,
maxLenBS,
unsafeMaxLenBS,
appendMaxLenBS,
)
where
import Control.Concurrent.STM
import Control.Exception (Exception)
import Control.Monad.Except
import Control.Monad.Trans.Except
@@ -144,7 +129,7 @@ import qualified Crypto.PubKey.Curve25519 as X25519
import qualified Crypto.PubKey.Curve448 as X448
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import Crypto.Random (ChaChaDRG, getRandomBytes, randomBytesGenerate)
import Crypto.Random (getRandomBytes)
import Data.ASN1.BinaryEncoding
import Data.ASN1.Encoding
import Data.ASN1.Types
@@ -162,11 +147,11 @@ import Data.Constraint (Dict (..))
import Data.Kind (Constraint, Type)
import Data.String
import Data.Type.Equality
import Data.Typeable (Proxy (Proxy), Typeable)
import Data.Typeable (Typeable)
import Data.X509
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
import GHC.TypeLits (ErrorMessage (..), TypeError)
import Network.Transport.Internal (decodeWord16, encodeWord16)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
@@ -259,12 +244,6 @@ deriving instance Eq (PrivateKey a)
deriving instance Show (PrivateKey a)
instance StrEncoding (PrivateKey X25519) where
strEncode = strEncode . encodePrivKey
{-# INLINE strEncode #-}
strDecode = decodePrivKey
{-# INLINE strDecode #-}
data APrivateKey
= forall a.
AlgorithmI a =>
@@ -305,18 +284,6 @@ instance Eq APrivateSignKey where
deriving instance Show APrivateSignKey
instance Encoding APrivateSignKey where
smpEncode = smpEncode . encodePrivKey
{-# INLINE smpEncode #-}
smpDecode = decodePrivKey
{-# INLINE smpDecode #-}
instance StrEncoding APrivateSignKey where
strEncode = strEncode . encodePrivKey
{-# INLINE strEncode #-}
strDecode = decodePrivKey
{-# INLINE strDecode #-}
data APublicVerifyKey
= forall a.
(AlgorithmI a, SignatureAlgorithm a) =>
@@ -699,9 +666,7 @@ data CryptoError
CERatchetHeader
| -- | too many skipped messages
CERatchetTooManySkipped
| -- | earlier message number (or, possibly, skipped message that failed to decrypt?)
CERatchetEarlierMessage
| -- | duplicate message number
| -- | duplicate message number (or, possibly, skipped message that failed to decrypt?)
CERatchetDuplicateMessage
deriving (Eq, Show, Exception)
@@ -818,41 +783,6 @@ unPad padded
(lenWrd, rest) = B.splitAt 2 padded
len = fromIntegral $ decodeWord16 lenWrd
newtype MaxLenBS (i :: Nat) = MLBS {unMaxLenBS :: ByteString}
pattern MaxLenBS :: ByteString -> MaxLenBS i
pattern MaxLenBS s <- MLBS s
{-# COMPLETE MaxLenBS #-}
instance KnownNat i => Encoding (MaxLenBS i) where
smpEncode (MLBS s) = smpEncode s
smpP = first show . maxLenBS <$?> smpP
instance KnownNat i => StrEncoding (MaxLenBS i) where
strEncode (MLBS s) = strEncode s
strP = first show . maxLenBS <$?> strP
maxLenBS :: forall i. KnownNat i => ByteString -> Either CryptoError (MaxLenBS i)
maxLenBS s
| B.length s > maxLength @i = Left CryptoLargeMsgError
| otherwise = Right $ MLBS s
unsafeMaxLenBS :: forall i. KnownNat i => ByteString -> MaxLenBS i
unsafeMaxLenBS = MLBS
padMaxLenBS :: forall i. KnownNat i => MaxLenBS i -> MaxLenBS (i + 2)
padMaxLenBS (MLBS msg) = MLBS $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
where
len = B.length msg
padLen = maxLength @i - len
appendMaxLenBS :: (KnownNat i, KnownNat j) => MaxLenBS i -> MaxLenBS j -> MaxLenBS (i + j)
appendMaxLenBS (MLBS s1) (MLBS s2) = MLBS $ s1 <> s2
maxLength :: forall i. KnownNat i => Int
maxLength = fromIntegral (natVal $ Proxy @i)
initAEAD :: forall c. AES.BlockCipher c => Key -> IV -> ExceptT CryptoError IO (AES.AEAD c)
initAEAD (Key aesKey) (IV ivBytes) = do
iv <- makeIV @c ivBytes
@@ -908,17 +838,12 @@ dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
cbEncrypt secret (CbNonce nonce) msg paddedLen = cryptoBox secret nonce <$> pad msg paddedLen
-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
cbEncryptMaxLenBS :: KnownNat i => DhSecret X25519 -> CbNonce -> MaxLenBS i -> ByteString
cbEncryptMaxLenBS secret (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS
cryptoBox :: DhSecret 'X25519 -> ByteString -> ByteString -> ByteString
cryptoBox secret nonce s = BA.convert tag <> c
cbEncrypt secret (CbNonce nonce) msg paddedLen = cryptoBox <$> pad msg paddedLen
where
(rs, c) = xSalsa20 secret nonce s
tag = Poly1305.auth rs c
cryptoBox s = BA.convert tag <> c
where
(rs, c) = xSalsa20 secret nonce s
tag = Poly1305.auth rs c
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
@@ -932,15 +857,7 @@ cbDecrypt secret (CbNonce nonce) packet
tag = Poly1305.auth rs c
newtype CbNonce = CbNonce {unCbNonce :: ByteString}
deriving (Eq, Show)
instance StrEncoding CbNonce where
strEncode (CbNonce s) = strEncode s
strP = cbNonce <$> strP
instance ToJSON CbNonce where
toJSON = strToJSON
toEncoding = strToJEncoding
deriving (Show)
cbNonce :: ByteString -> CbNonce
cbNonce s
@@ -953,16 +870,6 @@ cbNonce s
randomCbNonce :: IO CbNonce
randomCbNonce = CbNonce <$> getRandomBytes 24
pseudoRandomCbNonce :: TVar ChaChaDRG -> STM CbNonce
pseudoRandomCbNonce gVar = CbNonce <$> pseudoRandomBytes 24 gVar
pseudoRandomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
pseudoRandomBytes n gVar = do
g <- readTVar gVar
let (bytes, g') = randomBytesGenerate n g
writeTVar gVar g'
return bytes
instance Encoding CbNonce where
smpEncode = unCbNonce
smpP = CbNonce <$> A.take 24
+1 -2
View File
@@ -416,8 +416,7 @@ rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
skipMessageKeys :: Word32 -> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)
skipMessageKeys _ r@Ratchet {rcRcv = Nothing} = Right (r, M.empty)
skipMessageKeys untilN r@Ratchet {rcRcv = Just rr@RcvRatchet {rcCKr, rcHKr}, rcNr}
| rcNr > untilN + 1 = Left CERatchetEarlierMessage
| rcNr == untilN + 1 = Left CERatchetDuplicateMessage
| rcNr > untilN = Left CERatchetDuplicateMessage
| rcNr + maxSkip < untilN = Left CERatchetTooManySkipped
| rcNr == untilN = Right (r, M.empty)
| otherwise =
-63
View File
@@ -13,7 +13,6 @@ module Simplex.Messaging.Encoding
Large (..),
smpEncodeList,
smpListP,
lenEncode,
)
where
@@ -48,100 +47,66 @@ class Encoding a where
instance Encoding Char where
smpEncode = B.singleton
{-# INLINE smpEncode #-}
smpP = A.anyChar
{-# INLINE smpP #-}
instance Encoding Bool where
smpEncode = \case
True -> "T"
False -> "F"
{-# INLINE smpEncode #-}
smpP =
smpP >>= \case
'T' -> pure True
'F' -> pure False
_ -> fail "invalid Bool"
{-# INLINE smpP #-}
instance Encoding Word16 where
smpEncode = encodeWord16
{-# INLINE smpEncode #-}
smpP = decodeWord16 <$> A.take 2
{-# INLINE smpP #-}
instance Encoding Word32 where
smpEncode = encodeWord32
{-# INLINE smpEncode #-}
smpP = decodeWord32 <$> A.take 4
{-# INLINE smpP #-}
instance Encoding Int64 where
smpEncode i = w32 (i `shiftR` 32) <> w32 i
{-# INLINE smpEncode #-}
smpP = do
l <- w32P
r <- w32P
pure $ (l `shiftL` 32) .|. r
{-# INLINE smpP #-}
w32 :: Int64 -> ByteString
w32 = smpEncode @Word32 . fromIntegral
{-# INLINE w32 #-}
w32P :: Parser Int64
w32P = fromIntegral <$> smpP @Word32
{-# INLINE w32P #-}
-- ByteStrings are assumed no longer than 255 bytes
instance Encoding ByteString where
smpEncode s = B.cons (lenEncode $ B.length s) s
{-# INLINE smpEncode #-}
smpP = A.take =<< lenP
{-# INLINE smpP #-}
lenEncode :: Int -> Char
lenEncode = w2c . fromIntegral
{-# INLINE lenEncode #-}
lenP :: Parser Int
lenP = fromIntegral . c2w <$> A.anyChar
{-# INLINE lenP #-}
instance Encoding a => Encoding (Maybe a) where
smpEncode s = maybe "0" (("1" <>) . smpEncode) s
{-# INLINE smpEncode #-}
smpP =
smpP >>= \case
'0' -> pure Nothing
'1' -> Just <$> smpP
_ -> fail "invalid Maybe tag"
{-# INLINE smpP #-}
newtype Tail = Tail {unTail :: ByteString}
instance Encoding Tail where
smpEncode = unTail
{-# INLINE smpEncode #-}
smpP = Tail <$> A.takeByteString
{-# INLINE smpP #-}
-- newtype for encoding/decoding ByteStrings over 255 bytes with 2-bytes length prefix
newtype Large = Large {unLarge :: ByteString}
instance Encoding Large where
smpEncode (Large s) = smpEncode @Word16 (fromIntegral $ B.length s) <> s
{-# INLINE smpEncode #-}
smpP = do
len <- fromIntegral <$> smpP @Word16
Large <$> A.take len
{-# INLINE smpP #-}
instance Encoding SystemTime where
smpEncode = smpEncode . systemSeconds
{-# INLINE smpEncode #-}
smpP = MkSystemTime <$> smpP <*> pure 0
{-# INLINE smpP #-}
-- lists encode/parse as a sequence of items prefixed with list length (as 1 byte)
smpEncodeList :: Encoding a => [a] -> ByteString
@@ -152,9 +117,7 @@ smpListP = (`A.count` smpP) =<< lenP
instance Encoding String where
smpEncode = smpEncode . B.pack
{-# INLINE smpEncode #-}
smpP = B.unpack <$> smpP
{-# INLINE smpP #-}
instance Encoding a => Encoding (L.NonEmpty a) where
smpEncode = smpEncodeList . L.toList
@@ -165,42 +128,16 @@ instance Encoding a => Encoding (L.NonEmpty a) where
instance (Encoding a, Encoding b) => Encoding (a, b) where
smpEncode (a, b) = smpEncode a <> smpEncode b
{-# INLINE smpEncode #-}
smpP = (,) <$> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c) => Encoding (a, b, c) where
smpEncode (a, b, c) = smpEncode a <> smpEncode b <> smpEncode c
{-# INLINE smpEncode #-}
smpP = (,,) <$> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c, Encoding d) => Encoding (a, b, c, d) where
smpEncode (a, b, c, d) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d
{-# INLINE smpEncode #-}
smpP = (,,,) <$> smpP <*> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e) => Encoding (a, b, c, d, e) where
smpEncode (a, b, c, d, e) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e
{-# INLINE smpEncode #-}
smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f) => Encoding (a, b, c, d, e, f) where
smpEncode (a, b, c, d, e, f) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f
{-# INLINE smpEncode #-}
smpP = (,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g) => Encoding (a, b, c, d, e, f, g) where
smpEncode (a, b, c, d, e, f, g) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g
{-# INLINE smpEncode #-}
smpP = (,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g, Encoding h) => Encoding (a, b, c, d, e, f, g, h) where
smpEncode (a, b, c, d, e, f, g, h) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e <> smpEncode f <> smpEncode g <> smpEncode h
{-# INLINE smpEncode #-}
smpP = (,,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
{-# INLINE smpP #-}
+2 -63
View File
@@ -2,8 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Encoding.String
( TextEncoding (..),
StrEncoding (..),
( StrEncoding (..),
Str (..),
strP_,
strToJSON,
@@ -26,24 +25,12 @@ import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlphaNum)
import Data.Int (Int64)
import qualified Data.List.NonEmpty as L
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.System (SystemTime (..))
import Data.Time.Format.ISO8601
import Data.Word (Word16)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util ((<$?>))
class TextEncoding a where
textEncode :: a -> Text
textDecode :: Text -> Maybe a
-- | Serializing human-readable and (where possible) URI-friendly strings for SMP and SMP agent protocols
class StrEncoding a where
{-# MINIMAL strEncode, (strDecode | strP) #-}
@@ -83,47 +70,11 @@ instance FromJSON Str where
instance StrEncoding a => StrEncoding (Maybe a) where
strEncode = maybe "" strEncode
{-# INLINE strEncode #-}
strP = optional strP
{-# INLINE strP #-}
instance StrEncoding Word16 where
strEncode = B.pack . show
{-# INLINE strEncode #-}
strP = A.decimal
{-# INLINE strP #-}
instance StrEncoding Char where
strEncode = smpEncode
{-# INLINE strEncode #-}
strP = 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
@@ -137,36 +88,24 @@ instance StrEncoding a => StrEncoding (L.NonEmpty a) where
strEncode = strEncodeList . L.toList
strP = L.fromList <$> listItem `A.sepBy1'` A.char ','
instance (StrEncoding a, Ord a) => StrEncoding (Set a) where
strEncode = strEncodeList . S.toList
strP = S.fromList <$> listItem `A.sepBy'` A.char ','
listItem :: StrEncoding a => Parser a
listItem = parseAll strP <$?> A.takeTill (\c -> c == ',' || c == ' ' || c == '\n')
listItem = parseAll strP <$?> A.takeTill (== ',')
instance (StrEncoding a, StrEncoding b) => StrEncoding (a, b) where
strEncode (a, b) = B.unwords [strEncode a, strEncode b]
{-# INLINE strEncode #-}
strP = (,) <$> strP_ <*> strP
{-# INLINE strP #-}
instance (StrEncoding a, StrEncoding b, StrEncoding c) => StrEncoding (a, b, c) where
strEncode (a, b, c) = B.unwords [strEncode a, strEncode b, strEncode c]
{-# INLINE strEncode #-}
strP = (,,) <$> strP_ <*> strP_ <*> strP
{-# INLINE strP #-}
instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d) => StrEncoding (a, b, c, d) where
strEncode (a, b, c, d) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d]
{-# INLINE strEncode #-}
strP = (,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP
{-# INLINE strP #-}
instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncoding e) => StrEncoding (a, b, c, d, e) where
strEncode (a, b, c, d, e) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d, strEncode e]
{-# INLINE strEncode #-}
strP = (,,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP
{-# INLINE strP #-}
strP_ :: StrEncoding a => Parser a
strP_ = strP <* A.space
@@ -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,502 +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 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, notifierId) <- smpP
pure $ SMPQueueNtf {smpServer, notifierId}
instance StrEncoding SMPQueueNtf where
strEncode SMPQueueNtf {smpServer, notifierId} = strEncode smpServer <> "/" <> strEncode notifierId
strP = SMPQueueNtf <$> strP <* A.char '/' <*> strP
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 -> (c >= '0' && c <= '9') || (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,576 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# 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.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 . T.pack $ "SMP server disconnected " <> host srv <> " (" <> show (length subs) <> ") subscriptions"
forM_ subs $ \(_, ntfId) -> do
let smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSInactive
CAReconnected srv ->
logInfo $ "SMP server reconnected " <> T.pack (host srv)
CAResubscribed srv sub -> do
let ntfId = snd sub
smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSActive
CASubError srv (_, ntfId) err -> do
logError . T.pack $ "SMP subscription error on server " <> host srv <> ": " <> show err
handleSubError (SMPQueueNtf srv ntfId) err
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
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,200 +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
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
)
)
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,194 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
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
}
+1 -11
View File
@@ -13,8 +13,6 @@ import Data.ByteString.Base64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlphaNum, toLower)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Time.ISO8601 (parseISO8601)
import Data.Typeable (Typeable)
@@ -83,14 +81,6 @@ blobFieldDecoder dec = \case
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
@@ -108,7 +98,7 @@ enumJSON tagModifier =
}
sumTypeJSON :: (String -> String) -> J.Options
#if defined(darwin_HOST_OS) && defined(swiftJSON)
#if defined(darwin_HOST_OS)
sumTypeJSON = singleFieldJSON
#else
sumTypeJSON = taggedObjectJSON
+91 -425
View File
@@ -1,31 +1,23 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
{-# HLINT ignore "Use newtype instead of data" #-}
-- |
-- Module : Simplex.Messaging.ProtocolEncoding
-- Module : Simplex.Messaging.Protocol
-- Copyright : (c) simplex.chat
-- License : AGPL-3
--
@@ -45,7 +37,7 @@ module Simplex.Messaging.Protocol
e2eEncMessageLength,
-- * SMP protocol types
ProtocolEncoding (..),
Protocol,
Command (..),
Party (..),
Cmd (..),
@@ -63,14 +55,7 @@ module Simplex.Messaging.Protocol
PubHeader (..),
ClientMessage (..),
PrivHeader (..),
Protocol (..),
ProtocolType (..),
ProtocolServer (..),
ProtoServer,
SMPServer,
pattern SMPServer,
NtfServer,
pattern NtfServer,
SMPServer (..),
SrvLoc (..),
CorrId (..),
QueueId,
@@ -85,32 +70,13 @@ module Simplex.Messaging.Protocol
SndPublicVerifyKey,
NtfPrivateSignKey,
NtfPublicVerifyKey,
RcvNtfPublicDhKey,
RcvNtfDhSecret,
Message (..),
RcvMessage (..),
MsgId,
MsgBody,
MaxMessageLen,
MaxRcvMessageLen,
EncRcvMsgBody (..),
RcvMsgBody (..),
ClientRcvMsgBody (..),
EncNMsgMeta,
SMPMsgMeta (..),
NMsgMeta (..),
MsgFlags (..),
rcvMessageMeta,
noMsgFlags,
-- * Parse and serialize
ProtocolMsgTag (..),
messageTagP,
encodeTransmission,
transmissionP,
_smpP,
encodeRcvMsgBody,
clientRcvMsgBodyP,
encodeProtocol,
-- * TCP transport functions
tPut,
@@ -131,21 +97,18 @@ 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.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (isNothing)
import Data.String
import Data.Time.Clock.System (SystemTime (..))
import Data.Time.Clock.System (SystemTime)
import Data.Type.Equality
import GHC.Generics (Generic)
import GHC.TypeLits (type (+))
import Generic.Random (genericArbitraryU)
import Network.Socket (HostName, ServiceName)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport (THandle (..), Transport, TransportError (..), tGetBlock, tPutBlock)
import Simplex.Messaging.Util (bshow, (<$?>))
import Simplex.Messaging.Version
import Test.QuickCheck (Arbitrary (..))
@@ -159,11 +122,6 @@ smpClientVRange = mkVersionRange 1 smpClientVersion
maxMessageLength :: Int
maxMessageLength = 16088
type MaxMessageLen = 16088
-- 16 extra bytes: 8 for timestamp and 8 for flags (7 flags and the space, only 1 flag is currently used)
type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106
-- it is shorter to allow per-queue e2e encryption DH key in the "public" header
e2eEncConfirmationLength :: Int
e2eEncConfirmationLength = 15936
@@ -203,7 +161,7 @@ data Cmd = forall p. PartyI p => Cmd (SParty p) (Command p)
deriving instance Show Cmd
-- | Parsed SMP transmission without signature, size and session ID.
type Transmission c = (CorrId, EntityId, c)
type Transmission c = (CorrId, QueueId, c)
-- | signed parsed transmission, with original raw bytes and parsing error.
type SignedTransmission c = (Maybe C.ASignature, Signed, Transmission (Either ErrorType c))
@@ -214,15 +172,14 @@ type Signed = ByteString
data RawTransmission = RawTransmission
{ signature :: ByteString,
signed :: ByteString,
sessId :: SessionId,
sessId :: ByteString,
corrId :: ByteString,
entityId :: ByteString,
queueId :: ByteString,
command :: ByteString
}
deriving (Show)
-- | unparsed sent SMP transmission with signature, without session ID.
type SignedRawTransmission = (Maybe C.ASignature, SessionId, ByteString, ByteString)
type SignedRawTransmission = (Maybe C.ASignature, ByteString, ByteString, ByteString)
-- | unparsed sent SMP transmission with signature.
type SentRawTransmission = (Maybe C.ASignature, ByteString)
@@ -237,9 +194,7 @@ type SenderId = QueueId
type NotifierId = QueueId
-- | SMP queue ID on the server.
type QueueId = EntityId
type EntityId = ByteString
type QueueId = ByteString
-- | Parameterized type for SMP protocol commands from all clients.
data Command (p :: Party) where
@@ -247,18 +202,12 @@ data Command (p :: Party) where
NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient
SUB :: Command Recipient
KEY :: SndPublicVerifyKey -> Command Recipient
NKEY :: NtfPublicVerifyKey -> RcvNtfPublicDhKey -> Command Recipient
NDEL :: Command Recipient
GET :: Command Recipient
-- ACK v1 has to be supported for encoding/decoding
-- ACK :: Command Recipient
ACK :: MsgId -> Command Recipient
NKEY :: NtfPublicVerifyKey -> Command Recipient
ACK :: Command Recipient
OFF :: Command Recipient
DEL :: Command Recipient
-- SMP sender commands
-- SEND v1 has to be supported for encoding/decoding
-- SEND :: MsgBody -> Command Sender
SEND :: MsgFlags -> MsgBody -> Command Sender
SEND :: MsgBody -> Command Sender
PING :: Command Sender
-- SMP notification subscriber commands
NSUB :: Command Notifier
@@ -270,139 +219,15 @@ deriving instance Eq (Command p)
data BrokerMsg where
-- SMP broker messages (responses, client messages, notifications)
IDS :: QueueIdsKeys -> BrokerMsg
-- MSG v1/2 has to be supported for encoding/decoding
-- v1: MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
-- v2: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg
MSG :: RcvMessage -> BrokerMsg
NID :: NotifierId -> RcvNtfPublicDhKey -> BrokerMsg
NMSG :: C.CbNonce -> EncNMsgMeta -> BrokerMsg
MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
NID :: NotifierId -> BrokerMsg
NMSG :: BrokerMsg
END :: BrokerMsg
OK :: BrokerMsg
ERR :: ErrorType -> BrokerMsg
PONG :: BrokerMsg
deriving (Eq, Show)
data RcvMessage = RcvMessage
{ msgId :: MsgId,
msgTs :: SystemTime,
msgFlags :: MsgFlags,
msgBody :: EncRcvMsgBody -- e2e encrypted, with extra encryption for recipient
}
deriving (Eq, Show)
-- | received message without server/recipient encryption
data Message = Message
{ msgId :: MsgId,
msgTs :: SystemTime,
msgFlags :: MsgFlags,
msgBody :: C.MaxLenBS MaxMessageLen
}
instance StrEncoding RcvMessage where
strEncode RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} =
B.unwords
[ strEncode msgId,
strEncode msgTs,
"flags=" <> strEncode msgFlags,
strEncode body
]
strP = do
msgId <- strP_
msgTs <- strP_
msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
msgBody <- EncRcvMsgBody <$> strP
pure RcvMessage {msgId, msgTs, msgFlags, msgBody}
newtype EncRcvMsgBody = EncRcvMsgBody ByteString
deriving (Eq, Show)
data RcvMsgBody = RcvMsgBody
{ msgTs :: SystemTime,
msgFlags :: MsgFlags,
msgBody :: C.MaxLenBS MaxMessageLen
}
encodeRcvMsgBody :: RcvMsgBody -> C.MaxLenBS MaxRcvMessageLen
encodeRcvMsgBody RcvMsgBody {msgTs, msgFlags, msgBody} =
let rcvMeta :: C.MaxLenBS 16 = C.unsafeMaxLenBS $ smpEncode (msgTs, msgFlags, ' ')
in C.appendMaxLenBS rcvMeta msgBody
data ClientRcvMsgBody = ClientRcvMsgBody
{ msgTs :: SystemTime,
msgFlags :: MsgFlags,
msgBody :: ByteString
}
clientRcvMsgBodyP :: Parser ClientRcvMsgBody
clientRcvMsgBodyP = do
msgTs <- smpP
msgFlags <- smpP
Tail msgBody <- _smpP
pure ClientRcvMsgBody {msgTs, msgFlags, msgBody}
instance StrEncoding Message where
strEncode Message {msgId, msgTs, msgFlags, msgBody} =
B.unwords
[ strEncode msgId,
strEncode msgTs,
"flags=" <> strEncode msgFlags,
strEncode msgBody
]
strP = do
msgId <- strP_
msgTs <- strP_
msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
msgBody <- strP
pure Message {msgId, msgTs, msgFlags, msgBody}
type EncNMsgMeta = ByteString
data SMPMsgMeta = SMPMsgMeta
{ msgId :: MsgId,
msgTs :: SystemTime,
msgFlags :: MsgFlags
}
deriving (Show)
rcvMessageMeta :: MsgId -> ClientRcvMsgBody -> SMPMsgMeta
rcvMessageMeta msgId ClientRcvMsgBody {msgTs, msgFlags} = SMPMsgMeta {msgId, msgTs, msgFlags}
data NMsgMeta = NMsgMeta
{ msgId :: MsgId,
msgTs :: SystemTime
}
deriving (Show)
instance Encoding NMsgMeta where
smpEncode NMsgMeta {msgId, msgTs} =
smpEncode (msgId, msgTs)
smpP = do
-- Tail here is to allow extension in the future clients/servers
(msgId, msgTs, Tail _) <- smpP
pure NMsgMeta {msgId, msgTs}
-- it must be data for correct JSON encoding
data MsgFlags = MsgFlags {notification :: Bool}
deriving (Eq, Show, Generic)
instance ToJSON MsgFlags where toEncoding = J.genericToEncoding J.defaultOptions
-- this encoding should not become bigger than 7 bytes (currently it is 1 byte)
instance Encoding MsgFlags where
smpEncode MsgFlags {notification} = smpEncode notification
smpP = do
notification <- smpP <* A.takeTill (== ' ')
pure MsgFlags {notification}
instance StrEncoding MsgFlags where
strEncode = smpEncode
{-# INLINE strEncode #-}
strP = smpP
{-# INLINE strP #-}
noMsgFlags :: MsgFlags
noMsgFlags = MsgFlags {notification = False}
-- * SMP command tags
data CommandTag (p :: Party) where
@@ -410,8 +235,6 @@ data CommandTag (p :: Party) where
SUB_ :: CommandTag Recipient
KEY_ :: CommandTag Recipient
NKEY_ :: CommandTag Recipient
NDEL_ :: CommandTag Recipient
GET_ :: CommandTag Recipient
ACK_ :: CommandTag Recipient
OFF_ :: CommandTag Recipient
DEL_ :: CommandTag Recipient
@@ -441,7 +264,7 @@ class ProtocolMsgTag t where
messageTagP :: ProtocolMsgTag t => Parser t
messageTagP =
maybe (fail "bad message") pure . decodeTag
maybe (fail "bad command") pure . decodeTag
=<< (A.takeTill (== ' ') <* optional A.space)
instance PartyI p => Encoding (CommandTag p) where
@@ -450,8 +273,6 @@ instance PartyI p => Encoding (CommandTag p) where
SUB_ -> "SUB"
KEY_ -> "KEY"
NKEY_ -> "NKEY"
NDEL_ -> "NDEL"
GET_ -> "GET"
ACK_ -> "ACK"
OFF_ -> "OFF"
DEL_ -> "DEL"
@@ -466,8 +287,6 @@ instance ProtocolMsgTag CmdTag where
"SUB" -> Just $ CT SRecipient SUB_
"KEY" -> Just $ CT SRecipient KEY_
"NKEY" -> Just $ CT SRecipient NKEY_
"NDEL" -> Just $ CT SRecipient NDEL_
"GET" -> Just $ CT SRecipient GET_
"ACK" -> Just $ CT SRecipient ACK_
"OFF" -> Just $ CT SRecipient OFF_
"DEL" -> Just $ CT SRecipient DEL_
@@ -553,109 +372,34 @@ instance Encoding ClientMessage where
smpEncode (ClientMessage h msg) = smpEncode h <> msg
smpP = ClientMessage <$> smpP <*> A.takeByteString
type SMPServer = ProtocolServer 'PSMP
pattern SMPServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash
{-# COMPLETE SMPServer #-}
type NtfServer = ProtocolServer 'PNTF
pattern NtfServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
{-# COMPLETE NtfServer #-}
data ProtocolType = PSMP | PNTF
deriving (Eq, Ord, Show)
instance StrEncoding ProtocolType where
strEncode = \case
PSMP -> "smp"
PNTF -> "ntf"
strP =
A.takeTill (== ':') >>= \case
"smp" -> pure PSMP
"ntf" -> pure PNTF
_ -> fail "bad ProtocolType"
data SProtocolType (p :: ProtocolType) where
SPSMP :: SProtocolType 'PSMP
SPNTF :: SProtocolType 'PNTF
deriving instance Eq (SProtocolType p)
deriving instance Ord (SProtocolType p)
deriving instance Show (SProtocolType p)
data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)
instance TestEquality SProtocolType where
testEquality SPSMP SPSMP = Just Refl
testEquality SPNTF SPNTF = Just Refl
testEquality _ _ = Nothing
protocolType :: SProtocolType p -> ProtocolType
protocolType = \case
SPSMP -> PSMP
SPNTF -> PNTF
aProtocolType :: ProtocolType -> AProtocolType
aProtocolType = \case
PSMP -> AProtocolType SPSMP
PNTF -> AProtocolType SPNTF
instance ProtocolTypeI p => StrEncoding (SProtocolType p) where
strEncode = strEncode . protocolType
strP = (\(AProtocolType p) -> checkProtocolType p) <$?> strP
instance StrEncoding AProtocolType where
strEncode (AProtocolType p) = strEncode p
strP = aProtocolType <$> strP
checkProtocolType :: forall t p p'. (ProtocolTypeI p, ProtocolTypeI p') => t p' -> Either String (t p)
checkProtocolType p = case testEquality (protocolTypeI @p) (protocolTypeI @p') of
Just Refl -> Right p
Nothing -> Left "bad ProtocolType"
class ProtocolTypeI (p :: ProtocolType) where
protocolTypeI :: SProtocolType p
instance ProtocolTypeI 'PSMP where protocolTypeI = SPSMP
instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
-- | server location and transport key digest (hash).
data ProtocolServer p = ProtocolServer
{ scheme :: SProtocolType p,
host :: HostName,
-- | SMP server location and transport key digest (hash).
data SMPServer = SMPServer
{ host :: HostName,
port :: ServiceName,
keyHash :: C.KeyHash
}
deriving (Eq, Ord, Show)
instance ProtocolTypeI p => IsString (ProtocolServer p) where
instance IsString SMPServer where
fromString = parseString strDecode
instance ProtocolTypeI p => Encoding (ProtocolServer p) where
smpEncode ProtocolServer {host, port, keyHash} =
instance Encoding SMPServer where
smpEncode SMPServer {host, port, keyHash} =
smpEncode (host, port, keyHash)
smpP = do
(host, port, keyHash) <- smpP
pure ProtocolServer {scheme = protocolTypeI @p, host, port, keyHash}
pure SMPServer {host, port, keyHash}
instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
strEncode ProtocolServer {scheme, host, port, keyHash} =
strEncode scheme <> "://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
instance StrEncoding SMPServer where
strEncode SMPServer {host, port, keyHash} =
"smp://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
strP = do
scheme <- strP <* "://"
_ <- "smp://"
keyHash <- strP <* A.char '@'
SrvLoc host port <- strP
pure ProtocolServer {scheme, host, port, keyHash}
pure SMPServer {host, port, keyHash}
instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
instance ToJSON SMPServer where
toJSON = strToJSON
toEncoding = strToJEncoding
@@ -667,7 +411,7 @@ instance StrEncoding SrvLoc where
strP = SrvLoc <$> host <*> (port <|> pure "")
where
host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
port = show <$> (A.char ':' *> (A.decimal :: Parser Int))
port = B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
-- | Transmission correlation ID.
newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
@@ -714,18 +458,12 @@ type SndPrivateSignKey = C.APrivateSignKey
-- | Sender's public key used by SMP server to verify authorization of SMP commands.
type SndPublicVerifyKey = C.APublicVerifyKey
-- | Private key used by push notifications server to authorize (sign) NSUB command.
-- | Private key used by push notifications server to authorize (sign) LSTN command.
type NtfPrivateSignKey = C.APrivateSignKey
-- | Public key used by SMP server to verify authorization of NSUB command sent by push notifications server.
-- | Public key used by SMP server to verify authorization of LSTN command sent by push notifications server.
type NtfPublicVerifyKey = C.APublicVerifyKey
-- | Public key used for DH exchange to encrypt notification metadata from server to recipient
type RcvNtfPublicDhKey = C.PublicKeyX25519
-- | DH Secret used to encrypt notification metadata from server to recipient
type RcvNtfDhSecret = C.DhSecretX25519
-- | SMP message server ID.
type MsgId = ByteString
@@ -746,7 +484,7 @@ data ErrorType
QUOTA
| -- | ACK command is sent without message to be acknowledged
NO_MSG
| -- | sent message is too large (> maxMessageLength = 16088 bytes)
| -- | sent message is too large (> maxMessageLength = 16078 bytes)
LARGE_MSG
| -- | internal server error
INTERNAL
@@ -770,14 +508,12 @@ data CommandError
UNKNOWN
| -- | error parsing command
SYNTAX
| -- | command is not allowed (SUB/GET cannot be used with the same queue in the same TCP connection)
PROHIBITED
| -- | transmission has no required credentials (signature or queue ID)
NO_AUTH
| -- | transmission has credentials that are not allowed for this command
HAS_AUTH
| -- | transmission has no required entity ID (e.g. SMP queue)
NO_ENTITY
| -- | transmission has no required queue ID
NO_QUEUE
deriving (Eq, Generic, Read, Show)
instance ToJSON CommandError where
@@ -798,58 +534,34 @@ transmissionP = do
trn signature signed = do
sessId <- smpP
corrId <- smpP
entityId <- smpP
queueId <- smpP
command <- A.takeByteString
pure RawTransmission {signature, signed, sessId, corrId, entityId, command}
pure RawTransmission {signature, signed, sessId, corrId, queueId, command}
class (ProtocolEncoding msg, ProtocolEncoding (ProtoCommand msg), Show msg) => Protocol msg where
type ProtoCommand msg = cmd | cmd -> msg
type ProtoType msg = (sch :: ProtocolType) | sch -> msg
protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
protocolPing :: ProtoCommand msg
protocolError :: msg -> Maybe ErrorType
type ProtoServer msg = ProtocolServer (ProtoType msg)
instance Protocol BrokerMsg where
type ProtoCommand BrokerMsg = Cmd
type ProtoType BrokerMsg = 'PSMP
protocolClientHandshake = smpClientHandshake
protocolPing = Cmd SSender PING
protocolError = \case
ERR e -> Just e
_ -> Nothing
class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
class Protocol msg where
type Tag msg
encodeProtocol :: Version -> msg -> ByteString
protocolP :: Version -> Tag msg -> Parser msg
encodeProtocol :: msg -> ByteString
protocolP :: Tag msg -> Parser msg
checkCredentials :: SignedRawTransmission -> msg -> Either ErrorType msg
instance PartyI p => ProtocolEncoding (Command p) where
instance PartyI p => Protocol (Command p) where
type Tag (Command p) = CommandTag p
encodeProtocol v = \case
encodeProtocol = \case
NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)
SUB -> e SUB_
KEY k -> e (KEY_, ' ', k)
NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
NDEL -> e NDEL_
GET -> e GET_
ACK msgId
| v == 1 -> e ACK_
| otherwise -> e (ACK_, ' ', msgId)
NKEY k -> e (NKEY_, ' ', k)
ACK -> e ACK_
OFF -> e OFF_
DEL -> e DEL_
SEND flags msg
| v == 1 -> e (SEND_, ' ', Tail msg)
| otherwise -> e (SEND_, ' ', flags, ' ', Tail msg)
SEND msg -> e (SEND_, ' ', Tail msg)
PING -> e PING_
NSUB -> e NSUB_
where
e :: Encoding a => a -> ByteString
e = smpEncode
protocolP v tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP v (CT (sParty @p) tag)
protocolP tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP (CT (sParty @p) tag)
checkCredentials (sig, _, queueId, _) cmd = case cmd of
-- NEW must have signature but NOT queue ID
@@ -858,8 +570,8 @@ instance PartyI p => ProtocolEncoding (Command p) where
| not (B.null queueId) -> Left $ CMD HAS_AUTH
| otherwise -> Right cmd
-- SEND must have queue ID, signature is not always required
SEND {}
| B.null queueId -> Left $ CMD NO_ENTITY
SEND _
| B.null queueId -> Left $ CMD NO_QUEUE
| otherwise -> Right cmd
-- PING must not have queue ID or signature
PING
@@ -870,44 +582,35 @@ instance PartyI p => ProtocolEncoding (Command p) where
| isNothing sig || B.null queueId -> Left $ CMD NO_AUTH
| otherwise -> Right cmd
instance ProtocolEncoding Cmd where
instance Protocol Cmd where
type Tag Cmd = CmdTag
encodeProtocol v (Cmd _ c) = encodeProtocol v c
encodeProtocol (Cmd _ c) = encodeProtocol c
protocolP v = \case
protocolP = \case
CT SRecipient tag ->
Cmd SRecipient <$> case tag of
NEW_ -> NEW <$> _smpP <*> smpP
SUB_ -> pure SUB
KEY_ -> KEY <$> _smpP
NKEY_ -> NKEY <$> _smpP <*> smpP
NDEL_ -> pure NDEL
GET_ -> pure GET
ACK_
| v == 1 -> pure $ ACK ""
| otherwise -> ACK <$> _smpP
NKEY_ -> NKEY <$> _smpP
ACK_ -> pure ACK
OFF_ -> pure OFF
DEL_ -> pure DEL
CT SSender tag ->
Cmd SSender <$> case tag of
SEND_
| v == 1 -> SEND <$> pure noMsgFlags <*> (unTail <$> _smpP)
| otherwise -> SEND <$> _smpP <*> (unTail <$> _smpP)
SEND_ -> SEND . unTail <$> _smpP
PING_ -> pure PING
CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
checkCredentials t (Cmd p c) = Cmd p <$> checkCredentials t c
instance ProtocolEncoding BrokerMsg where
instance Protocol BrokerMsg where
type Tag BrokerMsg = BrokerMsgTag
encodeProtocol v = \case
encodeProtocol = \case
IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
MSG RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body}
| v == 1 -> e (MSG_, ' ', msgId, msgTs, Tail body)
| v == 2 -> e (MSG_, ' ', msgId, msgTs, msgFlags, ' ', Tail body)
| otherwise -> e (MSG_, ' ', msgId, Tail body)
NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta)
MSG msgId ts msgBody -> e (MSG_, ' ', msgId, ts, Tail msgBody)
NID nId -> e (NID_, ' ', nId)
NMSG -> e NMSG_
END -> e END_
OK -> e OK_
ERR err -> e (ERR_, ' ', err)
@@ -916,25 +619,18 @@ instance ProtocolEncoding BrokerMsg where
e :: Encoding a => a -> ByteString
e = smpEncode
protocolP v = \case
MSG_ -> do
msgId <- _smpP
MSG <$> case v of
1 -> RcvMessage msgId <$> smpP <*> pure noMsgFlags <*> bodyP
2 -> RcvMessage msgId <$> smpP <*> smpP <*> (A.space *> bodyP)
_ -> RcvMessage msgId (MkSystemTime 0 0) noMsgFlags <$> bodyP
where
bodyP = EncRcvMsgBody . unTail <$> smpP
protocolP = \case
MSG_ -> MSG <$> _smpP <*> smpP <*> (unTail <$> smpP)
IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP)
NID_ -> NID <$> _smpP <*> smpP
NMSG_ -> NMSG <$> _smpP <*> smpP
NID_ -> NID <$> _smpP
NMSG_ -> pure NMSG
END_ -> pure END
OK_ -> pure OK
ERR_ -> ERR <$> _smpP
PONG_ -> pure PONG
checkCredentials (_, _, queueId, _) cmd = case cmd of
-- IDS response should not have queue ID
-- IDS response must not have queue ID
IDS _ -> Right cmd
-- ERR response does not always have queue ID
ERR _ -> Right cmd
@@ -944,18 +640,18 @@ instance ProtocolEncoding BrokerMsg where
| otherwise -> Left $ CMD HAS_AUTH
-- other broker responses must have queue ID
_
| B.null queueId -> Left $ CMD NO_ENTITY
| B.null queueId -> Left $ CMD NO_QUEUE
| otherwise -> Right cmd
_smpP :: Encoding a => Parser a
_smpP = A.space *> smpP
-- | Parse SMP protocol commands and broker messages
parseProtocol :: ProtocolEncoding msg => Version -> ByteString -> Either ErrorType msg
parseProtocol v s =
parseProtocol :: (Protocol msg, ProtocolMsgTag (Tag msg)) => ByteString -> Either ErrorType msg
parseProtocol s =
let (tag, params) = B.break (== ' ') s
in case decodeTag tag of
Just cmd -> parse (protocolP v cmd) (CMD SYNTAX) params
Just cmd -> parse (protocolP cmd) (CMD SYNTAX) params
Nothing -> Left $ CMD UNKNOWN
checkParty :: forall t p p'. (PartyI p, PartyI p') => t p' -> Either String (t p)
@@ -997,73 +693,43 @@ instance Encoding CommandError where
smpEncode e = case e of
UNKNOWN -> "UNKNOWN"
SYNTAX -> "SYNTAX"
PROHIBITED -> "PROHIBITED"
NO_AUTH -> "NO_AUTH"
HAS_AUTH -> "HAS_AUTH"
NO_ENTITY -> "NO_ENTITY"
NO_QUEUE -> "NO_QUEUE"
smpP =
A.takeTill (== ' ') >>= \case
"UNKNOWN" -> pure UNKNOWN
"SYNTAX" -> pure SYNTAX
"PROHIBITED" -> pure PROHIBITED
"NO_AUTH" -> pure NO_AUTH
"HAS_AUTH" -> pure HAS_AUTH
"NO_ENTITY" -> pure NO_ENTITY
"NO_QUEUE" -> pure NO_ENTITY
"NO_QUEUE" -> pure NO_QUEUE
_ -> fail "bad command error type"
-- | Send signed SMP transmission to TCP transport.
tPut :: Transport c => THandle c -> NonEmpty (SentRawTransmission) -> IO (NonEmpty (Either TransportError ()))
tPut th trs
| batch th = tPutBatch [] $ L.map tEncode trs
| otherwise = forM trs $ tPutBlock th . tEncode
where
tPutBatch :: [Either TransportError ()] -> NonEmpty ByteString -> IO (NonEmpty (Either TransportError ()))
tPutBatch rs ts = do
let (n, s, ts_) = encodeBatch 0 "" ts
r <- if n == 0 then pure [Left TELargeMsg] else replicate n <$> tPutBlock th (lenEncode n `B.cons` s)
let rs' = rs <> r
case ts_ of
Just ts' -> tPutBatch rs' ts'
_ -> pure $ L.fromList rs'
encodeBatch :: Int -> ByteString -> NonEmpty ByteString -> (Int, ByteString, Maybe (NonEmpty ByteString))
encodeBatch n s ts@(t :| ts_)
| n == 255 = (n, s, Just ts)
| otherwise =
let s' = s <> smpEncode (Large t)
n' = n + 1
in if B.length s' > blockSize th - 1
then (n,s,) $ if n == 0 then L.nonEmpty ts_ else Just ts
else case L.nonEmpty ts_ of
Just ts' -> encodeBatch n' s' ts'
_ -> (n', s', Nothing)
tEncode (sig, tr) = smpEncode (C.signatureBytes sig) <> tr
tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t
encodeTransmission :: ProtocolEncoding c => Version -> ByteString -> Transmission c -> ByteString
encodeTransmission v sessionId (CorrId corrId, queueId, command) =
smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command
encodeTransmission :: Protocol c => ByteString -> Transmission c -> ByteString
encodeTransmission sessionId (CorrId corrId, queueId, command) =
smpEncode (sessionId, corrId, queueId) <> encodeProtocol command
-- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
tGetParse :: Transport c => THandle c -> IO (NonEmpty (Either TransportError RawTransmission))
tGetParse th
| batch th = either ((:| []) . Left) id <$> runExceptT getBatch
| otherwise = (:| []) . (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
where
getBatch :: ExceptT TransportError IO (NonEmpty (Either TransportError RawTransmission))
getBatch = do
s <- ExceptT $ tGetBlock th
ts <- liftEither $ parse smpP TEBadBlock s
pure $ L.map (\(Large t) -> parse transmissionP TEBadBlock t) ts
tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)
tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
-- | Receive client and server transmissions (determined by `cmd` type).
tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (NonEmpty (SignedTransmission cmd))
tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= mapM decodeParseValidate
tGet ::
forall cmd c m.
(Protocol cmd, ProtocolMsgTag (Tag cmd), Transport c, MonadIO m) =>
THandle c ->
m (SignedTransmission cmd)
tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate
where
decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
decodeParseValidate = \case
Right RawTransmission {signature, signed, sessId, corrId, entityId, command}
Right RawTransmission {signature, signed, sessId, corrId, queueId, command}
| sessId == sessionId ->
let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
let decodedTransmission = (,corrId,queueId,command) <$> C.decodeSignature signature
in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
| otherwise -> pure (Nothing, "", (CorrId corrId, "", Left SESSION))
Left _ -> tError ""
@@ -1072,6 +738,6 @@ tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= mapM deco
tError corrId = pure (Nothing, "", (CorrId corrId, "", Left BLOCK))
tParseValidate :: ByteString -> SignedRawTransmission -> m (SignedTransmission cmd)
tParseValidate signed t@(sig, corrId, entityId, command) = do
let cmd = parseProtocol v command >>= checkCredentials t
pure (sig, signed, (CorrId corrId, entityId, cmd))
tParseValidate signed t@(sig, corrId, queueId, command) = do
let cmd = parseProtocol command >>= checkCredentials t
pure (sig, signed, (CorrId corrId, queueId, cmd))
+184 -468
View File
@@ -5,10 +5,7 @@
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
@@ -26,60 +23,34 @@
-- and optional append only log of SMP queue records.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
module Simplex.Messaging.Server
( runSMPServer,
runSMPServerBlocking,
disconnectTransport,
verifyCmdSignature,
dummyVerifyCmd,
)
where
module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking) where
import Control.Logger.Simple
import Control.Concurrent.STM (stateTVar)
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Crypto.Random
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight, partitionEithers)
import Data.Functor (($>))
import Data.List (intercalate)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.Time.Clock.System (getSystemTime)
import Data.Type.Equality
import GHC.TypeLits (KnownNat)
import Network.Socket (ServiceName)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding (Encoding (smpEncode))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore
import Simplex.Messaging.Server.MsgStore.STM (MsgQueue)
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.STM (QueueStore)
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Server
import Simplex.Messaging.Util
import System.Exit (exitFailure)
import System.IO (hPutStrLn)
import System.Mem.Weak (deRefWeak)
import UnliftIO.Concurrent
import UnliftIO.Directory (doesFileExist, renameFile)
import UnliftIO.Exception
import UnliftIO.IO
import UnliftIO.STM
@@ -97,37 +68,37 @@ 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 ()
smpServer :: (MonadUnliftIO m', MonadReader Env m') => m' ()
smpServer = do
s <- asks server
raceAny_
( serverThread s subscribedQ subscribers subscriptions cancelSub :
serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :
map runServer transports
)
`finally` withLog closeStoreLog
runServer :: (MonadUnliftIO m', MonadReader Env m') => (ServiceName, ATransport) -> m' ()
runServer (tcpPort, ATransport t) = do
serverParams <- asks tlsServerParams
runTransportServer started tcpPort serverParams (runClient t)
serverThread ::
forall s.
forall m' s.
MonadUnliftIO m' =>
Server ->
(Server -> TBQueue (QueueId, Client)) ->
(Server -> TMap QueueId Client) ->
(Client -> TMap QueueId s) ->
(s -> m ()) ->
m ()
(Server -> TVar (M.Map QueueId Client)) ->
(Client -> TVar (M.Map QueueId s)) ->
(s -> m' ()) ->
m' ()
serverThread s subQ subs clientSubs unsub = forever $ do
atomically updateSubscribers
$>>= endPreviousSubscriptions
>>= fmap join . mapM endPreviousSubscriptions
>>= mapM_ unsub
where
updateSubscribers :: STM (Maybe (QueueId, Client))
@@ -139,85 +110,36 @@ smpServer started = do
else do
yes <- readTVar $ connected c'
pure $ if yes then Just (qId, c') else Nothing
TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified
endPreviousSubscriptions :: (QueueId, Client) -> m (Maybe s)
stateTVar (subs s) (\cs -> (M.lookup qId cs, M.insert qId clnt cs))
>>= fmap join . mapM clientToBeNotified
endPreviousSubscriptions :: (QueueId, Client) -> m' (Maybe s)
endPreviousSubscriptions (qId, c) = do
void . forkIO . atomically $
writeTBQueue (sndQ c) [(CorrId "", qId, END)]
atomically $ TM.lookupDelete qId (clientSubs c)
writeTBQueue (sndQ c) (CorrId "", qId, END)
atomically . stateTVar (clientSubs c) $ \ss -> (M.lookup qId ss, M.delete qId ss)
expireMessagesThread_ :: ServerConfig -> [m ()]
expireMessagesThread_ ServerConfig {messageExpiration = Just msgExp} = [expireMessages msgExp]
expireMessagesThread_ _ = []
expireMessages :: ExpirationConfig -> m ()
expireMessages expCfg = do
ms <- asks msgStore
quota <- asks $ msgQueueQuota . config
let interval = checkInterval expCfg * 1000000
forever $ do
threadDelay interval
old <- liftIO $ expireBeforeEpoch expCfg
rIds <- M.keysSet <$> readTVarIO ms
forM_ rIds $ \rId ->
atomically (getMsgQueue ms rId quota)
>>= atomically . (`deleteExpiredMsgs` old)
serverStatsThread_ :: ServerConfig -> [m ()]
serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
[logServerStats logStatsStartTime interval serverStatsLogFile]
serverStatsThread_ _ = []
logServerStats :: Int -> Int -> FilePath -> m ()
logServerStats startAt logInterval statsFilePath = do
initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
threadDelay $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues} <- asks serverStats
let interval = 1000000 * logInterval
withFile statsFilePath AppendMode $ \h -> liftIO $ do
hSetBuffering h LineBuffering
forever $ do
ts <- getCurrentTime
fromTime' <- atomically $ swapTVar fromTime ts
qCreated' <- atomically $ swapTVar qCreated 0
qSecured' <- atomically $ swapTVar qSecured 0
qDeleted' <- atomically $ swapTVar qDeleted 0
msgSent' <- atomically $ swapTVar msgSent 0
msgRecv' <- atomically $ swapTVar msgRecv 0
ps <- atomically $ periodStatCounts activeQueues ts
hPutStrLn h $ intercalate "," [iso8601Show $ utctDay fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', dayCount ps, weekCount ps, monthCount ps]
threadDelay interval
runClient :: Transport c => TProxy c -> c -> m ()
runClient :: (Transport c, MonadUnliftIO m, MonadReader Env m) => TProxy c -> c -> m ()
runClient _ h = do
kh <- asks serverIdentity
smpVRange <- asks $ smpServerVRange . config
liftIO (runExceptT $ smpServerHandshake h kh smpVRange) >>= \case
liftIO (runExceptT $ serverHandshake h kh) >>= \case
Right th -> runClientTransport th
Left _ -> pure ()
runClientTransport :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> m ()
runClientTransport th@THandle {thVersion, sessionId} = do
runClientTransport th@THandle {sessionId} = do
q <- asks $ tbqSize . config
ts <- liftIO getSystemTime
c <- atomically $ newClient q thVersion sessionId ts
c <- atomically $ newClient q sessionId
s <- asks server
expCfg <- asks $ inactiveClientExpiration . config
raceAny_ ([send th c, client c s, receive th c] <> disconnectThread_ c expCfg)
raceAny_ [send th c, client c s, receive th c]
`finally` clientDisconnected c
where
disconnectThread_ c (Just expCfg) = [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'
@@ -227,86 +149,55 @@ clientDisconnected c@Client {subscriptions, connected} = do
sameClientSession :: Client -> Client -> Bool
sameClientSession Client {sessionId} Client {sessionId = s'} = sessionId == s'
cancelSub :: MonadUnliftIO m => TVar Sub -> m ()
cancelSub sub =
readTVarIO sub >>= \case
Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
_ -> return ()
cancelSub :: MonadUnliftIO m => Sub -> m ()
cancelSub = \case
Sub {subThread = SubThread t} -> killThread t
_ -> return ()
receive :: 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
receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
receive th Client {rcvQ, sndQ} = forever $ do
(sig, signed, (corrId, queueId, cmdOrError)) <- tGet th
case cmdOrError of
Left e -> write sndQ (corrId, queueId, ERR e)
Right cmd -> do
verified <- verifyTransmission sig signed queueId cmd
if verified
then write rcvQ (corrId, queueId, cmd)
else write sndQ (corrId, queueId, ERR AUTH)
where
cmdAction :: SignedTransmission Cmd -> m (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
cmdAction (sig, signed, (corrId, queueId, cmdOrError)) =
case cmdOrError of
Left e -> pure $ Left (corrId, queueId, ERR e)
Right cmd -> verified <$> verifyTransmission sig signed queueId cmd
where
verified = \case
VRVerified qr -> Right (qr, (corrId, queueId, cmd))
VRFailed -> Left (corrId, queueId, ERR AUTH)
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
write q t = atomically $ writeTBQueue q t
send :: (Transport c, 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
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
send h Client {sndQ, sessionId} = forever $ do
t <- atomically $ readTBQueue sndQ
liftIO $ tPut h (Nothing, encodeTransmission sessionId t)
verifyTransmission ::
forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m VerificationResult
forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m Bool
verifyTransmission sig_ signed queueId cmd = do
case cmd of
Cmd SRecipient (NEW k _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
Cmd SSender PING -> pure $ VRVerified Nothing
Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
Cmd SRecipient (NEW k _) -> pure $ verifySignature k
Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey
Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe . senderKey
Cmd SSender PING -> pure True
Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier
where
verifyCmd :: SParty p -> (QueueRec -> Bool) -> m VerificationResult
verifyCmd :: SParty p -> (QueueRec -> Bool) -> m Bool
verifyCmd party f = do
st <- asks queueStore
q_ <- atomically (getQueue st party queueId)
pure $ case q_ of
Right q -> Just q `verified` f q
_ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
q <- atomically $ getQueue st party queueId
pure $ either (const $ maybe False dummyVerify sig_ `seq` False) f q
verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
verified q cond = if cond then VRVerified q else VRFailed
verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
where
verifyMaybe = maybe (isNothing sig_) verifySignature
verifySignature :: C.APublicVerifyKey -> Bool
verifySignature key = maybe False (verify key) sig_
verify :: C.APublicVerifyKey -> C.ASignature -> Bool
verify (C.APublicVerifyKey a k) sig@(C.ASignature a' s) =
case (testEquality a a', C.signatureSize k == C.signatureSize s) of
(Just Refl, True) -> C.verify' k s signed
_ -> dummyVerifyCmd signed sig `seq` False
dummyVerifyCmd :: ByteString -> C.ASignature -> Bool
dummyVerifyCmd signed (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed
_ -> dummyVerify sig `seq` False
dummyVerify :: C.ASignature -> Bool
dummyVerify (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed
-- These dummy keys are used with `dummyVerify` function to mitigate timing attacks
-- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes
@@ -322,34 +213,28 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448
dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
forever $
atomically (readTBQueue rcvQ)
>>= mapM processCommand
>>= processCommand
>>= atomically . writeTBQueue sndQ
where
processCommand :: (Maybe QueueRec, Transmission Cmd) -> m (Transmission BrokerMsg)
processCommand (qr_, (corrId, queueId, cmd)) = do
processCommand :: Transmission Cmd -> m (Transmission BrokerMsg)
processCommand (corrId, queueId, cmd) = do
st <- asks queueStore
case cmd of
Cmd SSender command ->
case command of
SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
SEND msgBody -> sendMessage st msgBody
PING -> pure (corrId, "", PONG)
Cmd SNotifier NSUB -> subscribeNotifications
Cmd SRecipient command ->
case command of
NEW rKey dhKey ->
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)
NEW rKey dhKey -> createQueue st rKey dhKey
SUB -> subscribeQueue queueId
ACK -> acknowledgeMsg
KEY sKey -> secureQueue_ st sKey
NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
NDEL -> deleteQueueNotifier_ st
NKEY nKey -> addQueueNotifier_ st nKey
OFF -> suspendQueue_ st
DEL -> delQueueAndMsgs st
where
@@ -376,15 +261,12 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
addQueueRetry n qik qRec = do
ids@(rId, _) <- getIds
-- create QueueRec record with these ids and keys
let qr = qRec ids
atomically (addQueue st qr) >>= \case
atomically (addQueue st $ qRec ids) >>= \case
Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
Left e -> pure $ ERR e
Right _ -> do
withLog (`logCreateById` rId)
stats <- asks serverStats
atomically $ modifyTVar (qCreated stats) (+ 1)
subscribeQueue qr rId $> IDS (qik ids)
subscribeQueue rId $> IDS (qik ids)
logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
logCreateById s rId =
@@ -400,236 +282,139 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg)
secureQueue_ st sKey = do
withLog $ \s -> logSecureQueue s queueId sKey
stats <- asks serverStats
atomically $ modifyTVar (qSecured stats) (+ 1)
atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg)
addQueueNotifier_ st notifierKey dhKey = do
(rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
let rcvNtfDhSecret = C.dh' dhKey privDhKey
(corrId,queueId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret
addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m (Transmission BrokerMsg)
addQueueNotifier_ st nKey = (corrId,queueId,) <$> addNotifierRetry 3
where
addNotifierRetry :: Int -> RcvNtfPublicDhKey -> RcvNtfDhSecret -> m BrokerMsg
addNotifierRetry 0 _ _ = pure $ ERR INTERNAL
addNotifierRetry n rcvPublicDhKey rcvNtfDhSecret = do
notifierId <- randomId =<< asks (queueIdBytes . config)
let ntfCreds = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
atomically (addQueueNotifier st queueId ntfCreds) >>= \case
Left DUPLICATE_ -> addNotifierRetry (n - 1) rcvPublicDhKey rcvNtfDhSecret
addNotifierRetry :: Int -> m BrokerMsg
addNotifierRetry 0 = pure $ ERR INTERNAL
addNotifierRetry n = do
nId <- randomId =<< asks (queueIdBytes . config)
atomically (addQueueNotifier st queueId nId nKey) >>= \case
Left DUPLICATE_ -> addNotifierRetry $ n - 1
Left e -> pure $ ERR e
Right _ -> do
withLog $ \s -> logAddNotifier s queueId ntfCreds
pure $ NID notifierId rcvPublicDhKey
deleteQueueNotifier_ :: QueueStore -> m (Transmission BrokerMsg)
deleteQueueNotifier_ st = do
withLog (`logDeleteNotifier` queueId)
okResp <$> atomically (deleteQueueNotifier st queueId)
withLog $ \s -> logAddNotifier s queueId nId nKey
pure $ NID nId
suspendQueue_ :: QueueStore -> m (Transmission BrokerMsg)
suspendQueue_ st = do
withLog (`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 BrokerMsg)
subscribeQueue rId =
atomically (getSubscription rId) >>= deliverMessage tryPeekMsg rId
getSubscription :: RecipientId -> STM Sub
getSubscription rId = do
subs <- readTVar subscriptions
case M.lookup rId subs of
Just s -> tryTakeTMVar (delivered s) $> s
Nothing -> do
writeTBQueue subscribedQ (rId, clnt)
sub <- newTVar =<< newSubscription NoSub
TM.insert rId sub subscriptions
pure sub
deliver :: TVar Sub -> m (Transmission BrokerMsg)
deliver sub = do
q <- getStoreMsgQueue rId
msg_ <- atomically $ tryPeekMsg q
deliverMessage qr rId sub q msg_
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)
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)
withQueue :: (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
withQueue action = maybe (pure $ err AUTH) action qr_
s <- newSubscription
writeTVar subscriptions $ M.insert rId s subs
return s
subscribeNotifications :: m (Transmission BrokerMsg)
subscribeNotifications = atomically $ do
unlessM (TM.member queueId ntfSubscriptions) $ do
subs <- readTVar ntfSubscriptions
when (isNothing $ M.lookup queueId subs) $ do
writeTBQueue ntfSubscribedQ (queueId, clnt)
TM.insert queueId () ntfSubscriptions
writeTVar ntfSubscriptions $ M.insert queueId () subs
pure ok
acknowledgeMsg :: QueueRec -> MsgId -> m (Transmission BrokerMsg)
acknowledgeMsg qr msgId = 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
where
getDelivered :: TVar Sub -> STM (Maybe Sub)
getDelivered sub = do
s@Sub {delivered} <- readTVar sub
tryTakeTMVar delivered $>>= \msgId' ->
if msgId == msgId' || B.null msgId
then pure $ Just s
else putTMVar delivered msgId' $> Nothing
updateStats :: m ()
updateStats = do
stats <- asks serverStats
atomically $ modifyTVar (msgRecv stats) (+ 1)
atomically $ updatePeriodStats (activeQueues stats) queueId
acknowledgeMsg :: m (Transmission BrokerMsg)
acknowledgeMsg =
atomically (withSub queueId $ \s -> const s <$$> tryTakeTMVar (delivered s))
>>= \case
Just (Just s) -> deliverMessage tryDelPeekMsg queueId s
_ -> return $ err NO_MSG
sendMessage :: QueueRec -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
sendMessage qr msgFlags msgBody
withSub :: RecipientId -> (Sub -> STM a) -> STM (Maybe a)
withSub rId f = readTVar subscriptions >>= mapM f . M.lookup rId
sendMessage :: QueueStore -> MsgBody -> m (Transmission BrokerMsg)
sendMessage st msgBody
| B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
| otherwise = case status qr of
QueueOff -> return $ err AUTH
QueueActive ->
mapM mkMessage (C.maxLenBS msgBody) >>= \case
Left _ -> pure $ err LARGE_MSG
Right msg -> do
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
| otherwise = do
qr <- atomically $ getQueue st SSender queueId
either (return . err) storeMessage qr
where
mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
mkMessage body = do
msgId <- randomId =<< asks (msgIdBytes . config)
msgTs <- liftIO getSystemTime
pure $ Message msgId msgTs msgFlags body
storeMessage :: QueueRec -> m (Transmission BrokerMsg)
storeMessage qr = case status qr of
QueueOff -> return $ err AUTH
QueueActive ->
mkMessage >>= \case
Left _ -> pure $ err LARGE_MSG
Right msg -> do
ms <- asks msgStore
quota <- asks $ msgQueueQuota . config
atomically $ do
q <- getMsgQueue ms (recipientId qr) quota
ifM (isFull q) (pure $ err QUOTA) $ do
trySendNotification
writeMsg q msg
pure ok
where
mkMessage :: m (Either C.CryptoError Message)
mkMessage = do
msgId <- randomId =<< asks (msgIdBytes . config)
ts <- liftIO getSystemTime
let c = C.cbEncrypt (rcvDhSecret qr) (C.cbNonce msgId) msgBody (maxMessageLength + 2)
pure $ Message msgId ts <$> c
trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
trySendNotification msg ntfNonceDrg =
forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
trySendNotification :: STM ()
trySendNotification =
forM_ (notifier qr) $ \(nId, _) ->
mapM_ (writeNtf nId) . M.lookup nId =<< readTVar 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)]
writeNtf :: NotifierId -> Client -> STM ()
writeNtf nId Client {sndQ = q} =
unlessM (isFullTBQueue sndQ) $
writeTBQueue q (CorrId "", nId, NMSG)
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
deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m (Transmission BrokerMsg)
deliverMessage tryPeek rId = \case
Sub {subThread = NoSub} -> do
ms <- asks msgStore
quota <- asks $ msgQueueQuota . config
q <- atomically $ getMsgQueue ms rId quota
atomically (tryPeek q) >>= \case
Nothing -> forkSub q $> ok
Just msg -> atomically setDelivered $> (corrId, rId, msgCmd msg)
_ -> pure ok
where
forkSub :: m ()
forkSub = do
atomically . modifyTVar sub $ \s -> s {subThread = SubPending}
t <- mkWeakThreadId =<< forkIO subscriber
atomically . modifyTVar sub $ \case
forkSub :: MsgQueue -> m ()
forkSub q = do
atomically . setSub $ \s -> s {subThread = SubPending}
t <- forkIO $ subscriber q
atomically . setSub $ \case
s@Sub {subThread = SubPending} -> s {subThread = SubThread t}
s -> s
where
subscriber = 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 (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) ()
msgCmd :: Message -> BrokerMsg
msgCmd Message {msgId, ts, msgBody} = MSG msgId ts msgBody
delQueueAndMsgs :: QueueStore -> m (Transmission BrokerMsg)
delQueueAndMsgs st = do
withLog (`logDeleteQueue` queueId)
ms <- asks msgStore
stats <- asks serverStats
atomically $ modifyTVar (qDeleted stats) (+ 1)
atomically $
deleteQueue st queueId >>= \case
Left e -> pure $ err e
@@ -652,80 +437,11 @@ withLog action = do
randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString
randomId n = do
gVar <- asks idsDrg
atomically (C.pseudoRandomBytes n gVar)
atomically (randomBytes n gVar)
saveServerMessages :: (MonadUnliftIO m, MonadReader Env m) => m ()
saveServerMessages = asks (storeMsgsFile . config) >>= mapM_ saveMessages
where
saveMessages f = do
logInfo $ "saving messages to file " <> T.pack f
ms <- asks msgStore
liftIO . withFile f WriteMode $ \h ->
readTVarIO ms >>= mapM_ (saveQueueMsgs ms h) . M.keys
logInfo "messages saved"
where
saveQueueMsgs ms h rId =
atomically (flushMsgQueue ms rId)
>>= mapM_ (B.hPutStrLn h . strEncode . MLRv3 rId)
restoreServerMessages :: forall m. (MonadUnliftIO m, MonadReader Env m) => m ()
restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages
where
restoreMessages f = whenM (doesFileExist f) $ do
logInfo $ "restoring messages from file " <> T.pack f
st <- asks queueStore
ms <- asks msgStore
quota <- asks $ msgQueueQuota . config
runExceptT (liftIO (B.readFile f) >>= mapM_ (restoreMsg st ms quota) . B.lines) >>= \case
Left e -> do
logError . T.pack $ "error restoring messages: " <> e
liftIO exitFailure
_ -> do
renameFile f $ f <> ".bak"
logInfo "messages restored"
where
restoreMsg st ms quota s = do
r <- liftEither . first (msgErr "parsing") $ strDecode s
case r of
MLRv3 rId msg -> addToMsgQueue rId msg
MLRv1 rId encMsg -> do
qr <- liftEitherError (msgErr "queue unknown") . atomically $ getQueue st SRecipient rId
msg' <- updateMsgV1toV3 qr encMsg
addToMsgQueue rId msg'
where
addToMsgQueue rId msg = do
full <- atomically $ do
q <- getMsgQueue ms rId quota
ifM (isFull q) (pure True) (writeMsg q msg $> False)
when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message))
updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
let nonce = C.cbNonce msgId
msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
pure Message {msgId, msgTs, msgFlags, msgBody}
msgErr :: Show e => String -> e -> String
msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s)
saveServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
saveServerStats =
asks (serverStatsBackupFile . config)
>>= mapM_ (\f -> asks serverStats >>= atomically . getServerStatsData >>= liftIO . saveStats f)
where
saveStats f stats = do
logInfo $ "saving server stats to file " <> T.pack f
B.writeFile f $ strEncode stats
logInfo "server stats saved"
restoreServerStats :: (MonadUnliftIO m, MonadReader Env m) => m ()
restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats
where
restoreStats f = whenM (doesFileExist f) $ do
logInfo $ "restoring server stats from file " <> T.pack f
liftIO (strDecode <$> B.readFile f) >>= \case
Right d -> do
s <- asks serverStats
atomically $ setServerStats s d
renameFile f $ f <> ".bak"
logInfo "server stats restored"
Left e -> do
logInfo $ "error restoring server stats: " <> T.pack e
liftIO exitFailure
randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString
randomBytes n gVar = do
g <- readTVar gVar
let (bytes, g') = randomBytesGenerate n g
writeTVar gVar g'
return bytes
-292
View File
@@ -1,292 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Messaging.Server.CLI where
import Control.Monad
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight)
import Data.Ini (Ini, lookupValue, readIniFile)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.X509.Validation (Fingerprint (..))
import Network.Socket (HostName, ServiceName)
import Options.Applicative
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
import Simplex.Messaging.Transport.Server (loadFingerprint)
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (whenM)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
import System.Exit (exitFailure)
import System.FilePath (combine)
import System.IO (BufferMode (..), IOMode (..), hFlush, hGetLine, hSetBuffering, stderr, stdout, withFile)
import System.Process (readCreateProcess, shell)
import Text.Read (readMaybe)
data ServerCLIConfig cfg = ServerCLIConfig
{ cfgDir :: FilePath,
logDir :: FilePath,
iniFile :: FilePath,
storeLogFile :: FilePath,
caKeyFile :: FilePath,
caCrtFile :: FilePath,
serverKeyFile :: FilePath,
serverCrtFile :: FilePath,
fingerprintFile :: FilePath,
defaultServerPort :: ServiceName,
executableName :: String,
serverVersion :: String,
mkIniFile :: Bool -> ServiceName -> String,
mkServerConfig :: Maybe FilePath -> [(ServiceName, ATransport)] -> Ini -> cfg
}
protocolServerCLI :: ServerCLIConfig cfg -> (cfg -> IO ()) -> IO ()
protocolServerCLI cliCfg@ServerCLIConfig {iniFile, executableName} server =
getCliCommand cliCfg >>= \case
Init opts ->
doesFileExist iniFile >>= \case
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
_ -> initializeServer cliCfg opts
Start ->
doesFileExist iniFile >>= \case
True -> readIniFile iniFile >>= either exitError (runServer cliCfg server)
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
Delete -> do
confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
cleanup cliCfg
putStrLn "Deleted configuration and log files"
exitError :: String -> IO ()
exitError msg = putStrLn msg >> exitFailure
confirmOrExit :: String -> IO ()
confirmOrExit s = do
putStrLn s
putStr "Continue (Y/n): "
hFlush stdout
ok <- getLine
when (ok /= "Y") exitFailure
data CliCommand
= Init InitOptions
| Start
| Delete
data InitOptions = InitOptions
{ enableStoreLog :: Bool,
signAlgorithm :: SignAlgorithm,
ip :: HostName,
fqdn :: Maybe HostName
}
deriving (Show)
data SignAlgorithm = ED448 | ED25519
deriving (Read, Show)
getCliCommand :: ServerCLIConfig cfg -> IO CliCommand
getCliCommand cliCfg =
customExecParser
(prefs showHelpOnEmpty)
( info
(helper <*> versionOption <*> cliCommandP cliCfg)
(header version <> fullDesc)
)
where
versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
version = serverVersion cliCfg
cliCommandP :: ServerCLIConfig cfg -> Parser CliCommand
cliCommandP ServerCLIConfig {cfgDir, logDir, iniFile} =
hsubparser
( command "init" (info initP (progDesc $ "Initialize server - creates " <> cfgDir <> " and " <> logDir <> " directories and configuration files"))
<> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
)
where
initP :: Parser CliCommand
initP =
Init
<$> ( InitOptions
<$> switch
( long "store-log"
<> short 'l'
<> help "Enable store log for persistence"
)
<*> option
(maybeReader readMaybe)
( long "sign-algorithm"
<> short 'a'
<> help "Signature algorithm used for TLS certificates: ED25519, ED448"
<> value ED448
<> showDefault
<> metavar "ALG"
)
<*> strOption
( long "ip"
<> help
"Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
<> value "127.0.0.1"
<> showDefault
<> metavar "IP"
)
<*> (optional . strOption)
( long "fqdn"
<> short 'n'
<> help "Server FQDN used as Common Name for TLS online certificate"
<> showDefault
<> metavar "FQDN"
)
)
initializeServer :: ServerCLIConfig cfg -> InitOptions -> IO ()
initializeServer cliCfg InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
clearDirs cliCfg
createDirectoryIfMissing True cfgDir
createDirectoryIfMissing True logDir
createX509
fp <- saveFingerprint
writeFile iniFile $ mkIniFile enableStoreLog defaultServerPort
putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
printServiceInfo cliCfg fp
warnCAPrivateKeyFile
where
ServerCLIConfig {cfgDir, logDir, iniFile, executableName, caKeyFile, caCrtFile, serverKeyFile, serverCrtFile, fingerprintFile, defaultServerPort, mkIniFile} = cliCfg
createX509 = do
createOpensslCaConf
createOpensslServerConf
-- CA certificate (identity/offline)
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile
run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile
-- server certificate (online)
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile
run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile
run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile
where
run cmd = void $ readCreateProcess (shell cmd) ""
opensslCaConfFile = combine cfgDir "openssl_ca.conf"
opensslServerConfFile = combine cfgDir "openssl_server.conf"
serverCsrFile = combine cfgDir "server.csr"
createOpensslCaConf =
writeFile
opensslCaConfFile
"[req]\n\
\distinguished_name = req_distinguished_name\n\
\prompt = no\n\n\
\[req_distinguished_name]\n\
\CN = SMP server CA\n\
\O = SimpleX\n\n\
\[v3]\n\
\subjectKeyIdentifier = hash\n\
\authorityKeyIdentifier = keyid:always\n\
\basicConstraints = critical,CA:true\n"
-- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
-- IP and FQDN can't both be used as server address interchangeably even if IP is added
-- as Subject Alternative Name, unless the following validation hook is disabled:
-- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
createOpensslServerConf =
writeFile
opensslServerConfFile
( "[req]\n\
\distinguished_name = req_distinguished_name\n\
\prompt = no\n\n\
\[req_distinguished_name]\n"
<> ("CN = " <> cn <> "\n\n")
<> "[v3]\n\
\basicConstraints = CA:FALSE\n\
\keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
\extendedKeyUsage = serverAuth\n"
)
where
cn = fromMaybe ip fqdn
saveFingerprint = do
Fingerprint fp <- loadFingerprint caCrtFile
withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
pure fp
warnCAPrivateKeyFile =
putStrLn $
"----------\n\
\You should store CA private key securely and delete it from the server.\n\
\If server TLS credential is compromised this key can be used to sign a new one, \
\keeping the same server identity and established connections.\n\
\CA private key location:\n"
<> caKeyFile
<> "\n----------"
data IniOptions = IniOptions
{ enableStoreLog :: Bool,
port :: ServiceName,
enableWebsockets :: Bool
}
mkIniOptions :: Ini -> IniOptions
mkIniOptions ini =
IniOptions
{ enableStoreLog = (== "on") $ strictIni "STORE_LOG" "enable" ini,
port = T.unpack $ strictIni "TRANSPORT" "port" ini,
enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
}
strictIni :: String -> String -> Ini -> T.Text
strictIni section key ini =
fromRight (error ("no key " <> key <> " in section " <> section)) $
lookupValue (T.pack section) (T.pack key) ini
readStrictIni :: Read a => String -> String -> Ini -> a
readStrictIni section key = read . T.unpack . strictIni section key
runServer :: ServerCLIConfig cfg -> (cfg -> IO ()) -> Ini -> IO ()
runServer cliCfg server ini = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
fp <- checkSavedFingerprint
printServiceInfo cliCfg fp
let IniOptions {enableStoreLog, port, enableWebsockets} = mkIniOptions ini
transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
logFile = if enableStoreLog then Just storeLogFile else Nothing
cfg = mkServerConfig logFile transports ini
printServerConfig logFile transports
server cfg
where
ServerCLIConfig {storeLogFile, caCrtFile, fingerprintFile, mkServerConfig} = cliCfg
checkSavedFingerprint = do
savedFingerprint <- withFile fingerprintFile ReadMode hGetLine
Fingerprint fp <- loadFingerprint caCrtFile
when (B.pack savedFingerprint /= strEncode fp) $
exitError "Stored fingerprint is invalid."
pure fp
printServerConfig logFile transports = do
putStrLn $ case logFile of
Just f -> "Store log: " <> f
_ -> "Store log disabled."
forM_ transports $ \(p, ATransport t) ->
putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
cleanup :: ServerCLIConfig cfg -> IO ()
cleanup ServerCLIConfig {cfgDir, logDir} = do
deleteDirIfExists cfgDir
deleteDirIfExists logDir
where
deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
clearDirs :: ServerCLIConfig cfg -> IO ()
clearDirs ServerCLIConfig {cfgDir, logDir} = do
clearDirIfExists cfgDir
clearDirIfExists logDir
where
clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= mapM_ (removePathForcibly . combine path)
printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO ()
printServiceInfo ServerCLIConfig {serverVersion} fpStr = do
putStrLn serverVersion
B.putStrLn $ "Fingerprint: " <> strEncode fpStr
+37 -82
View File
@@ -9,30 +9,21 @@ import Control.Concurrent (ThreadId)
import Control.Monad.IO.Unlift
import Crypto.Random
import Data.ByteString.Char8 (ByteString)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock.System (SystemTime)
import Data.X509.Validation (Fingerprint (..))
import Network.Socket (ServiceName)
import qualified Network.TLS as T
import Numeric.Natural
import Simplex.Messaging.Crypto (KeyHash (..))
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..))
import Simplex.Messaging.Server.QueueStore (QueueRec (..))
import Simplex.Messaging.Server.QueueStore.STM
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
import Simplex.Messaging.Version
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
import UnliftIO.STM
data ServerConfig = ServerConfig
@@ -42,46 +33,13 @@ data ServerConfig = ServerConfig
msgQueueQuota :: Natural,
queueIdBytes :: Int,
msgIdBytes :: Int,
storeLogFile :: Maybe FilePath,
storeMsgsFile :: Maybe FilePath,
-- | set to False to prohibit creating new queues
allowNewQueues :: Bool,
-- | time after which the messages can be removed from the queues and check interval, seconds
messageExpiration :: Maybe ExpirationConfig,
-- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),
-- and check interval, seconds
inactiveClientExpiration :: Maybe ExpirationConfig,
-- | log SMP server usage statistics, only aggregates are logged, seconds
logStatsInterval :: Maybe Int,
-- | time of the day when the stats are logged first, to log at consistent times,
-- irrespective of when the server is started (seconds from 00:00 UTC)
logStatsStartTime :: Int,
-- | file to log stats
serverStatsLogFile :: FilePath,
-- | file to save and restore stats
serverStatsBackupFile :: Maybe FilePath,
-- | CA certificate private key is not needed for initialization
storeLog :: Maybe (StoreLog 'ReadMode),
-- CA certificate private key is not needed for initialization
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
-- | SMP client-server protocol version range
smpServerVRange :: VersionRange
certificateFile :: FilePath
}
defaultMessageExpiration :: ExpirationConfig
defaultMessageExpiration =
ExpirationConfig
{ ttl = 30 * 86400, -- seconds, 30 days
checkInterval = 43200 -- seconds, 12 hours
}
defaultInactiveClientExpiration :: ExpirationConfig
defaultInactiveClientExpiration =
ExpirationConfig
{ ttl = 86400, -- seconds, 24 hours
checkInterval = 43200 -- seconds, 12 hours
}
data Env = Env
{ config :: ServerConfig,
server :: Server,
@@ -90,83 +48,80 @@ data Env = Env
msgStore :: STMMsgStore,
idsDrg :: TVar ChaChaDRG,
storeLog :: Maybe (StoreLog 'WriteMode),
tlsServerParams :: T.ServerParams,
serverStats :: ServerStats
tlsServerParams :: T.ServerParams
}
data Server = Server
{ subscribedQ :: TBQueue (RecipientId, Client),
subscribers :: TMap RecipientId Client,
subscribers :: TVar (Map RecipientId Client),
ntfSubscribedQ :: TBQueue (NotifierId, Client),
notifiers :: TMap NotifierId Client
notifiers :: TVar (Map NotifierId Client)
}
data Client = Client
{ subscriptions :: TMap RecipientId (TVar Sub),
ntfSubscriptions :: TMap NotifierId (),
rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
thVersion :: Version,
{ subscriptions :: TVar (Map RecipientId Sub),
ntfSubscriptions :: TVar (Map NotifierId ()),
rcvQ :: TBQueue (Transmission Cmd),
sndQ :: TBQueue (Transmission BrokerMsg),
sessionId :: ByteString,
connected :: TVar Bool,
activeAt :: TVar SystemTime
connected :: TVar Bool
}
data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub
data SubscriptionThread = NoSub | SubPending | SubThread ThreadId
data Sub = Sub
{ subThread :: SubscriptionThread,
delivered :: TMVar MsgId
delivered :: TMVar ()
}
newServer :: Natural -> STM Server
newServer qSize = do
subscribedQ <- newTBQueue qSize
subscribers <- TM.empty
subscribers <- newTVar M.empty
ntfSubscribedQ <- newTBQueue qSize
notifiers <- TM.empty
notifiers <- newTVar M.empty
return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers}
newClient :: Natural -> Version -> ByteString -> SystemTime -> STM Client
newClient qSize thVersion sessionId ts = do
subscriptions <- TM.empty
ntfSubscriptions <- TM.empty
newClient :: Natural -> ByteString -> STM Client
newClient qSize sessionId = do
subscriptions <- newTVar M.empty
ntfSubscriptions <- newTVar M.empty
rcvQ <- newTBQueue qSize
sndQ <- newTBQueue qSize
connected <- newTVar True
activeAt <- newTVar ts
return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, thVersion, sessionId, connected, activeAt}
return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, connected}
newSubscription :: SubscriptionThread -> STM Sub
newSubscription subThread = do
newSubscription :: STM Sub
newSubscription = do
delivered <- newEmptyTMVar
return Sub {subThread, delivered}
return Sub {subThread = NoSub, delivered}
newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile} = do
server <- atomically $ newServer (serverTbqSize config)
queueStore <- atomically newQueueStore
msgStore <- atomically newMsgStore
idsDrg <- drgNew >>= newTVarIO
storeLog <- liftIO $ openReadStoreLog `mapM` storeLogFile
s' <- restoreQueues queueStore `mapM` storeLog
s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig)
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
let serverIdentity = KeyHash fp
serverStats <- atomically . newServerStats =<< liftIO getCurrentTime
return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog = s', tlsServerParams, serverStats}
return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog = s', tlsServerParams}
where
restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode)
restoreQueues QueueStore {queues, senders, notifiers} s = do
(qs, s') <- liftIO $ readWriteStoreLog s
atomically $ do
writeTVar queues =<< mapM newTVar qs
writeTVar senders $ M.foldr' addSender M.empty qs
writeTVar notifiers $ M.foldr' addNotifier M.empty qs
restoreQueues queueStore s = do
(queues, s') <- liftIO $ readWriteStoreLog s
atomically $
modifyTVar queueStore $ \d ->
d
{ queues,
senders = M.foldr' addSender M.empty queues,
notifiers = M.foldr' addNotifier M.empty queues
}
pure s'
addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId
addSender q = M.insert (senderId q) (recipientId q)
addNotifier :: QueueRec -> Map NotifierId RecipientId -> Map NotifierId RecipientId
addNotifier q = case notifier q of
Nothing -> id
Just NtfCreds {notifierId} -> M.insert notifierId (recipientId q)
Just (nId, _) -> M.insert nId (recipientId q)
@@ -1,17 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Messaging.Server.Expiration where
import Control.Monad.IO.Class
import Data.Int (Int64)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
data ExpirationConfig = ExpirationConfig
{ -- time after which the entity can be expired, seconds
ttl :: Int64,
-- interval to check expiration, seconds
checkInterval :: Int
}
expireBeforeEpoch :: ExpirationConfig -> IO Int64
expireBeforeEpoch ExpirationConfig {ttl} = subtract ttl . systemSeconds <$> liftIO getSystemTime
+8 -17
View File
@@ -1,33 +1,24 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Server.MsgStore where
import Control.Applicative ((<|>))
import Data.Int (Int64)
import Data.Time.Clock.System (SystemTime)
import Numeric.Natural
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (Message (..), MsgId, RcvMessage (..), RecipientId)
import Simplex.Messaging.Protocol (MsgBody, MsgId, RecipientId)
data MsgLogRecord = MLRv3 RecipientId Message | MLRv1 RecipientId RcvMessage
instance StrEncoding MsgLogRecord where
strEncode = \case
MLRv3 rId msg -> strEncode (Str "v3", rId, msg)
MLRv1 rId msg -> strEncode (rId, msg)
strP = "v3 " *> (MLRv3 <$> strP_ <*> strP) <|> MLRv1 <$> strP_ <*> strP
data Message = Message
{ msgId :: MsgId,
ts :: SystemTime,
msgBody :: MsgBody
}
class MonadMsgStore s q m | s -> q where
getMsgQueue :: s -> RecipientId -> Natural -> m q
delMsgQueue :: s -> RecipientId -> m ()
flushMsgQueue :: s -> RecipientId -> m [Message]
class MonadMsgQueue q m where
isFull :: q -> m Bool
writeMsg :: q -> Message -> m () -- non blocking
tryPeekMsg :: q -> m (Maybe Message) -- non blocking
peekMsg :: q -> m Message -- blocking
tryDelMsg :: q -> MsgId -> m Bool -- non blocking
tryDelPeekMsg :: q -> MsgId -> m (Bool, Maybe Message) -- atomic delete (== read) last and peek next message, if available
deleteExpiredMsgs :: q -> Int64 -> m ()
tryDelPeekMsg :: q -> m (Maybe Message) -- atomic delete (== read) last and peek next message, if available
+16 -44
View File
@@ -2,47 +2,40 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
module Simplex.Messaging.Server.MsgStore.STM where
import Control.Concurrent.STM.TBQueue (flushTBQueue)
import Control.Monad (when)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.Int (Int64)
import Data.Time.Clock.System (SystemTime (systemSeconds))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Numeric.Natural
import Simplex.Messaging.Protocol (Message (..), MsgId, RecipientId)
import Simplex.Messaging.Protocol (RecipientId)
import Simplex.Messaging.Server.MsgStore
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import UnliftIO.STM
newtype MsgQueue = MsgQueue {msgQueue :: TBQueue Message}
type STMMsgStore = TMap RecipientId MsgQueue
newtype MsgStoreData = MsgStoreData {messages :: Map RecipientId MsgQueue}
type STMMsgStore = TVar MsgStoreData
newMsgStore :: STM STMMsgStore
newMsgStore = TM.empty
newMsgStore = newTVar $ MsgStoreData M.empty
instance MonadMsgStore STMMsgStore MsgQueue STM where
getMsgQueue :: STMMsgStore -> RecipientId -> Natural -> STM MsgQueue
getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
getMsgQueue store rId quota = do
m <- messages <$> readTVar store
maybe (newQ m) return $ M.lookup rId m
where
newQ = do
newQ m' = do
q <- MsgQueue <$> newTBQueue quota
TM.insert rId q st
writeTVar store . MsgStoreData $ M.insert rId q m'
return q
delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
delMsgQueue st rId = TM.delete rId st
flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
flushMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (flushTBQueue . msgQueue)
delMsgQueue store rId =
modifyTVar store $ MsgStoreData . M.delete rId . messages
instance MonadMsgQueue MsgQueue STM where
isFull :: MsgQueue -> STM Bool
@@ -57,27 +50,6 @@ instance MonadMsgQueue MsgQueue STM where
peekMsg :: MsgQueue -> STM Message
peekMsg = peekTBQueue . msgQueue
tryDelMsg :: MsgQueue -> MsgId -> STM Bool
tryDelMsg (MsgQueue q) msgId' =
tryPeekTBQueue q >>= \case
Just Message {msgId}
| msgId == msgId' || B.null msgId' -> tryReadTBQueue q $> True
| otherwise -> pure False
_ -> pure False
-- atomic delete (== read) last and peek next message if available
tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Bool, Maybe Message)
tryDelPeekMsg (MsgQueue q) msgId' =
tryPeekTBQueue q >>= \case
msg_@(Just Message {msgId})
| msgId == msgId' || B.null msgId' -> (True,) <$> (tryReadTBQueue q >> tryPeekTBQueue q)
| otherwise -> pure (False, msg_)
_ -> pure (False, Nothing)
deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
deleteExpiredMsgs (MsgQueue q) old = loop
where
loop = tryPeekTBQueue q >>= mapM_ delOldMsg
delOldMsg Message {msgTs} =
when (systemSeconds msgTs < old) $
tryReadTBQueue q >> loop
tryDelPeekMsg :: MsgQueue -> STM (Maybe Message)
tryDelPeekMsg (MsgQueue q) = tryReadTBQueue q >> tryPeekTBQueue q
+2 -19
View File
@@ -1,11 +1,9 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Messaging.Server.QueueStore where
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
data QueueRec = QueueRec
@@ -14,23 +12,9 @@ data QueueRec = QueueRec
rcvDhSecret :: RcvDhSecret,
senderId :: SenderId,
senderKey :: Maybe SndPublicVerifyKey,
notifier :: Maybe NtfCreds,
notifier :: Maybe (NotifierId, NtfPublicVerifyKey),
status :: QueueStatus
}
deriving (Eq, Show)
data NtfCreds = NtfCreds
{ notifierId :: NotifierId,
notifierKey :: NtfPublicVerifyKey,
rcvNtfDhSecret :: RcvNtfDhSecret
}
deriving (Eq, Show)
instance StrEncoding NtfCreds where
strEncode NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} = strEncode (notifierId, notifierKey, rcvNtfDhSecret)
strP = do
(notifierId, notifierKey, rcvNtfDhSecret) <- strP
pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
data QueueStatus = QueueActive | QueueOff deriving (Eq, Show)
@@ -38,7 +22,6 @@ class MonadQueueStore s m where
addQueue :: s -> QueueRec -> m (Either ErrorType ())
getQueue :: s -> SParty p -> QueueId -> m (Either ErrorType QueueRec)
secureQueue :: s -> RecipientId -> SndPublicVerifyKey -> m (Either ErrorType QueueRec)
addQueueNotifier :: s -> RecipientId -> NtfCreds -> m (Either ErrorType QueueRec)
deleteQueueNotifier :: s -> RecipientId -> m (Either ErrorType ())
addQueueNotifier :: s -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> m (Either ErrorType QueueRec)
suspendQueue :: s -> RecipientId -> m (Either ErrorType ())
deleteQueue :: s -> RecipientId -> m (Either ErrorType ())
+82 -65
View File
@@ -3,7 +3,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
@@ -12,89 +11,107 @@
module Simplex.Messaging.Server.QueueStore.STM where
import Control.Monad
import Data.Functor (($>))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (ifM, ($>>=))
import UnliftIO.STM
data QueueStore = QueueStore
{ queues :: TMap RecipientId (TVar QueueRec),
senders :: TMap SenderId RecipientId,
notifiers :: TMap NotifierId RecipientId
data QueueStoreData = QueueStoreData
{ queues :: Map RecipientId QueueRec,
senders :: Map SenderId RecipientId,
notifiers :: Map NotifierId RecipientId
}
type QueueStore = TVar QueueStoreData
newQueueStore :: STM QueueStore
newQueueStore = do
queues <- TM.empty
senders <- TM.empty
notifiers <- TM.empty
pure QueueStore {queues, senders, notifiers}
newQueueStore = newTVar QueueStoreData {queues = M.empty, senders = M.empty, notifiers = M.empty}
instance MonadQueueStore QueueStore STM where
addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ())
addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = do
ifM hasId (pure $ Left DUPLICATE_) $ do
qVar <- newTVar q
TM.insert rId qVar queues
TM.insert sId rId senders
pure $ Right ()
where
hasId = (||) <$> TM.member rId queues <*> TM.member sId senders
addQueue store qRec@QueueRec {recipientId = rId, senderId = sId} = do
cs@QueueStoreData {queues, senders} <- readTVar store
if M.member rId queues || M.member sId senders
then return $ Left DUPLICATE_
else do
writeTVar store $
cs
{ queues = M.insert rId qRec queues,
senders = M.insert sId rId senders
}
return $ Right ()
getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)
getQueue QueueStore {queues, senders, notifiers} party qId =
toResult <$> (mapM readTVar =<< getVar)
getQueue st party qId = do
cs <- readTVar st
pure $ case party of
SRecipient -> getRcpQueue cs qId
SSender -> getPartyQueue cs senders
SNotifier -> getPartyQueue cs notifiers
where
getVar = case party of
SRecipient -> TM.lookup qId queues
SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues)
SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues)
getPartyQueue ::
QueueStoreData ->
(QueueStoreData -> Map QueueId RecipientId) ->
Either ErrorType QueueRec
getPartyQueue cs recipientIds =
case M.lookup qId $ recipientIds cs of
Just rId -> getRcpQueue cs rId
Nothing -> Left AUTH
secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec)
secureQueue QueueStore {queues} rId sKey =
withQueue rId queues $ \qVar ->
readTVar qVar >>= \q -> case senderKey q of
Just _ -> pure Nothing
_ -> writeTVar qVar q {senderKey = Just sKey} $> Just q
secureQueue store rId sKey =
updateQueues store rId $ \cs c ->
case senderKey c of
Just _ -> (Left AUTH, cs)
_ -> (Right c, cs {queues = M.insert rId c {senderKey = Just sKey} (queues cs)})
addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec)
addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $
withQueue rId queues $ \qVar -> do
q <- readTVar qVar
forM_ (notifier q) $ (`TM.delete` notifiers) . notifierId
writeTVar qVar q {notifier = Just ntfCreds}
TM.insert nId rId notifiers
pure $ Just q
deleteQueueNotifier :: QueueStore -> RecipientId -> STM (Either ErrorType ())
deleteQueueNotifier QueueStore {queues, notifiers} rId =
withQueue rId queues $ \qVar -> do
q <- readTVar qVar
forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
writeTVar qVar q {notifier = Nothing}
pure $ Just ()
addQueueNotifier :: QueueStore -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> STM (Either ErrorType QueueRec)
addQueueNotifier store rId nId nKey = do
cs@QueueStoreData {queues, notifiers} <- readTVar store
if M.member nId notifiers
then pure $ Left DUPLICATE_
else case M.lookup rId queues of
Nothing -> pure $ Left AUTH
Just q -> case notifier q of
Just _ -> pure $ Left AUTH
_ -> do
writeTVar store $
cs
{ queues = M.insert rId q {notifier = Just (nId, nKey)} queues,
notifiers = M.insert nId rId notifiers
}
pure $ Right q
suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
suspendQueue QueueStore {queues} rId =
withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
suspendQueue store rId =
updateQueues store rId $ \cs c ->
(Right (), cs {queues = M.insert rId c {status = QueueOff} (queues cs)})
deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
deleteQueue QueueStore {queues, senders, notifiers} rId = do
TM.lookupDelete rId queues >>= \case
Just qVar ->
readTVar qVar >>= \q -> do
TM.delete (senderId q) senders
forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
pure $ Right ()
_ -> pure $ Left AUTH
deleteQueue store rId =
updateQueues store rId $ \cs c ->
( Right (),
cs
{ queues = M.delete rId (queues cs),
senders = M.delete (senderId c) (senders cs)
}
)
toResult :: Maybe a -> Either ErrorType a
toResult = maybe (Left AUTH) Right
updateQueues ::
QueueStore ->
RecipientId ->
(QueueStoreData -> QueueRec -> (Either ErrorType a, QueueStoreData)) ->
STM (Either ErrorType a)
updateQueues store rId update = do
cs <- readTVar store
let conn = getRcpQueue cs rId
either (return . Left) (_update cs) conn
where
_update cs c = do
let (res, cs') = update cs c
writeTVar store cs'
return res
withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM (Maybe a)) -> STM (Either ErrorType a)
withQueue rId queues f = toResult <$> TM.lookup rId queues $>>= f
getRcpQueue :: QueueStoreData -> RecipientId -> Either ErrorType QueueRec
getRcpQueue cs rId = maybe (Left AUTH) Right . M.lookup rId $ queues cs
-168
View File
@@ -1,168 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Server.Stats where
import Control.Applicative (optional)
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Char8 as B
import Data.Set (Set)
import qualified Data.Set as S
import Data.Time.Calendar.Month.Compat (pattern MonthDay)
import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
import Data.Time.Clock (UTCTime (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (RecipientId)
import UnliftIO.STM
data ServerStats = ServerStats
{ fromTime :: TVar UTCTime,
qCreated :: TVar Int,
qSecured :: TVar Int,
qDeleted :: TVar Int,
msgSent :: TVar Int,
msgRecv :: TVar Int,
activeQueues :: PeriodStats RecipientId
}
data ServerStatsData = ServerStatsData
{ _fromTime :: UTCTime,
_qCreated :: Int,
_qSecured :: Int,
_qDeleted :: Int,
_msgSent :: Int,
_msgRecv :: Int,
_activeQueues :: PeriodStatsData RecipientId
}
newServerStats :: UTCTime -> STM ServerStats
newServerStats ts = do
fromTime <- newTVar ts
qCreated <- newTVar 0
qSecured <- newTVar 0
qDeleted <- newTVar 0
msgSent <- newTVar 0
msgRecv <- newTVar 0
activeQueues <- newPeriodStats
pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues}
getServerStatsData :: ServerStats -> STM ServerStatsData
getServerStatsData s = do
_fromTime <- readTVar $ fromTime s
_qCreated <- readTVar $ qCreated s
_qSecured <- readTVar $ qSecured s
_qDeleted <- readTVar $ qDeleted s
_msgSent <- readTVar $ msgSent s
_msgRecv <- readTVar $ msgRecv s
_activeQueues <- getPeriodStatsData $ activeQueues s
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues}
setServerStats :: ServerStats -> ServerStatsData -> STM ()
setServerStats s d = do
writeTVar (fromTime s) (_fromTime d)
writeTVar (qCreated s) (_qCreated d)
writeTVar (qSecured s) (_qSecured d)
writeTVar (qDeleted s) (_qDeleted d)
writeTVar (msgSent s) (_msgSent d)
writeTVar (msgRecv s) (_msgRecv d)
setPeriodStats (activeQueues s) (_activeQueues d)
instance StrEncoding ServerStatsData where
strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues} =
B.unlines
[ "fromTime=" <> strEncode _fromTime,
"qCreated=" <> strEncode _qCreated,
"qSecured=" <> strEncode _qSecured,
"qDeleted=" <> strEncode _qDeleted,
"msgSent=" <> strEncode _msgSent,
"msgRecv=" <> strEncode _msgRecv,
"activeQueues:",
strEncode _activeQueues
]
strP = do
_fromTime <- "fromTime=" *> strP <* A.endOfLine
_qCreated <- "qCreated=" *> strP <* A.endOfLine
_qSecured <- "qSecured=" *> strP <* A.endOfLine
_qDeleted <- "qDeleted=" *> strP <* A.endOfLine
_msgSent <- "msgSent=" *> strP <* A.endOfLine
_msgRecv <- "msgRecv=" *> strP <* A.endOfLine
r <- optional ("activeQueues:" <* A.endOfLine)
_activeQueues <- case r of
Just _ -> strP <* optional A.endOfLine
_ -> do
_day <- "dayMsgQueues=" *> strP <* A.endOfLine
_week <- "weekMsgQueues=" *> strP <* A.endOfLine
_month <- "monthMsgQueues=" *> strP <* optional A.endOfLine
pure PeriodStatsData {_day, _week, _month}
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues}
data PeriodStats a = PeriodStats
{ day :: TVar (Set a),
week :: TVar (Set a),
month :: TVar (Set a)
}
newPeriodStats :: STM (PeriodStats a)
newPeriodStats = do
day <- newTVar S.empty
week <- newTVar S.empty
month <- newTVar S.empty
pure PeriodStats {day, week, month}
data PeriodStatsData a = PeriodStatsData
{ _day :: Set a,
_week :: Set a,
_month :: Set a
}
getPeriodStatsData :: PeriodStats a -> STM (PeriodStatsData a)
getPeriodStatsData s = do
_day <- readTVar $ day s
_week <- readTVar $ week s
_month <- readTVar $ month s
pure PeriodStatsData {_day, _week, _month}
setPeriodStats :: PeriodStats a -> PeriodStatsData a -> STM ()
setPeriodStats s d = do
writeTVar (day s) (_day d)
writeTVar (week s) (_week d)
writeTVar (month s) (_month d)
instance (Ord a, StrEncoding a) => StrEncoding (PeriodStatsData a) where
strEncode PeriodStatsData {_day, _week, _month} =
"day=" <> strEncode _day <> "\nweek=" <> strEncode _week <> "\nmonth=" <> strEncode _month
strP = do
_day <- "day=" *> strP <* A.endOfLine
_week <- "week=" *> strP <* A.endOfLine
_month <- "month=" *> strP
pure PeriodStatsData {_day, _week, _month}
data PeriodStatCounts = PeriodStatCounts
{ dayCount :: String,
weekCount :: String,
monthCount :: String
}
periodStatCounts :: forall a. PeriodStats a -> UTCTime -> STM PeriodStatCounts
periodStatCounts ps ts = do
let d = utctDay ts
(_, wDay) = mondayStartWeek d
MonthDay _ mDay = d
dayCount <- periodCount 1 $ day ps
weekCount <- periodCount wDay $ week ps
monthCount <- periodCount mDay $ month ps
pure PeriodStatCounts {dayCount, weekCount, monthCount}
where
periodCount :: Int -> TVar (Set a) -> STM String
periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
periodCount _ _ = pure ""
updatePeriodStats :: Ord a => PeriodStats a -> a -> STM ()
updatePeriodStats stats pId = do
updatePeriod day
updatePeriod week
updatePeriod month
where
updatePeriod pSel = modifyTVar (pSel stats) (S.insert pId)
+11 -23
View File
@@ -13,12 +13,10 @@ module Simplex.Messaging.Server.StoreLog
openReadStoreLog,
storeLogFilePath,
closeStoreLog,
writeStoreLogRecord,
logCreateQueue,
logSecureQueue,
logAddNotifier,
logDeleteQueue,
logDeleteNotifier,
readWriteStoreLog,
)
where
@@ -36,7 +34,7 @@ import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..), QueueStatus (..))
import Simplex.Messaging.Server.QueueStore (QueueRec (..), QueueStatus (..))
import Simplex.Messaging.Transport (trimCR)
import System.Directory (doesFileExist)
import System.IO
@@ -50,9 +48,8 @@ data StoreLog (a :: IOMode) where
data StoreLogRecord
= CreateQueue QueueRec
| SecureQueue QueueId SndPublicVerifyKey
| AddNotifier QueueId NtfCreds
| AddNotifier QueueId NotifierId NtfPublicVerifyKey
| DeleteQueue QueueId
| DeleteNotifier QueueId
instance StrEncoding QueueRec where
strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier} =
@@ -65,7 +62,7 @@ instance StrEncoding QueueRec where
]
<> maybe "" notifierStr notifier
where
notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds
notifierStr (nId, nKey) = " nid=" <> strEncode nId <> " nk=" <> strEncode nKey
strP = do
recipientId <- "rid=" *> strP_
@@ -73,29 +70,24 @@ instance StrEncoding QueueRec where
rcvDhSecret <- "rdh=" *> strP_
senderId <- "sid=" *> strP_
senderKey <- "sk=" *> strP
notifier <- optional $ " notifier=" *> strP
notifier <- optional $ (,) <$> (" nid=" *> strP_) <*> ("nk=" *> strP)
pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier, status = QueueActive}
instance StrEncoding StoreLogRecord where
strEncode = \case
CreateQueue q -> strEncode (Str "CREATE", q)
SecureQueue rId sKey -> strEncode (Str "SECURE", rId, sKey)
AddNotifier rId ntfCreds -> strEncode (Str "NOTIFIER", rId, ntfCreds)
AddNotifier rId nId nKey -> strEncode (Str "NOTIFIER", rId, nId, nKey)
DeleteQueue rId -> strEncode (Str "DELETE", rId)
DeleteNotifier rId -> strEncode (Str "NDELETE", rId)
strP =
"CREATE " *> (CreateQueue <$> strP)
<|> "SECURE " *> (SecureQueue <$> strP_ <*> strP)
<|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP)
<|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP_ <*> strP)
<|> "DELETE " *> (DeleteQueue <$> strP)
<|> "NDELETE " *> (DeleteNotifier <$> strP)
openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode)
openWriteStoreLog f = do
h <- openFile f WriteMode
hSetBuffering h LineBuffering
pure $ WriteStoreLog f h
openWriteStoreLog f = WriteStoreLog f <$> openFile f WriteMode
openReadStoreLog :: FilePath -> IO (StoreLog 'ReadMode)
openReadStoreLog f = do
@@ -112,7 +104,7 @@ closeStoreLog = \case
WriteStoreLog _ h -> hClose h
ReadStoreLog _ h -> hClose h
writeStoreLogRecord :: StrEncoding r => StoreLog 'WriteMode -> r -> IO ()
writeStoreLogRecord :: StoreLog 'WriteMode -> StoreLogRecord -> IO ()
writeStoreLogRecord (WriteStoreLog _ h) r = do
B.hPutStrLn h $ strEncode r
hFlush h
@@ -123,15 +115,12 @@ logCreateQueue s = writeStoreLogRecord s . CreateQueue
logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicVerifyKey -> IO ()
logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NtfCreds -> IO ()
logAddNotifier s qId ntfCreds = writeStoreLogRecord s $ AddNotifier qId ntfCreds
logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NotifierId -> NtfPublicVerifyKey -> IO ()
logAddNotifier s qId nId nKey = writeStoreLogRecord s $ AddNotifier qId nId nKey
logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
logDeleteQueue s = writeStoreLogRecord s . DeleteQueue
logDeleteNotifier :: StoreLog 'WriteMode -> QueueId -> IO ()
logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
readWriteStoreLog :: StoreLog 'ReadMode -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode)
readWriteStoreLog s@(ReadStoreLog f _) = do
qs <- readQueues s
@@ -160,8 +149,7 @@ readQueues (ReadStoreLog _ h) = LB.hGetContents h >>= returnResult . procStoreLo
procLogRecord m = \case
CreateQueue q -> M.insert (recipientId q) q m
SecureQueue qId sKey -> M.adjust (\q -> q {senderKey = Just sKey}) qId m
AddNotifier qId ntfCreds -> M.adjust (\q -> q {notifier = Just ntfCreds}) qId m
AddNotifier qId nId nKey -> M.adjust (\q -> q {notifier = Just (nId, nKey)}) qId m
DeleteQueue qId -> M.delete qId m
DeleteNotifier qId -> M.adjust (\q -> q {notifier = Nothing}) qId m
printError :: LogParsingError -> IO ()
printError (e, s) = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
-82
View File
@@ -1,82 +0,0 @@
module Simplex.Messaging.TMap
( TMap,
empty,
singleton,
Simplex.Messaging.TMap.null,
Simplex.Messaging.TMap.lookup,
member,
insert,
delete,
lookupInsert,
lookupDelete,
adjust,
update,
alter,
alterF,
union,
)
where
import Control.Concurrent.STM
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
type TMap k a = TVar (Map k a)
empty :: STM (TMap k a)
empty = newTVar M.empty
{-# INLINE empty #-}
singleton :: k -> a -> STM (TMap k a)
singleton k v = newTVar $ M.singleton k v
{-# INLINE singleton #-}
null :: TMap k a -> STM Bool
null m = M.null <$> readTVar m
{-# INLINE null #-}
lookup :: Ord k => k -> TMap k a -> STM (Maybe a)
lookup k m = M.lookup k <$> readTVar m
{-# INLINE lookup #-}
member :: Ord k => k -> TMap k a -> STM Bool
member k m = M.member k <$> readTVar m
{-# INLINE member #-}
insert :: Ord k => k -> a -> TMap k a -> STM ()
insert k v m = modifyTVar' m $ M.insert k v
{-# INLINE insert #-}
delete :: Ord k => k -> TMap k a -> STM ()
delete k m = modifyTVar' m $ M.delete k
{-# INLINE delete #-}
lookupInsert :: Ord k => k -> a -> TMap k a -> STM (Maybe a)
lookupInsert k v m = stateTVar m $ \mv -> (M.lookup k mv, M.insert k v mv)
{-# INLINE lookupInsert #-}
lookupDelete :: Ord k => k -> TMap k a -> STM (Maybe a)
lookupDelete k m = stateTVar m $ \mv -> (M.lookup k mv, M.delete k mv)
{-# INLINE lookupDelete #-}
adjust :: Ord k => (a -> a) -> k -> TMap k a -> STM ()
adjust f k m = modifyTVar' m $ M.adjust f k
{-# INLINE adjust #-}
update :: Ord k => (a -> Maybe a) -> k -> TMap k a -> STM ()
update f k m = modifyTVar' m $ M.update f k
{-# INLINE update #-}
alter :: Ord k => (Maybe a -> Maybe a) -> k -> TMap k a -> STM ()
alter f k m = modifyTVar' m $ M.alter f k
{-# INLINE alter #-}
alterF :: Ord k => (Maybe a -> STM (Maybe a)) -> k -> TMap k a -> STM ()
alterF f k m = do
mv <- M.alterF f k =<< readTVar m
writeTVar m $! mv
{-# INLINE alterF #-}
union :: Ord k => Map k a -> TMap k a -> STM ()
union m' m = modifyTVar' m $ M.union m'
{-# INLINE union #-}
+38 -52
View File
@@ -26,7 +26,8 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
module Simplex.Messaging.Transport
( -- * SMP transport parameters
supportedSMPServerVRange,
smpBlockSize,
supportedSMPVersions,
simplexMQVersion,
-- * Transport connection class
@@ -37,7 +38,6 @@ module Simplex.Messaging.Transport
-- * TLS Transport
TLS (..),
SessionId,
connectTLS,
closeTLS,
supportedParameters,
@@ -46,15 +46,12 @@ module Simplex.Messaging.Transport
-- * SMP transport
THandle (..),
TransportError (..),
HandshakeError (..),
smpServerHandshake,
smpClientHandshake,
serverHandshake,
clientHandshake,
tPutBlock,
tGetBlock,
serializeTransportError,
transportErrorP,
sendHandshake,
getHandshake,
-- * Trim trailing CR
trimCR,
@@ -83,7 +80,7 @@ import qualified Network.TLS.Extra as TE
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Parsers (dropPrefix, parse, parseRead1, sumTypeJSON)
import Simplex.Messaging.Util (bshow, catchAll, catchAll_)
import Simplex.Messaging.Util (bshow)
import Simplex.Messaging.Version
import Test.QuickCheck (Arbitrary (..))
import UnliftIO.Exception (Exception)
@@ -95,11 +92,11 @@ import UnliftIO.STM
smpBlockSize :: Int
smpBlockSize = 16384
supportedSMPServerVRange :: VersionRange
supportedSMPServerVRange = mkVersionRange 1 4
supportedSMPVersions :: VersionRange
supportedSMPVersions = mkVersionRange 1 1
simplexMQVersion :: String
simplexMQVersion = "3.1.3"
simplexMQVersion = "1.0.3"
-- * Transport connection class
@@ -118,7 +115,7 @@ class Transport c where
getClientConnection :: T.Context -> IO c
-- | tls-unique channel binding per RFC5929
tlsUnique :: c -> SessionId
tlsUnique :: c -> ByteString
-- | Close connection
closeConnection :: c -> IO ()
@@ -157,7 +154,7 @@ connectTLS :: T.TLSParams p => p -> Socket -> IO T.Context
connectTLS params sock =
E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx -> do
T.handshake ctx
`catchAll` \e -> putStrLn ("exception: " <> show e) >> E.throwIO e
`E.catch` \(e :: E.SomeException) -> putStrLn ("exception: " <> show e) >> E.throwIO e
pure ctx
getTLS :: TransportPeer -> T.Context -> IO TLS
@@ -178,9 +175,8 @@ withTlsUnique peer cxt f =
closeTLS :: T.Context -> IO ()
closeTLS ctx =
T.bye ctx -- sometimes socket was closed before 'TLS.bye' so we catch the 'Broken pipe' error here
`E.finally` T.contextClose ctx
`catchAll_` pure ()
(T.bye ctx >> T.contextClose ctx) -- sometimes socket was closed before 'TLS.bye'
`E.catch` (\(_ :: E.SomeException) -> pure ()) -- so we catch the 'Broken pipe' error here
supportedParameters :: T.Supported
supportedParameters =
@@ -217,11 +213,10 @@ instance Transport TLS where
readChunks :: ByteString -> IO ByteString
readChunks b
| B.length b >= n = pure b
| otherwise =
T.recvData tlsContext >>= \case
-- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
"" -> ioe_EOF
s -> readChunks $ b <> s
| otherwise = readChunks . (b <>) =<< T.recvData tlsContext `E.catch` handleEOF
handleEOF = \case
T.Error_EOF -> E.throwIO TEBadBlock
e -> E.throwIO e
cPut :: TLS -> ByteString -> IO ()
cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
@@ -255,21 +250,14 @@ trimCR s = if B.last s == '\r' then B.init s else s
-- | The handle for SMP encrypted transport connection over Transport .
data THandle c = THandle
{ connection :: c,
sessionId :: SessionId,
blockSize :: Int,
-- | agreed server protocol version
thVersion :: Version,
-- | send multiple transmissions in a single block
-- based on protocol and protocol version
batch :: Bool
sessionId :: ByteString,
-- | agreed SMP server protocol version
smpVersion :: Version
}
-- | TLS-unique channel binding
type SessionId = ByteString
data ServerHandshake = ServerHandshake
{ smpVersionRange :: VersionRange,
sessionId :: SessionId
sessionId :: ByteString
}
data ClientHandshake = ClientHandshake
@@ -344,55 +332,53 @@ serializeTransportError = \case
-- | Pad and send block to SMP transport.
tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
tPutBlock THandle {connection = c, blockSize} block =
tPutBlock THandle {connection = c} block =
bimapM (const $ pure TELargeMsg) (cPut c) $
C.pad block blockSize
C.pad block smpBlockSize
-- | Receive block from SMP transport.
tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
tGetBlock THandle {connection = c, blockSize} =
cGet c blockSize >>= \case
tGetBlock THandle {connection = c} =
cGet c smpBlockSize >>= \case
"" -> ioe_EOF
msg -> pure . first (const TELargeMsg) $ C.unPad msg
-- | Server SMP transport handshake.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
smpServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
smpServerHandshake c kh smpVRange = do
let th@THandle {sessionId} = smpTHandle c
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange}
serverHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
serverHandshake c kh = do
let th@THandle {sessionId} = tHandle c
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = supportedSMPVersions}
getHandshake th >>= \case
ClientHandshake {smpVersion, keyHash}
| keyHash /= kh ->
throwE $ TEHandshake IDENTITY
| smpVersion `isCompatible` smpVRange -> do
pure $ smpThHandle th smpVersion
| smpVersion `isCompatible` supportedSMPVersions -> do
pure (th :: THandle c) {smpVersion}
| otherwise -> throwE $ TEHandshake VERSION
-- | Client SMP transport handshake.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
smpClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
smpClientHandshake c keyHash smpVRange = do
let th@THandle {sessionId} = smpTHandle c
clientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
clientHandshake c keyHash = do
let th@THandle {sessionId} = tHandle c
ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th
if sessionId /= sessId
then throwE TEBadSession
else case smpVersionRange `compatibleVersion` smpVRange of
else case smpVersionRange `compatibleVersion` supportedSMPVersions of
Just (Compatible smpVersion) -> do
sendHandshake th $ ClientHandshake {smpVersion, keyHash}
pure $ smpThHandle th smpVersion
pure (th :: THandle c) {smpVersion}
Nothing -> throwE $ TEHandshake VERSION
smpThHandle :: forall c. THandle c -> Version -> THandle c
smpThHandle th v = (th :: THandle c) {thVersion = v, batch = v >= 4}
sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
sendHandshake th = ExceptT . tPutBlock th . smpEncode
getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportError IO smp
getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th
smpTHandle :: Transport c => c -> THandle c
smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False}
tHandle :: Transport c => c -> THandle c
tHandle c =
THandle {connection = c, sessionId = tlsUnique c, smpVersion = 0}
+16 -74
View File
@@ -2,60 +2,37 @@
module Simplex.Messaging.Transport.Client
( runTransportClient,
runTLSTransportClient,
smpClientHandshake,
defaultSMPPort,
defaultSocksProxy,
SocksProxy,
clientHandshake,
)
where
import Control.Applicative (optional)
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Default (def)
import Data.Maybe (fromMaybe)
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as XS
import Data.X509.Validation (Fingerprint (..))
import qualified Data.X509.Validation as XV
import GHC.IO.Exception (IOErrorType (..))
import Network.Socket
import Network.Socks5
import qualified Network.TLS as T
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.KeepAlive
import System.IO.Error
import Text.Read (readMaybe)
import UnliftIO.Exception (IOException)
import qualified UnliftIO.Exception as E
-- | Connect to passed TCP host:port and pass handle to the client.
runTransportClient :: (Transport c, MonadUnliftIO m) => Maybe SocksProxy -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
runTransportClient = runTLSTransportClient supportedParameters Nothing
runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> Maybe SocksProxy -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
runTLSTransportClient tlsParams caStore_ socksProxy_ host port keyHash keepAliveOpts client = do
let clientParams = mkTLSClientParams tlsParams caStore_ host port keyHash
connectTCP = maybe connectTCPClient connectSocksClient socksProxy_
c <- liftIO $ connectTLSClient connectTCP host port clientParams keepAliveOpts
runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> C.KeyHash -> (c -> m a) -> m a
runTransportClient host port keyHash client = do
let clientParams = mkTLSClientParams host port keyHash
c <- liftIO $ startTCPClient host port clientParams
client c `E.finally` liftIO (closeConnection c)
connectTLSClient :: forall c. Transport c => (HostName -> ServiceName -> IO Socket) -> HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
connectTLSClient tcpClient host port clientParams keepAliveOpts = do
sock <- tcpClient host port
mapM_ (setSocketKeepAlive sock) keepAliveOpts
ctx <- connectTLS clientParams sock
getClientConnection ctx
connectTCPClient :: HostName -> ServiceName -> IO Socket
connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> IO c
startTCPClient host port clientParams = withSocketsDo $ resolve >>= tryOpen err
where
err :: IOException
err = mkIOError NoSuchThing "no address" Nothing Nothing
@@ -65,60 +42,25 @@ connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
let hints = defaultHints {addrSocketType = Stream}
in getAddrInfo (Just hints) (Just host) (Just port)
tryOpen :: IOException -> [AddrInfo] -> IO Socket
tryOpen :: IOException -> [AddrInfo] -> IO c
tryOpen e [] = E.throwIO e
tryOpen _ (addr : as) =
E.try (open addr) >>= either (`tryOpen` as) pure
open :: AddrInfo -> IO Socket
open :: AddrInfo -> IO c
open addr = do
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
connect sock $ addrAddress addr
pure sock
ctx <- connectTLS clientParams sock
getClientConnection ctx
defaultSMPPort :: PortNumber
defaultSMPPort = 5223
connectSocksClient :: SocksProxy -> HostName -> ServiceName -> IO Socket
connectSocksClient (SocksProxy addr) host _port = do
let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
fst <$> socksConnect (defaultSocksConf addr) (SocksAddress (SocksAddrDomainName $ B.pack host) port)
defaultSocksHost :: HostAddress
defaultSocksHost = tupleToHostAddress (127, 0, 0, 1)
defaultSocksProxy :: SocksProxy
defaultSocksProxy = SocksProxy $ SockAddrInet 9050 defaultSocksHost
newtype SocksProxy = SocksProxy SockAddr
deriving (Eq)
instance Show SocksProxy where show (SocksProxy addr) = show addr
instance StrEncoding SocksProxy where
strEncode = B.pack . show
strP = do
host <- maybe defaultSocksHost tupleToHostAddress <$> optional ipv4P
port <- fromMaybe 9050 <$> optional (A.char ':' *> (fromInteger <$> A.decimal))
pure . SocksProxy $ SockAddrInet port host
where
ipv4P = (,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal
ipNum = A.decimal <* A.char '.'
instance ToJSON SocksProxy where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromJSON SocksProxy where
parseJSON = strParseJSON "SocksProxy"
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
mkTLSClientParams supported caStore_ host port keyHash_ = do
mkTLSClientParams :: HostName -> ServiceName -> C.KeyHash -> T.ClientParams
mkTLSClientParams host port keyHash = do
let p = B.pack port
(T.defaultParamsClient host p)
{ T.clientShared = maybe def (\caStore -> def {T.sharedCAStore = caStore}) caStore_,
T.clientHooks = maybe def (\keyHash -> def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p}) keyHash_,
T.clientSupported = supported
{ T.clientShared = def,
T.clientHooks = def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p},
T.clientSupported = supportedParameters
}
validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
-36
View File
@@ -1,36 +0,0 @@
module Simplex.Messaging.Transport.HTTP2 where
import qualified Control.Exception as E
import Data.Default (def)
import Foreign (mallocBytes)
import Network.HPACK (BufferSize)
import Network.HTTP2.Client (Config (..), defaultPositionReadMaker, freeSimpleConfig)
import qualified Network.TLS as T
import qualified Network.TLS.Extra as TE
import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut))
import qualified System.TimeManager as TI
withTlsConfig :: TLS -> BufferSize -> (Config -> IO ()) -> IO ()
withTlsConfig c sz = E.bracket (allocTlsConfig c sz) freeSimpleConfig
allocTlsConfig :: TLS -> BufferSize -> IO Config
allocTlsConfig c sz = do
buf <- mallocBytes sz
tm <- TI.initialize $ 30 * 1000000
pure
Config
{ confWriteBuffer = buf,
confBufferSize = sz,
confSendAll = cPut c,
confReadN = cGet c,
confPositionReadMaker = defaultPositionReadMaker,
confTimeoutManager = tm
}
http2TLSParams :: T.Supported
http2TLSParams =
def
{ T.supportedVersions = [T.TLS13, T.TLS12],
T.supportedCiphers = TE.ciphersuite_strong_det,
T.supportedSecureRenegotiation = False
}
@@ -1,128 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Transport.HTTP2.Client where
import Control.Concurrent.Async
import Control.Exception (IOException)
import qualified Control.Exception as E
import Control.Monad.Except
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Maybe (isNothing)
import qualified Data.X509.CertificateStore as XS
import Network.HPACK (HeaderTable)
import Network.HTTP2.Client (ClientConfig (..), Request, Response)
import qualified Network.HTTP2.Client as H
import Network.Socket (HostName, ServiceName)
import qualified Network.TLS as T
import Numeric.Natural (Natural)
import Simplex.Messaging.Transport.Client (runTLSTransportClient)
import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
import UnliftIO.STM
import UnliftIO.Timeout
data HTTP2Client = HTTP2Client
{ action :: Async (),
connected :: TVar Bool,
host :: HostName,
port :: ServiceName,
config :: HTTP2ClientConfig,
reqQ :: TBQueue (Request, TMVar HTTP2Response)
}
data HTTP2Response = HTTP2Response
{ response :: Response,
respBody :: ByteString,
respTrailers :: Maybe HeaderTable
}
data HTTP2ClientConfig = HTTP2ClientConfig
{ qSize :: Natural,
connTimeout :: Int,
tcpKeepAlive :: Maybe KeepAliveOpts,
caStoreFile :: FilePath,
suportedTLSParams :: T.Supported
}
deriving (Show)
defaultHTTP2ClientConfig :: HTTP2ClientConfig
defaultHTTP2ClientConfig =
HTTP2ClientConfig
{ qSize = 64,
connTimeout = 10000000,
tcpKeepAlive = Nothing,
caStoreFile = "/etc/ssl/cert.pem",
suportedTLSParams = http2TLSParams
}
data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCNetworkError1 | HCIOError IOException
deriving (Show)
getHTTP2Client :: HostName -> ServiceName -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, caStoreFile, suportedTLSParams} disconnected =
(atomically mkHTTPS2Client >>= runClient)
`E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
where
mkHTTPS2Client :: STM HTTP2Client
mkHTTPS2Client = do
connected <- newTVar False
reqQ <- newTBQueue $ qSize config
pure HTTP2Client {action = undefined, connected, host, port, config, reqQ}
runClient :: HTTP2Client -> IO (Either HTTP2ClientError HTTP2Client)
runClient c = do
cVar <- newEmptyTMVarIO
caStore <- XS.readCertificateStore caStoreFile
when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile
action <-
async $
runHTTP2Client suportedTLSParams caStore host port tcpKeepAlive (client c cVar)
`E.finally` atomically (putTMVar cVar $ Left HCNetworkError)
conn_ <- connTimeout `timeout` atomically (takeTMVar cVar)
pure $ case conn_ of
Just (Right ()) -> Right c {action}
Just (Left e) -> Left e
Nothing -> Left HCNetworkError1
client :: HTTP2Client -> TMVar (Either HTTP2ClientError ()) -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
client c cVar sendReq = do
atomically $ do
writeTVar (connected c) True
putTMVar cVar $ Right ()
process c sendReq `E.finally` disconnected
process :: HTTP2Client -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
process HTTP2Client {reqQ} sendReq = forever $ do
(req, respVar) <- atomically $ readTBQueue reqQ
sendReq req $ \r -> do
let writeResp respBody respTrailers = atomically $ putTMVar respVar HTTP2Response {response = r, respBody, respTrailers}
respBody <- getResponseBody r ""
respTrailers <- H.getResponseTrailers r
writeResp respBody respTrailers
getResponseBody :: Response -> ByteString -> IO ByteString
getResponseBody r s =
H.getResponseBodyChunk r >>= \chunk ->
if B.null chunk then pure s else getResponseBody r $ s <> chunk
-- | Disconnects client from the server and terminates client threads.
closeHTTP2Client :: HTTP2Client -> IO ()
-- TODO disconnect
closeHTTP2Client = uninterruptibleCancel . action
sendRequest :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response)
sendRequest HTTP2Client {reqQ, config} req = do
resp <- newEmptyTMVarIO
atomically $ writeTBQueue reqQ (req, resp)
maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))
runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
runHTTP2Client tlsParams caStore host port keepAliveOpts client =
runTLSTransportClient tlsParams caStore Nothing host port Nothing keepAliveOpts $ \c ->
withTlsConfig c 16384 (`run` client)
where
run = H.run $ ClientConfig "https" (B.pack host) 20
@@ -1,70 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Transport.HTTP2.Server where
import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
import Control.Concurrent.STM
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Network.HPACK (HeaderTable)
import Network.HTTP2.Server (Aux, PushPromise, Request, Response)
import qualified Network.HTTP2.Server as H
import Network.Socket
import qualified Network.TLS as T
import Numeric.Natural (Natural)
import Simplex.Messaging.Transport.HTTP2 (withTlsConfig)
import Simplex.Messaging.Transport.Server (loadSupportedTLSServerParams, runTransportServer)
type HTTP2ServerFunc = (Request -> (Response -> IO ()) -> IO ())
data HTTP2ServerConfig = HTTP2ServerConfig
{ qSize :: Natural,
http2Port :: ServiceName,
serverSupported :: T.Supported,
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath
}
deriving (Show)
data HTTP2Request = HTTP2Request
{ request :: Request,
reqBody :: ByteString,
reqTrailers :: Maybe HeaderTable,
sendResponse :: Response -> IO ()
}
data HTTP2Server = HTTP2Server
{ action :: Async (),
reqQ :: TBQueue HTTP2Request
}
getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertificateFile, certificateFile, privateKeyFile} = do
tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
started <- newEmptyTMVarIO
reqQ <- newTBQueueIO qSize
action <- async $
runHTTP2Server started http2Port tlsServerParams $ \r sendResponse -> do
reqBody <- getRequestBody r ""
reqTrailers <- H.getRequestTrailers r
atomically $ writeTBQueue reqQ HTTP2Request {request = r, reqBody, reqTrailers, sendResponse}
void . atomically $ takeTMVar started
pure HTTP2Server {action, reqQ}
where
getRequestBody :: Request -> ByteString -> IO ByteString
getRequestBody r s =
H.getRequestBodyChunk r >>= \chunk ->
if B.null chunk then pure s else getRequestBody r $ s <> chunk
closeHTTP2Server :: HTTP2Server -> IO ()
closeHTTP2Server = uninterruptibleCancel . action
runHTTP2Server :: TMVar Bool -> ServiceName -> T.ServerParams -> HTTP2ServerFunc -> IO ()
runHTTP2Server started port serverParams http2Server =
runTransportServer started port serverParams $ \c -> withTlsConfig c 16384 (`H.run` server)
where
server :: Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()
server req _aux sendResp = http2Server req (`sendResp` [])
@@ -1,63 +0,0 @@
{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Messaging.Transport.KeepAlive where
import Foreign.C (CInt (..))
import Network.Socket
data KeepAliveOpts = KeepAliveOpts
{ keepIdle :: Int,
keepIntvl :: Int,
keepCnt :: Int
}
deriving (Show)
defaultKeepAliveOpts :: KeepAliveOpts
defaultKeepAliveOpts =
KeepAliveOpts
{ keepIdle = 30,
keepIntvl = 15,
keepCnt = 4
}
_SOL_TCP :: CInt
_SOL_TCP = 6
#if defined(mingw32_HOST_OS)
-- Windows
-- The values are copied from windows::Win32::Networking::WinSock
-- https://microsoft.github.io/windows-docs-rs/doc/windows/Win32/Networking/WinSock/index.html
_TCP_KEEPIDLE :: CInt
_TCP_KEEPIDLE = 3
_TCP_KEEPINTVL :: CInt
_TCP_KEEPINTVL = 17
_TCP_KEEPCNT :: CInt
_TCP_KEEPCNT = 16
#else
-- Mac/Linux
#if defined(darwin_HOST_OS)
foreign import capi "netinet/tcp.h value TCP_KEEPALIVE" _TCP_KEEPIDLE :: CInt
#else
foreign import capi "netinet/tcp.h value TCP_KEEPIDLE" _TCP_KEEPIDLE :: CInt
#endif
foreign import capi "netinet/tcp.h value TCP_KEEPINTVL" _TCP_KEEPINTVL :: CInt
foreign import capi "netinet/tcp.h value TCP_KEEPCNT" _TCP_KEEPCNT :: CInt
#endif
setSocketKeepAlive :: Socket -> KeepAliveOpts -> IO ()
setSocketKeepAlive sock KeepAliveOpts {keepCnt, keepIdle, keepIntvl} = do
setSocketOption sock KeepAlive 1
setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPIDLE) keepIdle
setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPINTVL) keepIntvl
setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPCNT) keepCnt
+25 -38
View File
@@ -4,30 +4,25 @@
module Simplex.Messaging.Transport.Server
( runTransportServer,
runTCPServer,
loadSupportedTLSServerParams,
loadTLSServerParams,
loadFingerprint,
smpServerHandshake,
serverHandshake,
)
where
import Control.Concurrent.STM (stateTVar)
import Control.Monad.Except
import Control.Monad.IO.Unlift
import qualified Crypto.Store.X509 as SX
import Data.Default (def)
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.X509 as X
import Data.X509.Validation (Fingerprint (..))
import qualified Data.X509.Validation as XV
import Network.Socket
import qualified Network.TLS as T
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (catchAll_)
import System.Exit (exitFailure)
import System.Mem.Weak (Weak, deRefWeak)
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM
@@ -38,32 +33,27 @@ import UnliftIO.STM
runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> (c -> m ()) -> m ()
runTransportServer started port serverParams server = do
u <- askUnliftIO
liftIO . runTCPServer started port $ \conn ->
liftIO $ do
clients <- newTVarIO S.empty
E.bracket
(connectTLS serverParams conn >>= getServerConnection)
closeConnection
(unliftIO u . server)
-- | Run TCP server without TLS
runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
runTCPServer started port server = do
clients <- atomically TM.empty
clientId <- newTVarIO 0
E.bracket
(startTCPServer started port)
(closeServer started clients)
$ \sock -> forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
-- catchAll_ is needed here in case the connection was closed earlier
cId <- atomically $ stateTVar clientId $ \cId -> let cId' = cId + 1 in (cId', cId')
let closeConn _ = atomically (TM.delete cId clients) >> gracefulClose conn 5000 `catchAll_` pure ()
tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
atomically $ TM.insert cId tId clients
closeServer :: TMVar Bool -> TMap Int (Weak ThreadId) -> Socket -> IO ()
closeServer started clients sock = do
readTVarIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread)
close sock
void . atomically $ tryPutTMVar started False
(startTCPServer started port)
(closeServer clients)
$ \sock -> forever $ do
(connSock, _) <- accept sock
tid <- forkIO $ connectClient u connSock `E.catch` \(_ :: E.SomeException) -> pure ()
atomically . modifyTVar clients $ S.insert tid
where
connectClient :: UnliftIO m -> Socket -> IO ()
connectClient u connSock =
E.bracket
(connectTLS serverParams connSock >>= getServerConnection)
closeConnection
(unliftIO u . server)
closeServer :: TVar (Set ThreadId) -> Socket -> IO ()
closeServer clients sock = do
readTVarIO clients >>= mapM_ killThread
close sock
void . atomically $ tryPutTMVar started False
startTCPServer :: TMVar Bool -> ServiceName -> IO Socket
startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
@@ -81,10 +71,7 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
setStarted sock = atomically (tryPutTMVar started True) >> pure sock
loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams
loadTLSServerParams = loadSupportedTLSServerParams supportedParameters
loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> IO T.ServerParams
loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile =
loadTLSServerParams caCertificateFile certificateFile privateKeyFile =
fromCredential <$> loadServerCredential
where
loadServerCredential :: IO T.Credential
@@ -98,7 +85,7 @@ loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile p
{ T.serverWantClientCert = False,
T.serverShared = def {T.sharedCredentials = T.Credentials [credential]},
T.serverHooks = def,
T.serverSupported = serverSupported
T.serverSupported = supportedParameters
}
loadFingerprint :: FilePath -> IO Fingerprint
-32
View File
@@ -1,18 +1,13 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Util where
import qualified Control.Exception as E
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Except
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Text (Text)
import qualified Data.Text as T
import UnliftIO.Async
raceAny_ :: MonadUnliftIO m => [m a] -> m ()
@@ -35,10 +30,6 @@ bshow :: Show a => a -> ByteString
bshow = B.pack . show
{-# INLINE bshow #-}
tshow :: Show a => a -> Text
tshow = T.pack . show
{-# INLINE tshow #-}
maybeWord :: (a -> ByteString) -> Maybe a -> ByteString
maybeWord f = maybe "" $ B.cons ' ' . f
{-# INLINE maybeWord #-}
@@ -63,33 +54,10 @@ tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a)
tryE m = (Right <$> m) `catchE` (pure . Left)
{-# INLINE tryE #-}
liftE :: (e -> e') -> ExceptT e IO a -> ExceptT e' IO a
liftE f a = ExceptT $ first f <$> runExceptT a
{-# INLINE liftE #-}
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM ba t f = ba >>= \b -> if b then t else f
{-# INLINE ifM #-}
whenM :: Monad m => m Bool -> m () -> m ()
whenM b a = ifM b a $ pure ()
{-# INLINE whenM #-}
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM b = ifM b $ pure ()
{-# INLINE unlessM #-}
($>>=) :: (Monad m, Monad f, Traversable f) => m (f a) -> (a -> m (f b)) -> m (f b)
f $>>= g = f >>= fmap join . mapM g
catchAll :: IO a -> (E.SomeException -> IO a) -> IO a
catchAll = E.catch
{-# INLINE catchAll #-}
catchAll_ :: IO a -> IO a -> IO a
catchAll_ a = catchAll a . const
{-# INLINE catchAll_ #-}
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe = either (const Nothing) Just
{-# INLINE eitherToMaybe #-}
+4 -4
View File
@@ -17,7 +17,7 @@
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-18.28
resolver: lts-18.21
# User packages to be built.
# Various formats can be used as shown in the example below.
@@ -36,10 +36,9 @@ packages:
#
extra-deps:
- cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881
- network-3.1.2.7@sha256:e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568,4888
- simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
- tls-1.6.0@sha256:7ae39373fd2de27fb80e90f76d22aeeb9a074a0ddd120cbd02c9c52f516a9e55,6987
# below dependencies are to update Aeson to 2.0.3
- tls-1.5.7@sha256:1cc30253a9696b65a9cafc0317fbf09f7dcea15e3a145ed6c9c0e28c632fa23a,6991
# below dependancies are to update Aeson to 2.0.3
- OneTuple-0.3.1@sha256:a848c096c9d29e82ffdd30a9998aa2931cbccb3a1bc137539d80f6174d31603e,2262
- attoparsec-0.14.4@sha256:79584bdada8b730cb5138fca8c35c76fbef75fc1d1e01e6b1d815a5ee9843191,5810
- hashable-1.4.0.2@sha256:0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55,5005
@@ -53,6 +52,7 @@ extra-deps:
# commit: f6cc753611f80af300401cfae63846e9d7c40d9e
# subdirs:
# - core
# Override default flag values for local packages and extra-deps
# flags: {}
+97 -104
View File
@@ -12,16 +12,14 @@ module AgentTests (agentTests) where
import AgentTests.ConnectionRequestTests
import AgentTests.DoubleRatchetTests (doubleRatchetTests)
import AgentTests.FunctionalAPITests (functionalAPITests)
import AgentTests.NotificationTests (notificationTests)
import AgentTests.SQLiteTests (storeTests)
import AgentTests.SchemaDump (schemaDumpTest)
import Control.Concurrent
import Control.Monad (forM_)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Network.HTTP.Types (urlEncode)
import SMPAgentClient
import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
import SMPClient (testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as A
import Simplex.Messaging.Encoding.String
@@ -37,9 +35,7 @@ agentTests (ATransport t) = do
describe "Connection request" connectionRequestTests
describe "Double ratchet tests" doubleRatchetTests
describe "Functional API" $ functionalAPITests (ATransport t)
describe "Notification tests" $ notificationTests (ATransport t)
describe "SQLite store" storeTests
describe "SQLite schema dump" schemaDumpTest
describe "SMP agent protocol syntax" $ syntaxTests t
describe "Establishing duplex connection" $ do
it "should connect via one server and one agent" $
@@ -119,38 +115,38 @@ h #:# err = tryGet `shouldReturn` ()
_ -> return ()
pattern Msg :: MsgBody -> ACommand 'Agent
pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} msgBody
testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
testDuplexConnection _ alice bob = do
("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW INV")
let cReq' = strEncode cReq
bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
("", "bob", Right (CONF confId _ "bob's connInfo")) <- (alice <#:)
("", "bob", Right (CONF confId "bob's connInfo")) <- (alice <#:)
alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
bob <# ("", "alice", INFO "alice's connInfo")
bob <# ("", "alice", CON)
alice <# ("", "bob", CON)
-- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
alice #: ("3", "bob", "SEND F :hello") #> ("3", "bob", MID 4)
alice <# ("", "bob", SENT 4)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)
alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", MID 5)
alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 5)
alice <# ("", "bob", SENT 5)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 6)
alice <# ("", "bob", SENT 6)
bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 6)
bob <# ("", "alice", SENT 6)
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)
bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", MID 7)
bob #: ("13", "alice", "ACK 6") #> ("13", "alice", OK)
bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 7)
bob <# ("", "alice", SENT 7)
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
alice #: ("3a", "bob", "ACK 7") #> ("3a", "bob", OK)
bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 8)
bob <# ("", "alice", SENT 8)
alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False
alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)
alice #: ("4a", "bob", "ACK 8") #> ("4a", "bob", OK)
alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", MID 8)
bob <# ("", "alice", MERR 8 (SMP AUTH))
bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 9)
bob <# ("", "alice", MERR 9 (SMP AUTH))
alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
alice #:# "nothing else should be delivered to alice"
@@ -159,31 +155,31 @@ testDuplexConnRandomIds _ alice bob = do
("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW INV")
let cReq' = strEncode cReq
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
("", bobConn', Right (CONF confId _ "bob's connInfo")) <- (alice <#:)
("", bobConn', Right (CONF confId "bob's connInfo")) <- (alice <#:)
bobConn' `shouldBe` bobConn
alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
bob <# ("", aliceConn, INFO "alice's connInfo")
bob <# ("", aliceConn, CON)
alice <# ("", bobConn, CON)
alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, MID 4)
alice <# ("", bobConn, SENT 4)
bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK)
alice #: ("3", bobConn, "SEND F :how are you?") #> ("3", bobConn, MID 5)
alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 5)
alice <# ("", bobConn, SENT 5)
bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
bob #: ("12", aliceConn, "ACK 5") #> ("12", aliceConn, OK)
alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 6)
alice <# ("", bobConn, SENT 6)
bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False
bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
bob #: ("14", aliceConn, "SEND F 9\nhello too") #> ("14", aliceConn, MID 6)
bob <# ("", aliceConn, SENT 6)
alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK)
bob #: ("15", aliceConn, "SEND F 9\nmessage 1") #> ("15", aliceConn, MID 7)
bob #: ("13", aliceConn, "ACK 6") #> ("13", aliceConn, OK)
bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 7)
bob <# ("", aliceConn, SENT 7)
alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
alice #: ("3a", bobConn, "ACK 7") #> ("3a", bobConn, OK)
bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 8)
bob <# ("", aliceConn, SENT 8)
alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> False
alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK)
alice #: ("4a", bobConn, "ACK 8") #> ("4a", bobConn, OK)
alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
bob #: ("17", aliceConn, "SEND F 9\nmessage 3") #> ("17", aliceConn, MID 8)
bob <# ("", aliceConn, MERR 8 (SMP AUTH))
bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 9)
bob <# ("", aliceConn, MERR 9 (SMP AUTH))
alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
alice #:# "nothing else should be delivered to alice"
@@ -193,30 +189,30 @@ testContactConnection _ alice bob tom = do
let cReq' = strEncode cReq
bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
("", "alice_contact", Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:)
("", "alice_contact", Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
alice #: ("2", "bob", "ACPT " <> aInvId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
("", "alice", Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:)
("", "alice", Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
alice <# ("", "bob", INFO "bob's connInfo 2")
alice <# ("", "bob", CON)
bob <# ("", "alice", CON)
alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", MID 4)
alice <# ("", "bob", SENT 4)
alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 5)
alice <# ("", "bob", SENT 5)
bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
("", "alice_contact", Right (REQ aInvId' _ "tom's connInfo")) <- (alice <#:)
("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)
alice #: ("4", "tom", "ACPT " <> aInvId' <> " 16\nalice's connInfo") #> ("4", "tom", OK)
("", "alice", Right (CONF tConfId _ "alice's connInfo")) <- (tom <#:)
("", "alice", Right (CONF tConfId "alice's connInfo")) <- (tom <#:)
tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
alice <# ("", "tom", INFO "tom's connInfo 2")
alice <# ("", "tom", CON)
tom <# ("", "alice", CON)
alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", MID 4)
alice <# ("", "tom", SENT 4)
alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 5)
alice <# ("", "tom", SENT 5)
tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False
tom #: ("23", "alice", "ACK 4") #> ("23", "alice", OK)
tom #: ("23", "alice", "ACK 5") #> ("23", "alice", OK)
testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
testContactConnRandomIds _ alice bob = do
@@ -224,11 +220,11 @@ testContactConnRandomIds _ alice bob = do
let cReq' = strEncode cReq
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
("", aliceContact', Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:)
("", aliceContact', Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
aliceContact' `shouldBe` aliceContact
("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> " 16\nalice's connInfo")
("", aliceConn', Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:)
("", aliceConn', Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
aliceConn' `shouldBe` aliceConn
bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
@@ -236,17 +232,17 @@ testContactConnRandomIds _ alice bob = do
alice <# ("", bobConn, CON)
bob <# ("", aliceConn, CON)
alice #: ("3", bobConn, "SEND F :hi") #> ("3", bobConn, MID 4)
alice <# ("", bobConn, SENT 4)
alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 5)
alice <# ("", bobConn, SENT 5)
bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> False
bob #: ("13", aliceConn, "ACK 4") #> ("13", aliceConn, OK)
bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
testRejectContactRequest _ alice bob = do
("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW CON")
let cReq' = strEncode cReq
bob #: ("11", "alice", "JOIN " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)
("", "a_contact", Right (REQ aInvId _ "bob's info")) <- (alice <#:)
("", "a_contact", Right (REQ aInvId "bob's info")) <- (alice <#:)
-- RJCT must use correct contact connection
alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
@@ -256,20 +252,20 @@ testRejectContactRequest _ alice bob = do
testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
testSubscription _ alice1 alice2 bob = do
(alice1, "alice") `connect` (bob, "bob")
bob #: ("12", "alice", "SEND F 5\nhello") #> ("12", "alice", MID 4)
bob <# ("", "alice", SENT 4)
alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
alice1 #: ("1", "bob", "ACK 4") #> ("1", "bob", OK)
bob #: ("13", "alice", "SEND F 11\nhello again") #> ("13", "alice", MID 5)
bob #: ("12", "alice", "SEND 5\nhello") #> ("12", "alice", MID 5)
bob <# ("", "alice", SENT 5)
alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
alice1 #: ("1", "bob", "ACK 5") #> ("1", "bob", OK)
bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 6)
bob <# ("", "alice", SENT 6)
alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
alice1 #: ("2", "bob", "ACK 5") #> ("2", "bob", OK)
alice1 #: ("2", "bob", "ACK 6") #> ("2", "bob", OK)
alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
alice1 <# ("", "bob", END)
bob #: ("14", "alice", "SEND F 2\nhi") #> ("14", "alice", MID 6)
bob <# ("", "alice", SENT 6)
bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 7)
bob <# ("", "alice", SENT 7)
alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
alice2 #: ("22", "bob", "ACK 6") #> ("22", "bob", OK)
alice2 #: ("22", "bob", "ACK 7") #> ("22", "bob", OK)
alice1 #:# "nothing else should be delivered to alice1"
testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
@@ -277,7 +273,7 @@ testSubscrNotification t (server, _) client = do
client #: ("1", "conn1", "NEW INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
client #:# "nothing should be delivered to client before the server is killed"
killThread server
client <# ("", "", DOWN testSMPServer ["conn1"])
client <# ("", "conn1", DOWN)
withSmpServer (ATransport t) $
client <# ("", "conn1", ERR (SMP AUTH)) -- this new server does not have the queue
@@ -285,23 +281,22 @@ testMsgDeliveryServerRestart :: Transport c => TProxy c -> c -> c -> IO ()
testMsgDeliveryServerRestart t alice bob = do
withServer $ do
connect (alice, "alice") (bob, "bob")
bob #: ("1", "alice", "SEND F 2\nhi") #> ("1", "alice", MID 4)
bob <# ("", "alice", SENT 4)
bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 5)
bob <# ("", "alice", SENT 5)
alice <#= \case ("", "bob", Msg "hi") -> True; _ -> False
alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)
alice #: ("11", "bob", "ACK 5") #> ("11", "bob", OK)
alice #:# "nothing else delivered before the server is killed"
let server = (SMPServer "localhost" testPort2 testKeyHash)
alice <# ("", "", DOWN server ["bob"])
bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", MID 5)
alice <# ("", "bob", DOWN)
bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 6)
bob #:# "nothing else delivered before the server is restarted"
alice #:# "nothing else delivered before the server is restarted"
withServer $ do
bob <# ("", "alice", SENT 5)
alice <# ("", "", UP server ["bob"])
bob <# ("", "alice", SENT 6)
alice <# ("", "bob", UP)
alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
alice #: ("12", "bob", "ACK 6") #> ("12", "bob", OK)
removeFile testStoreLogFile
where
@@ -314,9 +309,9 @@ testServerConnectionAfterError t _ = do
withServer $ do
connect (bob, "bob") (alice, "alice")
bob <# ("", "", DOWN server ["alice"])
alice <# ("", "", DOWN server ["bob"])
alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
bob <# ("", "alice", DOWN)
alice <# ("", "bob", DOWN)
alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 5)
alice #:# "nothing else delivered before the server is restarted"
bob #:# "nothing else delivered before the server is restarted"
@@ -325,20 +320,19 @@ testServerConnectionAfterError t _ = do
bob #: ("1", "alice", "SUB") #> ("1", "alice", ERR (BROKER NETWORK))
alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER NETWORK))
withServer $ do
alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
bob <# ("", "", UP server ["alice"])
alice <#= \case ("", "bob", cmd) -> cmd == UP || cmd == SENT 5; _ -> False
alice <#= \case ("", "bob", cmd) -> cmd == UP || cmd == SENT 5; _ -> False
bob <# ("", "alice", UP)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5)
alice <# ("", "bob", SENT 5)
bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK)
alice #: ("1", "bob", "SEND 11\nhello again") #> ("1", "bob", MID 6)
alice <# ("", "bob", SENT 6)
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
removeFile testStoreLogFile
removeFile testDB
removeFile testDB2
where
server = SMPServer "localhost" testPort2 testKeyHash
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
withAgent1 = withAgent agentTestPort testDB
withAgent2 = withAgent agentTestPort2 testDB2
@@ -347,18 +341,17 @@ testServerConnectionAfterError t _ = do
testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
testMsgDeliveryAgentRestart t bob = do
let server = SMPServer "localhost" testPort2 testKeyHash
withAgent $ \alice -> do
withServer $ do
connect (bob, "bob") (alice, "alice")
alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
alice <# ("", "bob", SENT 4)
alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 5)
alice <# ("", "bob", SENT 5)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK)
bob #: ("11", "alice", "ACK 5") #> ("11", "alice", OK)
bob #:# "nothing else delivered before the server is down"
bob <# ("", "", DOWN server ["alice"])
alice #: ("2", "bob", "SEND F 11\nhello again") #> ("2", "bob", MID 5)
bob <# ("", "alice", DOWN)
alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 6)
alice #:# "nothing else delivered before the server is restarted"
bob #:# "nothing else delivered before the server is restarted"
@@ -368,11 +361,11 @@ testMsgDeliveryAgentRestart t bob = do
alice <#= \case
(corrId, "bob", cmd) ->
(corrId == "3" && cmd == OK)
|| (corrId == "" && cmd == SENT 5)
|| (corrId == "" && cmd == SENT 6)
_ -> False
bob <# ("", "", UP server ["alice"])
bob <# ("", "alice", UP)
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
bob #: ("12", "alice", "ACK 6") #> ("12", "alice", OK)
removeFile testStoreLogFile
removeFile testDB
@@ -387,7 +380,7 @@ testConcurrentMsgDelivery _ alice bob = do
("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW INV")
let cReq' = strEncode cReq
bob #: ("11", "alice2", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK)
("", "bob2", Right (CONF _confId _ "bob's connInfo")) <- (alice <#:)
("", "bob2", Right (CONF _confId "bob's connInfo")) <- (alice <#:)
-- below commands would be needed to accept bob's connection, but alice does not
-- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
-- bob <# ("", "alice", INFO "alice's connInfo")
@@ -396,15 +389,15 @@ testConcurrentMsgDelivery _ alice bob = do
-- the first connection should not be blocked by the second one
sendMessage (alice, "alice") (bob, "bob") "hello"
-- alice #: ("2", "bob", "SEND F :hello") #> ("2", "bob", MID 1)
-- alice #: ("2", "bob", "SEND :hello") #> ("2", "bob", MID 1)
-- alice <# ("", "bob", SENT 1)
-- bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-- bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 5)
bob <# ("", "alice", SENT 5)
bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 6)
bob <# ("", "alice", SENT 6)
-- if delivery is blocked it won't go further
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
alice #: ("3", "bob", "ACK 5") #> ("3", "bob", OK)
alice #: ("3", "bob", "ACK 6") #> ("3", "bob", OK)
testMsgDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
testMsgDeliveryQuotaExceeded _ alice bob = do
@@ -413,20 +406,20 @@ testMsgDeliveryQuotaExceeded _ alice bob = do
forM_ [1 .. 4 :: Int] $ \i -> do
let corrId = bshow i
msg = "message " <> bshow i
(_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND F :" <> msg)
(_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND :" <> msg)
alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
(_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND F :over quota")
(_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND :over quota")
alice #: ("1", "bob2", "SEND F :hello") #> ("1", "bob2", MID 4)
alice #: ("1", "bob2", "SEND :hello") #> ("1", "bob2", MID 5)
-- if delivery is blocked it won't go further
alice <# ("", "bob2", SENT 4)
alice <# ("", "bob2", SENT 5)
connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
connect (h1, name1) (h2, name2) = do
("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW INV")
let cReq' = strEncode cReq
h2 #: ("c2", name1, "JOIN " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
("", _, Right (CONF connId _ "info2")) <- (h1 <#:)
("", _, Right (CONF connId "info2")) <- (h1 <#:)
h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
h2 <# ("", name1, INFO "info1")
h2 <# ("", name1, CON)
@@ -434,10 +427,10 @@ connect (h1, name1) (h2, name2) = do
sendMessage :: Transport c => (c, ConnId) -> (c, ConnId) -> ByteString -> IO ()
sendMessage (h1, name1) (h2, name2) msg = do
("m1", name2', Right (MID mId)) <- h1 #: ("m1", name2, "SEND F :" <> msg)
("m1", name2', Right (MID mId)) <- h1 #: ("m1", name2, "SEND :" <> msg)
name2' `shouldBe` name2
h1 <#= \case ("", n, SENT m) -> n == name2 && m == mId; _ -> False
("", name1', Right (MSG MsgMeta {recipient = (msgId', _)} _ msg')) <- (h2 <#:)
("", name1', Right (MSG MsgMeta {recipient = (msgId', _)} msg')) <- (h2 <#:)
name1' `shouldBe` name1
msg' `shouldBe` msg
h2 #: ("m2", name1, "ACK " <> bshow msgId') =#> \case ("m2", n, OK) -> n == name1; _ -> False
@@ -447,7 +440,7 @@ sendMessage (h1, name1) (h2, name2) msg = do
-- ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW INV")
-- let cReq' = strEncode cReq
-- ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> cReq' <> " 5\ninfo2")
-- ("", _, Right (REQ connId _ "info2")) <- (h1 <#:)
-- ("", _, Right (REQ connId "info2")) <- (h1 <#:)
-- h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False
-- h2 <# ("", conn1, INFO "info1")
-- h2 <# ("", conn1, CON)
@@ -475,7 +468,7 @@ syntaxTests t = do
"a",
"JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
<> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
<> "%40localhost%3A5001%2F3456-w%3D%3D%23"
<> "%40127.0.0.1%3A5001%2F3456-w%3D%3D%23"
<> urlEncode True sampleDhKey
<> "&v=1"
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+9 -4
View File
@@ -11,7 +11,7 @@ import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtocolServer (..), smpClientVRange)
import Simplex.Messaging.Protocol (smpClientVRange)
import Simplex.Messaging.Version
import Test.Hspec
@@ -19,7 +19,12 @@ uri :: String
uri = "smp.simplex.im"
srv :: SMPServer
srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251")
srv =
SMPServer
{ host = "smp.simplex.im",
port = "5223",
keyHash = C.KeyHash "\215m\248\251"
}
queue :: SMPQueueUri
queue =
@@ -43,7 +48,7 @@ connReqData :: ConnReqUriData
connReqData =
ConnReqUriData
{ crScheme = simplexChat,
crAgentVRange = mkVersionRange 1 1,
crAgentVRange = smpAgentVRange,
crSmpQueues = [queue]
}
@@ -65,7 +70,7 @@ connectionRequest12 :: AConnectionRequestUri
connectionRequest12 =
ACR SCMInvitation $
CRInvitationUri
connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queue, queue]}
connReqData {crAgentVRange = mkVersionRange 1 2, crSmpQueues = [queue, queue]}
testE2ERatchetParams13
connectionRequestTests :: Spec
+59 -435
View File
@@ -1,44 +1,24 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module AgentTests.FunctionalAPITests
( functionalAPITests,
makeConnection,
get,
(##>),
(=##>),
pattern Msg,
)
where
module AgentTests.FunctionalAPITests (functionalAPITests) where
import Control.Concurrent (killThread, threadDelay)
import Control.Monad
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.IO.Unlift
import Data.Int (Int64)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import SMPAgentClient
import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Client (ProtocolClientConfig (..))
import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (ATransport (..))
import Simplex.Messaging.Version
import System.Timeout
import Test.Hspec
import UnliftIO
import UnliftIO.STM
(##>) :: MonadIO m => m (ATransmission 'Agent) -> ATransmission 'Agent -> m ()
a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t)
@@ -50,36 +30,13 @@ get :: MonadIO m => AgentClient -> m (ATransmission 'Agent)
get c = atomically (readTBQueue $ subQ c)
pattern Msg :: MsgBody -> ACommand 'Agent
pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
smpCfgV1 :: ProtocolClientConfig
smpCfgV1 = (smpCfg agentCfg) {smpServerVRange = mkVersionRange 1 1}
agentCfgV1 :: AgentConfig
agentCfgV1 = agentCfg {smpAgentVersion = 1, smpAgentVRange = mkVersionRange 1 1, smpCfg = smpCfgV1}
pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} msgBody
functionalAPITests :: ATransport -> Spec
functionalAPITests t = do
describe "Establishing duplex connection" $
it "should connect via one server using SMP agent clients" $
withSmpServer t testAgentClient
describe "Duplex connection between agent versions 1 and 2" $ do
it "should connect agent v1 to v1" $
withSmpServer t testAgentClientV1toV1
it "should connect agent v1 to v2" $
withSmpServer t testAgentClientV1toV2
it "should connect agent v2 to v1" $
withSmpServer t testAgentClientV2toV1
describe "Establish duplex connection via contact address" $
it "should connect via one server using SMP agent clients" $
withSmpServer t testAgentClientContact
describe "Duplex connection via contact address between agent versions 1 and 2" $ do
it "should connect agent v1 to v1" $
withSmpServer t testAgentClientContactV1toV1
it "should connect agent v1 to v2" $
withSmpServer t testAgentClientContactV1toV2
it "should connect agent v2 to v1" $
withSmpServer t testAgentClientContactV2toV1
describe "Establishing connection asynchronously" $ do
it "should connect with initiating client going offline" $
withSmpServer t testAsyncInitiatingOffline
@@ -91,166 +48,62 @@ functionalAPITests t = do
testAsyncServerOffline t
it "should notify after HELLO timeout" $
withSmpServer t testAsyncHelloTimeout
describe "Duplicate message delivery" $
it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $
testDuplicateMessage t
describe "Inactive client disconnection" $ do
it "should disconnect clients if it was inactive longer than TTL" $
testInactiveClientDisconnected t
it "should NOT disconnect active clients" $
testActiveClientNotDisconnected t
describe "Suspending agent" $ do
it "should update client when agent is suspended" $
withSmpServer t testSuspendingAgent
it "should complete sending messages when agent is suspended" $
testSuspendingAgentCompleteSending t
it "should suspend agent on timeout, even if pending messages not sent" $
testSuspendingAgentTimeout t
describe "Batching SMP commands" $ do
it "should subscribe to multiple subscriptions with batching" $
testBatchedSubscriptions t
testAgentClient :: IO ()
testAgentClient = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
runAgentClientTest alice bob 3
testAgentClientV1toV1 :: IO ()
testAgentClientV1toV1 = do
alice <- getSMPAgentClient agentCfgV1 initAgentServers
bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
runAgentClientTest alice bob 4
testAgentClientV1toV2 :: IO ()
testAgentClientV1toV2 = do
alice <- getSMPAgentClient agentCfgV1 initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
runAgentClientTest alice bob 4
testAgentClientV2toV1 :: IO ()
testAgentClientV2toV1 = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
runAgentClientTest alice bob 4
testAgentClientContact :: IO ()
testAgentClientContact = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
runAgentClientContactTest alice bob 3
testAgentClientContactV1toV1 :: IO ()
testAgentClientContactV1toV1 = do
alice <- getSMPAgentClient agentCfgV1 initAgentServers
bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
runAgentClientContactTest alice bob 4
testAgentClientContactV1toV2 :: IO ()
testAgentClientContactV1toV2 = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
runAgentClientContactTest alice bob 4
testAgentClientContactV2toV1 :: IO ()
testAgentClientContactV2toV1 = do
alice <- getSMPAgentClient agentCfgV1 initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
runAgentClientContactTest alice bob 4
runAgentClientTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
runAgentClientTest alice bob baseId = do
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
Right () <- runExceptT $ do
(bobId, qInfo) <- createConnection alice SCMInvitation
aliceId <- joinConnection bob qInfo "bob's connInfo"
("", _, CONF confId _ "bob's connInfo") <- get alice
("", _, CONF confId "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, INFO "alice's connInfo")
get bob ##> ("", aliceId, CON)
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
get alice ##> ("", bobId, SENT $ baseId + 1)
2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
get alice ##> ("", bobId, SENT $ baseId + 2)
-- message IDs 1 to 4 get assigned to control messages, so first MSG is assigned ID 5
5 <- sendMessage alice bobId "hello"
get alice ##> ("", bobId, SENT 5)
6 <- sendMessage alice bobId "how are you?"
get alice ##> ("", bobId, SENT 6)
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
ackMessage bob aliceId $ baseId + 1
ackMessage bob aliceId 5
get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
ackMessage bob aliceId $ baseId + 2
3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
get bob ##> ("", aliceId, SENT $ baseId + 3)
4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
get bob ##> ("", aliceId, SENT $ baseId + 4)
ackMessage bob aliceId 6
7 <- sendMessage bob aliceId "hello too"
get bob ##> ("", aliceId, SENT 7)
8 <- sendMessage bob aliceId "message 1"
get bob ##> ("", aliceId, SENT 8)
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 3
ackMessage alice bobId 7
get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 4
ackMessage alice bobId 8
suspendConnection alice bobId
5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
9 <- sendMessage bob aliceId "message 2"
get bob ##> ("", aliceId, MERR 9 (SMP AUTH))
deleteConnection alice bobId
liftIO $ noMessages alice "nothing else should be delivered to alice"
pure ()
where
msgId = subtract baseId
runAgentClientContactTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
runAgentClientContactTest alice bob baseId = do
Right () <- runExceptT $ do
(_, qInfo) <- createConnection alice SCMContact
aliceId <- joinConnection bob qInfo "bob's connInfo"
("", _, REQ invId _ "bob's connInfo") <- get alice
bobId <- acceptContact alice invId "alice's connInfo"
("", _, CONF confId _ "alice's connInfo") <- get bob
allowConnection bob aliceId confId "bob's connInfo"
get alice ##> ("", bobId, INFO "bob's connInfo")
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, CON)
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
get alice ##> ("", bobId, SENT $ baseId + 1)
2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
get alice ##> ("", bobId, SENT $ baseId + 2)
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
ackMessage bob aliceId $ baseId + 1
get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
ackMessage bob aliceId $ baseId + 2
3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
get bob ##> ("", aliceId, SENT $ baseId + 3)
4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
get bob ##> ("", aliceId, SENT $ baseId + 4)
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 3
get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 4
suspendConnection alice bobId
5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
deleteConnection alice bobId
liftIO $ noMessages alice "nothing else should be delivered to alice"
pure ()
where
msgId = subtract baseId
noMessages :: AgentClient -> String -> Expectation
noMessages c err = tryGet `shouldReturn` ()
where
tryGet =
10000 `timeout` get c >>= \case
Just _ -> error err
_ -> return ()
noMessages :: AgentClient -> String -> Expectation
noMessages c err = tryGet `shouldReturn` ()
where
tryGet =
10000 `timeout` get c >>= \case
Just _ -> error err
_ -> return ()
testAsyncInitiatingOffline :: IO ()
testAsyncInitiatingOffline = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
Right () <- runExceptT $ do
(bobId, cReq) <- createConnection alice SCMInvitation
disconnectAgentClient alice
aliceId <- joinConnection bob cReq "bob's connInfo"
alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
alice' <- liftIO $ getSMPAgentClient cfg
subscribeConnection alice' bobId
("", _, CONF confId _ "bob's connInfo") <- get alice'
("", _, CONF confId "bob's connInfo") <- get alice'
allowConnection alice' bobId confId "alice's connInfo"
get alice' ##> ("", bobId, CON)
get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -260,15 +113,15 @@ testAsyncInitiatingOffline = do
testAsyncJoiningOfflineBeforeActivation :: IO ()
testAsyncJoiningOfflineBeforeActivation = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
Right () <- runExceptT $ do
(bobId, qInfo) <- createConnection alice SCMInvitation
aliceId <- joinConnection bob qInfo "bob's connInfo"
disconnectAgentClient bob
("", _, CONF confId _ "bob's connInfo") <- get alice
("", _, CONF confId "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
bob' <- liftIO $ getSMPAgentClient cfg {dbFile = testDB2}
subscribeConnection bob' aliceId
get alice ##> ("", bobId, CON)
get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -278,18 +131,18 @@ testAsyncJoiningOfflineBeforeActivation = do
testAsyncBothOffline :: IO ()
testAsyncBothOffline = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
Right () <- runExceptT $ do
(bobId, cReq) <- createConnection alice SCMInvitation
disconnectAgentClient alice
aliceId <- joinConnection bob cReq "bob's connInfo"
disconnectAgentClient bob
alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
alice' <- liftIO $ getSMPAgentClient cfg
subscribeConnection alice' bobId
("", _, CONF confId _ "bob's connInfo") <- get alice'
("", _, CONF confId "bob's connInfo") <- get alice'
allowConnection alice' bobId confId "alice's connInfo"
bob' <- liftIO $ getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
bob' <- liftIO $ getSMPAgentClient cfg {dbFile = testDB2}
subscribeConnection bob' aliceId
get alice' ##> ("", bobId, CON)
get bob' ##> ("", aliceId, INFO "alice's connInfo")
@@ -299,24 +152,21 @@ testAsyncBothOffline = do
testAsyncServerOffline :: ATransport -> IO ()
testAsyncServerOffline t = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
-- create connection and shutdown the server
Right (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
runExceptT $ createConnection alice SCMInvitation
-- connection fails
Left (BROKER NETWORK) <- runExceptT $ joinConnection bob cReq "bob's connInfo"
("", "", DOWN srv conns) <- get alice
srv `shouldBe` testSMPServer
conns `shouldBe` [bobId]
("", bobId1, DOWN) <- get alice
bobId1 `shouldBe` bobId
-- connection succeeds after server start
Right () <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
("", "", UP srv1 conns1) <- get alice
liftIO $ do
srv1 `shouldBe` testSMPServer
conns1 `shouldBe` [bobId]
("", bobId2, UP) <- get alice
liftIO $ bobId2 `shouldBe` bobId
aliceId <- joinConnection bob cReq "bob's connInfo"
("", _, CONF confId _ "bob's connInfo") <- get alice
("", _, CONF confId "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -326,9 +176,8 @@ testAsyncServerOffline t = do
testAsyncHelloTimeout :: IO ()
testAsyncHelloTimeout = do
-- this test would only work if any of the agent is v1, there is no HELLO timeout in v2
alice <- getSMPAgentClient agentCfgV1 initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2, helloTimeout = 1} initAgentServers
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2, helloTimeout = 1}
Right () <- runExceptT $ do
(_, cReq) <- createConnection alice SCMInvitation
disconnectAgentClient alice
@@ -336,238 +185,13 @@ testAsyncHelloTimeout = do
get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
pure ()
testDuplicateMessage :: ATransport -> IO ()
testDuplicateMessage t = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
(aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do
Right (aliceId, bobId) <- runExceptT $ makeConnection alice bob
Right () <- runExceptT $ do
4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
get alice ##> ("", bobId, SENT 4)
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
disconnectAgentClient bob
-- if the agent user did not send ACK, the message will be delivered again
bob1 <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right () <- runExceptT $ do
subscribeConnection bob1 aliceId
get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
ackMessage bob1 aliceId 4
5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2"
get alice ##> ("", bobId, SENT 5)
get bob1 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False
pure (aliceId, bobId, bob1)
get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
get bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
-- commenting two lines below and uncommenting further two lines would also pass,
-- it is the scenario tested above, when the message was not acknowledged by the user
threadDelay 200000
Left (BROKER TIMEOUT) <- runExceptT $ ackMessage bob1 aliceId 5
disconnectAgentClient alice
disconnectAgentClient bob1
alice2 <- getSMPAgentClient agentCfg initAgentServers
bob2 <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
Right () <- runExceptT $ do
subscribeConnection bob2 aliceId
subscribeConnection alice2 bobId
-- get bob2 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False
-- ackMessage bob2 aliceId 5
-- message 2 is not delivered again, even though it was delivered to the agent
6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3"
get alice2 ##> ("", bobId, SENT 6)
get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
pure ()
makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
makeConnection alice bob = do
(bobId, qInfo) <- createConnection alice SCMInvitation
aliceId <- joinConnection bob qInfo "bob's connInfo"
("", _, CONF confId _ "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, INFO "alice's connInfo")
get bob ##> ("", aliceId, CON)
pure (aliceId, bobId)
testInactiveClientDisconnected :: ATransport -> IO ()
testInactiveClientDisconnected t = do
let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
withSmpServerConfigOn t cfg' testPort $ \_ -> do
alice <- getSMPAgentClient agentCfg initAgentServers
Right () <- runExceptT $ do
(connId, _cReq) <- createConnection alice SCMInvitation
get alice ##> ("", "", DOWN testSMPServer [connId])
pure ()
testActiveClientNotDisconnected :: ATransport -> IO ()
testActiveClientNotDisconnected t = do
let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
withSmpServerConfigOn t cfg' testPort $ \_ -> do
alice <- getSMPAgentClient agentCfg initAgentServers
ts <- getSystemTime
Right () <- runExceptT $ do
(connId, _cReq) <- createConnection alice SCMInvitation
keepSubscribing alice connId ts
pure ()
where
keepSubscribing :: AgentClient -> ConnId -> SystemTime -> ExceptT AgentErrorType IO ()
keepSubscribing alice connId ts = do
ts' <- liftIO $ getSystemTime
if milliseconds ts' - milliseconds ts < 2200
then do
-- keep sending SUB for 2.2 seconds
liftIO $ threadDelay 200000
subscribeConnection alice connId
keepSubscribing alice connId ts
else do
-- check that nothing is sent from agent
Nothing <- 800000 `timeout` get alice
liftIO $ threadDelay 1200000
-- and after 2 sec of inactivity DOWN is sent
get alice ##> ("", "", DOWN testSMPServer [connId])
milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000)
testSuspendingAgent :: IO ()
testSuspendingAgent = do
a <- getSMPAgentClient agentCfg initAgentServers
b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right () <- runExceptT $ do
(aId, bId) <- makeConnection a b
4 <- sendMessage a bId SMP.noMsgFlags "hello"
get a ##> ("", bId, SENT 4)
get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
ackMessage b aId 4
suspendAgent b 1000000
get b ##> ("", "", SUSPENDED)
5 <- sendMessage a bId SMP.noMsgFlags "hello 2"
get a ##> ("", bId, SENT 5)
Nothing <- 100000 `timeout` get b
activateAgent b
get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False
pure ()
testSuspendingAgentCompleteSending :: ATransport -> IO ()
testSuspendingAgentCompleteSending t = do
a <- getSMPAgentClient agentCfg initAgentServers
b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
(aId, bId) <- makeConnection a b
4 <- sendMessage a bId SMP.noMsgFlags "hello"
get a ##> ("", bId, SENT 4)
get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
ackMessage b aId 4
pure (aId, bId)
Right () <- runExceptT $ do
("", "", DOWN {}) <- get a
("", "", DOWN {}) <- get b
5 <- sendMessage b aId SMP.noMsgFlags "hello too"
6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
liftIO $ threadDelay 100000
suspendAgent b 5000000
Right () <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False
get b =##> \case ("", c, SENT 6) -> c == aId; ("", "", UP {}) -> True; _ -> False
("", "", SUSPENDED) <- get b
("", "", UP {}) <- get a
get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
ackMessage a bId 5
get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
ackMessage a bId 6
pure ()
testSuspendingAgentTimeout :: ATransport -> IO ()
testSuspendingAgentTimeout t = do
a <- getSMPAgentClient agentCfg initAgentServers
b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right (aId, _) <- withSmpServer t . runExceptT $ do
(aId, bId) <- makeConnection a b
4 <- sendMessage a bId SMP.noMsgFlags "hello"
get a ##> ("", bId, SENT 4)
get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
ackMessage b aId 4
pure (aId, bId)
Right () <- runExceptT $ do
("", "", DOWN {}) <- get a
("", "", DOWN {}) <- get b
5 <- sendMessage b aId SMP.noMsgFlags "hello too"
6 <- sendMessage b aId SMP.noMsgFlags "how are you?"
suspendAgent b 100000
("", "", SUSPENDED) <- get b
pure ()
pure ()
testBatchedSubscriptions :: ATransport -> IO ()
testBatchedSubscriptions t = do
a <- getSMPAgentClient agentCfg initAgentServers2
b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers2
Right conns <- runServers $ do
conns <- forM [1 .. 200 :: Int] . const $ makeConnection a b
forM_ conns $ \(aId, bId) -> exchangeGreetings a bId b aId
forM_ (take 10 conns) $ \(aId, bId) -> do
deleteConnection a bId
deleteConnection b aId
liftIO $ threadDelay 1000000
pure conns
("", "", DOWN {}) <- get a
("", "", DOWN {}) <- get a
("", "", DOWN {}) <- get b
("", "", DOWN {}) <- get b
Right () <- runServers $ do
("", "", UP {}) <- get a
("", "", UP {}) <- get a
("", "", UP {}) <- get b
("", "", UP {}) <- get b
liftIO $ threadDelay 1000000
subscribe a $ map snd conns
subscribe b $ map fst conns
forM_ (drop 10 conns) $ \(aId, bId) -> exchangeGreetingsMsgId 6 a bId b aId
pure ()
where
subscribe :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
subscribe c cs = do
r <- subscribeConnections c cs
liftIO $ do
let dc = S.fromList $ take 10 cs
all (== Right ()) (M.withoutKeys r dc) `shouldBe` True
all (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True
M.keys r `shouldMatchList` cs
runServers :: ExceptT AgentErrorType IO a -> IO (Either AgentErrorType a)
runServers a = do
withSmpServerStoreLogOn t testPort $ \t1 -> do
res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 -> do
res <- runExceptT a
killThread t2
pure res
killThread t1
pure res
exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
exchangeGreetings = exchangeGreetingsMsgId 4
exchangeGreetingsMsgId :: Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
exchangeGreetingsMsgId msgId alice bobId bob aliceId = do
msgId1 <- sendMessage alice bobId SMP.noMsgFlags "hello"
liftIO $ msgId1 `shouldBe` msgId
get alice ##> ("", bobId, SENT msgId)
exchangeGreetings alice bobId bob aliceId = do
5 <- sendMessage alice bobId "hello"
get alice ##> ("", bobId, SENT 5)
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
ackMessage bob aliceId msgId
msgId2 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
let msgId' = msgId + 1
liftIO $ msgId2 `shouldBe` msgId'
get bob ##> ("", aliceId, SENT msgId')
ackMessage bob aliceId 5
6 <- sendMessage bob aliceId "hello too"
get bob ##> ("", aliceId, SENT 6)
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
ackMessage alice bobId msgId'
ackMessage alice bobId 6
-514
View File
@@ -1,514 +0,0 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module AgentTests.NotificationTests where
-- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
import AgentTests.FunctionalAPITests (get, makeConnection, (##>), (=##>), pattern Msg)
import Control.Concurrent (killThread, threadDelay)
import Control.Monad.Except
import qualified Data.Aeson as J
import qualified Data.Aeson.Types as JT
import Data.Bifunctor (bimap, first)
import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Char8 (ByteString)
import Data.Text.Encoding (encodeUtf8)
import NtfClient
import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Types (NtfToken (..))
import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), SMPMsgMeta (..))
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Util (tryE)
import System.Directory (doesFileExist, removeFile)
import Test.Hspec
import UnliftIO
removeFileIfExists :: FilePath -> IO ()
removeFileIfExists filePath = do
fileExists <- doesFileExist filePath
when fileExists $ removeFile filePath
notificationTests :: ATransport -> Spec
notificationTests t =
after_ (removeFile testDB >> removeFileIfExists testDB2) $ do
describe "Managing notification tokens" $ do
it "should register and verify notification token" $
withAPNSMockServer $ \apns ->
withNtfServer t $ testNotificationToken apns
it "should allow repeated registration with the same credentials" $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServer t $ testNtfTokenRepeatRegistration apns
it "should allow the second registration with different credentials and delete the first after verification" $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServer t $ testNtfTokenSecondRegistration apns
it "should re-register token when notification server is restarted" $ \_ ->
withAPNSMockServer $ \apns ->
testNtfTokenServerRestart t apns
describe "Managing notification subscriptions" $ do
it "should create notification subscription for existing connection" $ \_ ->
withSmpServer t $
withAPNSMockServer $ \apns ->
withNtfServer t $ testNotificationSubscriptionExistingConnection apns
it "should create notification subscription for new connection" $ \_ ->
withSmpServer t $
withAPNSMockServer $ \apns ->
withNtfServer t $ testNotificationSubscriptionNewConnection apns
it "should change notifications mode" $ \_ ->
withSmpServer t $
withAPNSMockServer $ \apns ->
withNtfServer t $ testChangeNotificationsMode apns
it "should change token" $ \_ ->
withSmpServer t $
withAPNSMockServer $ \apns ->
withNtfServer t $ testChangeToken apns
describe "Notifications server store log" $
it "should save and restore tokens and subscriptions" $ \_ ->
withSmpServer t $
withAPNSMockServer $ \apns ->
testNotificationsStoreLog t apns
describe "Notifications after SMP server restart" $
it "should resume subscriptions after SMP server is restarted" $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServer t $ testNotificationsSMPRestart t apns
testNotificationToken :: APNSMockServer -> IO ()
testNotificationToken APNSMockServer {apnsQ} = do
a <- getSMPAgentClient agentCfg initAgentServers
Right () <- runExceptT $ do
let tkn = DeviceToken PPApnsTest "abcd"
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
verifyNtfToken a tkn nonce verification
NTActive <- checkNtfToken a tkn
deleteNtfToken a tkn
-- agent deleted this token
Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn
pure ()
pure ()
(.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
v .-> key = do
J.Object o <- pure v
liftEither . bimap INTERNAL (U.decodeLenient . encodeUtf8) $ JT.parseEither (J..: key) o
-- logCfg :: LogConfig
-- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
-- setLogLevel LogError -- LogDebug
-- withGlobalLogging logCfg $ do
a <- getSMPAgentClient agentCfg initAgentServers
Right () <- runExceptT $ do
let tkn = DeviceToken PPApnsTest "abcd"
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
atomically $ readTBQueue apnsQ
_ <- ntfData' .-> "verification"
_ <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
-- can still use the first verification code, it is the same after decryption
verifyNtfToken a tkn nonce verification
NTActive <- checkNtfToken a tkn
pure ()
pure ()
testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
-- setLogLevel LogError -- LogDebug
-- withGlobalLogging logCfg $ do
a <- getSMPAgentClient agentCfg initAgentServers
a' <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right () <- runExceptT $ do
let tkn = DeviceToken PPApnsTest "abcd"
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
verifyNtfToken a tkn nonce verification
NTRegistered <- registerNtfToken a' tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
atomically $ readTBQueue apnsQ
verification' <- ntfData' .-> "verification"
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
-- at this point the first token is still active
NTActive <- checkNtfToken a tkn
-- and the second is not yet verified
liftIO $ threadDelay 50000
NTConfirmed <- checkNtfToken a' tkn
-- now the second token registration is verified
verifyNtfToken a' tkn nonce' verification'
-- the first registration is removed
Left (NTF AUTH) <- tryE $ checkNtfToken a tkn
-- and the second is active
NTActive <- checkNtfToken a' tkn
pure ()
pure ()
testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
a <- getSMPAgentClient agentCfg initAgentServers
let tkn = DeviceToken PPApnsTest "abcd"
Right ntfData <- withNtfServer t . runExceptT $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
pure ntfData
-- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
threadDelay 1000000
disconnectAgentClient a
a' <- getSMPAgentClient agentCfg initAgentServers
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
-- so that repeat verification happens without restarting the clients, when notification arrives
Right () <- withNtfServer t . runExceptT $ do
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
atomically $ readTBQueue apnsQ
verification' <- ntfData' .-> "verification"
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
verifyNtfToken a' tkn nonce' verification'
NTActive <- checkNtfToken a' tkn
pure ()
pure ()
testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO ()
testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right (bobId, aliceId, nonce, message) <- runExceptT $ do
-- establish connection
(bobId, qInfo) <- createConnection alice SCMInvitation
aliceId <- joinConnection bob qInfo "bob's connInfo"
("", _, CONF confId _ "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get bob ##> ("", aliceId, INFO "alice's connInfo")
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, CON)
-- register notification token
let tkn = DeviceToken PPApnsTest "abcd"
NTRegistered <- registerNtfToken alice tkn NMInstant
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification <- ntfData .-> "verification"
vNonce <- C.cbNonce <$> ntfData .-> "nonce"
liftIO $ sendApnsResponse APNSRespOk
verifyNtfToken alice tkn vNonce verification
NTActive <- checkNtfToken alice tkn
-- send message
liftIO $ threadDelay 50000
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT $ baseId + 1)
-- notification
(nonce, message) <- messageNotification apnsQ
pure (bobId, aliceId, nonce, message)
-- alice client already has subscription for the connection
Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message
-- aliceNtf client doesn't have subscription and is allowed to get notification message
aliceNtf <- getSMPAgentClient agentCfg initAgentServers
Right () <- runExceptT $ do
(_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
pure ()
disconnectAgentClient aliceNtf
Right () <- runExceptT $ do
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 1
-- delete notification subscription
deleteNtfSub alice bobId
-- send message
2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT $ baseId + 2)
-- no notifications should follow
noNotification apnsQ
pure ()
where
baseId = 3
msgId = subtract baseId
testNotificationSubscriptionNewConnection :: APNSMockServer -> IO ()
testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right () <- runExceptT $ do
-- alice registers notification token
_ <- registerTestToken alice "abcd" NMInstant apnsQ
-- bob registers notification token
_ <- registerTestToken bob "bcde" NMInstant apnsQ
-- establish connection
liftIO $ threadDelay 50000
(bobId, qInfo) <- createConnection alice SCMInvitation
liftIO $ threadDelay 500000
aliceId <- joinConnection bob qInfo "bob's connInfo"
liftIO $ print 0
void $ messageNotification apnsQ
("", _, CONF confId _ "bob's connInfo") <- get alice
liftIO $ threadDelay 500000
allowConnection alice bobId confId "alice's connInfo"
liftIO $ print 1
void $ messageNotification apnsQ
get bob ##> ("", aliceId, INFO "alice's connInfo")
liftIO $ print 2
void $ messageNotification apnsQ
get alice ##> ("", bobId, CON)
liftIO $ print 3
void $ messageNotification apnsQ
get bob ##> ("", aliceId, CON)
-- bob sends message
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT $ baseId + 1)
liftIO $ print 4
void $ messageNotification apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 1
-- alice sends message
2 <- msgId <$> sendMessage alice bobId (SMP.MsgFlags True) "hey there"
get alice ##> ("", bobId, SENT $ baseId + 2)
liftIO $ print 5
void $ messageNotification apnsQ
get bob =##> \case ("", c, Msg "hey there") -> c == aliceId; _ -> False
ackMessage bob aliceId $ baseId + 2
-- no unexpected notifications should follow
noNotification apnsQ
pure ()
where
baseId = 3
msgId = subtract baseId
registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken
registerTestToken a token mode apnsQ = do
let tkn = DeviceToken PPApnsTest token
NTRegistered <- registerNtfToken a tkn mode
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
atomically $ readTBQueue apnsQ
verification' <- ntfData' .-> "verification"
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
verifyNtfToken a tkn nonce' verification'
NTActive <- checkNtfToken a tkn
pure tkn
testChangeNotificationsMode :: APNSMockServer -> IO ()
testChangeNotificationsMode APNSMockServer {apnsQ} = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right () <- runExceptT $ do
-- establish connection
(bobId, qInfo) <- createConnection alice SCMInvitation
aliceId <- joinConnection bob qInfo "bob's connInfo"
("", _, CONF confId _ "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get bob ##> ("", aliceId, INFO "alice's connInfo")
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, CON)
-- register notification token, set mode to NMInstant
tkn <- registerTestToken alice "abcd" NMInstant apnsQ
-- send message, receive notification
liftIO $ threadDelay 500000
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT $ baseId + 1)
void $ messageNotification apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 1
-- set mode to NMPeriodic
NTActive <- registerNtfToken alice tkn NMPeriodic
-- send message, no notification
liftIO $ threadDelay 500000
2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT $ baseId + 2)
noNotification apnsQ
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 2
-- set mode to NMInstant
NTActive <- registerNtfToken alice tkn NMInstant
-- send message, receive notification
liftIO $ threadDelay 500000
3 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
get bob ##> ("", aliceId, SENT $ baseId + 3)
void $ messageNotification apnsQ
get alice =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 3
-- turn off notifications
deleteNtfToken alice tkn
-- send message, no notification
liftIO $ threadDelay 500000
4 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "why hello there"
get bob ##> ("", aliceId, SENT $ baseId + 4)
noNotification apnsQ
get alice =##> \case ("", c, Msg "why hello there") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 4
-- turn on notifications, set mode to NMInstant
void $ registerTestToken alice "abcd" NMInstant apnsQ
-- send message, receive notification
liftIO $ threadDelay 500000
5 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hey"
get bob ##> ("", aliceId, SENT $ baseId + 5)
void $ messageNotification apnsQ
get alice =##> \case ("", c, Msg "hey") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 5
-- no notifications should follow
noNotification apnsQ
pure ()
where
baseId = 3
msgId = subtract baseId
testChangeToken :: APNSMockServer -> IO ()
testChangeToken APNSMockServer {apnsQ} = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right (aliceId, bobId) <- runExceptT $ do
-- establish connection
(bobId, qInfo) <- createConnection alice SCMInvitation
aliceId <- joinConnection bob qInfo "bob's connInfo"
("", _, CONF confId _ "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get bob ##> ("", aliceId, INFO "alice's connInfo")
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, CON)
-- register notification token, set mode to NMInstant
void $ registerTestToken alice "abcd" NMInstant apnsQ
-- send message, receive notification
liftIO $ threadDelay 500000
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT $ baseId + 1)
void $ messageNotification apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 1
pure (aliceId, bobId)
disconnectAgentClient alice
alice1 <- getSMPAgentClient agentCfg initAgentServers
Right () <- runExceptT $ do
subscribeConnection alice1 bobId
-- change notification token
void $ registerTestToken alice1 "bcde" NMInstant apnsQ
-- send message, receive notification
liftIO $ threadDelay 500000
2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
get bob ##> ("", aliceId, SENT $ baseId + 2)
void $ messageNotification apnsQ
get alice1 =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
ackMessage alice1 bobId $ baseId + 2
-- no notifications should follow
noNotification apnsQ
pure ()
where
baseId = 3
msgId = subtract baseId
testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
testNotificationsStoreLog t APNSMockServer {apnsQ} = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runExceptT $ do
(aliceId, bobId) <- makeConnection alice bob
_ <- registerTestToken alice "abcd" NMInstant apnsQ
liftIO $ threadDelay 250000
4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT 4)
void $ messageNotification apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId 4
liftIO $ killThread threadId
pure (aliceId, bobId)
liftIO $ threadDelay 250000
Right () <- withNtfServerStoreLog t $ \threadId -> runExceptT $ do
liftIO $ threadDelay 250000
5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT 5)
void $ messageNotification apnsQ
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
liftIO $ killThread threadId
pure ()
testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
Right (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runExceptT $ do
(aliceId, bobId) <- makeConnection alice bob
_ <- registerTestToken alice "abcd" NMInstant apnsQ
liftIO $ threadDelay 250000
4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT 4)
void $ messageNotification apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId 4
liftIO $ killThread threadId
pure (aliceId, bobId)
Right () <- runExceptT $ do
get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
get bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
Right () <- withSmpServerStoreLogOn t testPort $ \threadId -> runExceptT $ do
get alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
get bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
liftIO $ threadDelay 1000000
5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT 5)
_ <- messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
liftIO $ killThread threadId
pure ()
messageNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
messageNotification apnsQ = do
1000000 `timeout` atomically (readTBQueue apnsQ) >>= \case
Nothing -> error "no notification"
Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}, sendApnsResponse} -> do
nonce <- C.cbNonce <$> ntfData .-> "nonce"
message <- ntfData .-> "message"
liftIO $ sendApnsResponse APNSRespOk
pure (nonce, message)
_ -> error "bad notification"
messageNotificationData :: AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData
messageNotificationData c apnsQ = do
(nonce, message) <- messageNotification apnsQ
NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c
Right pnMsgData <- liftEither . first INTERNAL $ Right . strDecode =<< first show (C.cbDecrypt dhSecret nonce message)
pure pnMsgData
noNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO ()
noNotification apnsQ = do
500000 `timeout` atomically (readTBQueue apnsQ) >>= \case
Nothing -> pure ()
_ -> error "unexpected notification"
+170 -175
View File
@@ -11,6 +11,7 @@ module AgentTests.SQLiteTests (storeTests) where
import Control.Concurrent.Async (concurrently_)
import Control.Concurrent.STM
import Control.Monad (replicateM_)
import Control.Monad.Except (ExceptT, runExceptT)
import Crypto.Random (drgNew)
import Data.ByteString.Char8 (ByteString)
import qualified Data.Text as T
@@ -26,7 +27,6 @@ import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Protocol as SMP
import System.Random
import Test.Hspec
import UnliftIO.Directory (removeFile)
@@ -43,7 +43,7 @@ withStore2 = before connect2 . after (removeStore . fst)
connect2 :: IO (SQLiteStore, SQLiteStore)
connect2 = do
s1 <- createStore
s2 <- connectSQLiteStore (dbFilePath s1)
s2 <- connectSQLiteStore (dbFilePath s1) 4
pure (s1, s2)
createStore :: IO SQLiteStore
@@ -51,15 +51,21 @@ createStore = do
-- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
-- IO operations on multiple similarly named files; error seems to be environment specific
r <- randomIO :: IO Word32
createSQLiteStore (testDB <> show r) Migrations.app True
createSQLiteStore (testDB <> show r) 4 Migrations.app True
removeStore :: SQLiteStore -> IO ()
removeStore db = do
close db
removeFile $ dbFilePath db
removeStore store = do
close store
removeFile $ dbFilePath store
where
close :: SQLiteStore -> IO ()
close st = mapM_ DB.close =<< atomically (tryTakeTMVar $ dbConnection st)
close st = mapM_ DB.close =<< atomically (flushTBQueue $ dbConnPool st)
returnsResult :: (Eq a, Eq e, Show a, Show e) => ExceptT e IO a -> a -> Expectation
action `returnsResult` r = runExceptT action `shouldReturn` Right r
throwsError :: (Eq a, Eq e, Show a, Show e) => ExceptT e IO a -> e -> Expectation
action `throwsError` e = runExceptT action `shouldReturn` Left e
-- TODO add null port tests
storeTests :: Spec
@@ -67,10 +73,10 @@ storeTests = do
withStore2 $ do
describe "stress test" testConcurrentWrites
withStore $ do
describe "db setup" $ do
describe "store setup" $ do
testCompiledThreadsafe
testForeignKeysEnabled
describe "db methods" $ do
describe "store methods" $ do
describe "Queue and Connection management" $ do
describe "createRcvConn" $ do
testCreateRcvConn
@@ -105,29 +111,28 @@ testConcurrentWrites :: SpecWith (SQLiteStore, SQLiteStore)
testConcurrentWrites =
it "should complete multiple concurrent write transactions w/t sqlite busy errors" $ \(s1, s2) -> do
g <- newTVarIO =<< drgNew
_ <- withTransaction s1 $ \db ->
createRcvConn db g cData1 rcvQueue1 SCMInvitation
_ <- runExceptT $ createRcvConn s1 g cData1 rcvQueue1 SCMInvitation
let ConnData {connId} = cData1
concurrently_ (runTest s1 connId) (runTest s2 connId)
where
runTest :: SQLiteStore -> ConnId -> IO ()
runTest st connId = replicateM_ 100 . withTransaction st $ \db -> do
(internalId, internalRcvId, _, _) <- updateRcvIds db connId
runTest :: SQLiteStore -> ConnId -> IO (Either StoreError ())
runTest store connId = runExceptT . replicateM_ 100 $ do
(internalId, internalRcvId, _, _) <- updateRcvIds store connId
let rcvMsgData = mkRcvMsgData internalId internalRcvId 0 "0" "hash_dummy"
createRcvMsg db connId rcvMsgData
createRcvMsg store connId rcvMsgData
testCompiledThreadsafe :: SpecWith SQLiteStore
testCompiledThreadsafe =
it "compiled sqlite library should be threadsafe" . withStoreTransaction $ \db -> do
it "compiled sqlite library should be threadsafe" . withStoreConnection $ \db -> do
compileOptions <- DB.query_ db "pragma COMPILE_OPTIONS;" :: IO [[T.Text]]
compileOptions `shouldNotContain` [["THREADSAFE=0"]]
withStoreTransaction :: (DB.Connection -> IO a) -> SQLiteStore -> IO a
withStoreTransaction = flip withTransaction
withStoreConnection :: (DB.Connection -> IO a) -> SQLiteStore -> IO a
withStoreConnection = flip withConnection
testForeignKeysEnabled :: SpecWith SQLiteStore
testForeignKeysEnabled =
it "foreign keys should be enabled" . withStoreTransaction $ \db -> do
it "foreign keys should be enabled" . withStoreConnection $ \db -> do
let inconsistentQuery =
[sql|
INSERT INTO snd_queues
@@ -139,7 +144,7 @@ testForeignKeysEnabled =
`shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)
cData1 :: ConnData
cData1 = ConnData {connId = "conn1", connAgentVersion = 1, duplexHandshake = Nothing}
cData1 = ConnData {connId = "conn1"}
testPrivateSignKey :: C.APrivateSignKey
testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
@@ -160,8 +165,7 @@ rcvQueue1 =
e2ePrivKey = testPrivDhKey,
e2eDhSecret = Nothing,
sndId = Just "2345",
status = New,
clientNtfCreds = Nothing
status = New
}
sndQueue1 :: SndQueue
@@ -178,125 +182,125 @@ sndQueue1 =
testCreateRcvConn :: SpecWith SQLiteStore
testCreateRcvConn =
it "should create RcvConnection and add SndQueue" . withStoreTransaction $ \db -> do
it "should create RcvConnection and add SndQueue" $ \store -> do
g <- newTVarIO =<< drgNew
createRcvConn db g cData1 rcvQueue1 SCMInvitation
`shouldReturn` Right "conn1"
getConn db "conn1"
`shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
upgradeRcvConnToDuplex db "conn1" sndQueue1
`shouldReturn` Right ()
getConn db "conn1"
`shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
createRcvConn store g cData1 rcvQueue1 SCMInvitation
`returnsResult` "conn1"
getConn store "conn1"
`returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
upgradeRcvConnToDuplex store "conn1" sndQueue1
`returnsResult` ()
getConn store "conn1"
`returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
testCreateRcvConnRandomId :: SpecWith SQLiteStore
testCreateRcvConnRandomId =
it "should create RcvConnection and add SndQueue with random ID" . withStoreTransaction $ \db -> do
it "should create RcvConnection and add SndQueue with random ID" $ \store -> do
g <- newTVarIO =<< drgNew
Right connId <- createRcvConn db g cData1 {connId = ""} rcvQueue1 SCMInvitation
getConn db connId
`shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 {connId} rcvQueue1))
upgradeRcvConnToDuplex db connId sndQueue1
`shouldReturn` Right ()
getConn db connId
`shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1))
Right connId <- runExceptT $ createRcvConn store g cData1 {connId = ""} rcvQueue1 SCMInvitation
getConn store connId
`returnsResult` SomeConn SCRcv (RcvConnection cData1 {connId} rcvQueue1)
upgradeRcvConnToDuplex store connId sndQueue1
`returnsResult` ()
getConn store connId
`returnsResult` SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1)
testCreateRcvConnDuplicate :: SpecWith SQLiteStore
testCreateRcvConnDuplicate =
it "should throw error on attempt to create duplicate RcvConnection" . withStoreTransaction $ \db -> do
it "should throw error on attempt to create duplicate RcvConnection" $ \store -> do
g <- newTVarIO =<< drgNew
_ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
createRcvConn db g cData1 rcvQueue1 SCMInvitation
`shouldReturn` Left (SEConnDuplicate)
_ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
createRcvConn store g cData1 rcvQueue1 SCMInvitation
`throwsError` SEConnDuplicate
testCreateSndConn :: SpecWith SQLiteStore
testCreateSndConn =
it "should create SndConnection and add RcvQueue" . withStoreTransaction $ \db -> do
it "should create SndConnection and add RcvQueue" $ \store -> do
g <- newTVarIO =<< drgNew
createSndConn db g cData1 sndQueue1
`shouldReturn` Right "conn1"
getConn db "conn1"
`shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
upgradeSndConnToDuplex db "conn1" rcvQueue1
`shouldReturn` Right ()
getConn db "conn1"
`shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
createSndConn store g cData1 sndQueue1
`returnsResult` "conn1"
getConn store "conn1"
`returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1)
upgradeSndConnToDuplex store "conn1" rcvQueue1
`returnsResult` ()
getConn store "conn1"
`returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
testCreateSndConnRandomID :: SpecWith SQLiteStore
testCreateSndConnRandomID =
it "should create SndConnection and add RcvQueue with random ID" . withStoreTransaction $ \db -> do
it "should create SndConnection and add RcvQueue with random ID" $ \store -> do
g <- newTVarIO =<< drgNew
Right connId <- createSndConn db g cData1 {connId = ""} sndQueue1
getConn db connId
`shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 {connId} sndQueue1))
upgradeSndConnToDuplex db connId rcvQueue1
`shouldReturn` Right ()
getConn db connId
`shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1))
Right connId <- runExceptT $ createSndConn store g cData1 {connId = ""} sndQueue1
getConn store connId
`returnsResult` SomeConn SCSnd (SndConnection cData1 {connId} sndQueue1)
upgradeSndConnToDuplex store connId rcvQueue1
`returnsResult` ()
getConn store connId
`returnsResult` SomeConn SCDuplex (DuplexConnection cData1 {connId} rcvQueue1 sndQueue1)
testCreateSndConnDuplicate :: SpecWith SQLiteStore
testCreateSndConnDuplicate =
it "should throw error on attempt to create duplicate SndConnection" . withStoreTransaction $ \db -> do
it "should throw error on attempt to create duplicate SndConnection" $ \store -> do
g <- newTVarIO =<< drgNew
_ <- createSndConn db g cData1 sndQueue1
createSndConn db g cData1 sndQueue1
`shouldReturn` Left (SEConnDuplicate)
_ <- runExceptT $ createSndConn store g cData1 sndQueue1
createSndConn store g cData1 sndQueue1
`throwsError` SEConnDuplicate
testGetRcvConn :: SpecWith SQLiteStore
testGetRcvConn =
it "should get connection using rcv queue id and server" . withStoreTransaction $ \db -> do
it "should get connection using rcv queue id and server" $ \store -> do
let smpServer = SMPServer "smp.simplex.im" "5223" testKeyHash
let recipientId = "1234"
g <- newTVarIO =<< drgNew
_ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
getRcvConn db smpServer recipientId
`shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
_ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
getRcvConn store smpServer recipientId
`returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
testDeleteRcvConn :: SpecWith SQLiteStore
testDeleteRcvConn =
it "should create RcvConnection and delete it" . withStoreTransaction $ \db -> do
it "should create RcvConnection and delete it" $ \store -> do
g <- newTVarIO =<< drgNew
_ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
getConn db "conn1"
`shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
deleteConn db "conn1"
`shouldReturn` ()
_ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
getConn store "conn1"
`returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
deleteConn store "conn1"
`returnsResult` ()
-- TODO check queues are deleted as well
getConn db "conn1"
`shouldReturn` Left (SEConnNotFound)
getConn store "conn1"
`throwsError` SEConnNotFound
testDeleteSndConn :: SpecWith SQLiteStore
testDeleteSndConn =
it "should create SndConnection and delete it" . withStoreTransaction $ \db -> do
it "should create SndConnection and delete it" $ \store -> do
g <- newTVarIO =<< drgNew
_ <- createSndConn db g cData1 sndQueue1
getConn db "conn1"
`shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
deleteConn db "conn1"
`shouldReturn` ()
_ <- runExceptT $ createSndConn store g cData1 sndQueue1
getConn store "conn1"
`returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1)
deleteConn store "conn1"
`returnsResult` ()
-- TODO check queues are deleted as well
getConn db "conn1"
`shouldReturn` Left (SEConnNotFound)
getConn store "conn1"
`throwsError` SEConnNotFound
testDeleteDuplexConn :: SpecWith SQLiteStore
testDeleteDuplexConn =
it "should create DuplexConnection and delete it" . withStoreTransaction $ \db -> do
it "should create DuplexConnection and delete it" $ \store -> do
g <- newTVarIO =<< drgNew
_ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
_ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
getConn db "conn1"
`shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
deleteConn db "conn1"
`shouldReturn` ()
_ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
_ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
getConn store "conn1"
`returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
deleteConn store "conn1"
`returnsResult` ()
-- TODO check queues are deleted as well
getConn db "conn1"
`shouldReturn` Left (SEConnNotFound)
getConn store "conn1"
`throwsError` SEConnNotFound
testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore
testUpgradeRcvConnToDuplex =
it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" . withStoreTransaction $ \db -> do
it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" $ \store -> do
g <- newTVarIO =<< drgNew
_ <- createSndConn db g cData1 sndQueue1
_ <- runExceptT $ createSndConn store g cData1 sndQueue1
let anotherSndQueue =
SndQueue
{ server = SMPServer "smp.simplex.im" "5223" testKeyHash,
@@ -307,17 +311,17 @@ testUpgradeRcvConnToDuplex =
e2eDhSecret = testDhSecret,
status = New
}
upgradeRcvConnToDuplex db "conn1" anotherSndQueue
`shouldReturn` Left (SEBadConnType CSnd)
_ <- upgradeSndConnToDuplex db "conn1" rcvQueue1
upgradeRcvConnToDuplex db "conn1" anotherSndQueue
`shouldReturn` Left (SEBadConnType CDuplex)
upgradeRcvConnToDuplex store "conn1" anotherSndQueue
`throwsError` SEBadConnType CSnd
_ <- runExceptT $ upgradeSndConnToDuplex store "conn1" rcvQueue1
upgradeRcvConnToDuplex store "conn1" anotherSndQueue
`throwsError` SEBadConnType CDuplex
testUpgradeSndConnToDuplex :: SpecWith SQLiteStore
testUpgradeSndConnToDuplex =
it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" . withStoreTransaction $ \db -> do
it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" $ \store -> do
g <- newTVarIO =<< drgNew
_ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
_ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
let anotherRcvQueue =
RcvQueue
{ server = SMPServer "smp.simplex.im" "5223" testKeyHash,
@@ -327,55 +331,54 @@ testUpgradeSndConnToDuplex =
e2ePrivKey = testPrivDhKey,
e2eDhSecret = Nothing,
sndId = Just "4567",
status = New,
clientNtfCreds = Nothing
status = New
}
upgradeSndConnToDuplex db "conn1" anotherRcvQueue
`shouldReturn` Left (SEBadConnType CRcv)
_ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
upgradeSndConnToDuplex db "conn1" anotherRcvQueue
`shouldReturn` Left (SEBadConnType CDuplex)
upgradeSndConnToDuplex store "conn1" anotherRcvQueue
`throwsError` SEBadConnType CRcv
_ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
upgradeSndConnToDuplex store "conn1" anotherRcvQueue
`throwsError` SEBadConnType CDuplex
testSetRcvQueueStatus :: SpecWith SQLiteStore
testSetRcvQueueStatus =
it "should update status of RcvQueue" . withStoreTransaction $ \db -> do
it "should update status of RcvQueue" $ \store -> do
g <- newTVarIO =<< drgNew
_ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
getConn db "conn1"
`shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1))
setRcvQueueStatus db rcvQueue1 Confirmed
`shouldReturn` ()
getConn db "conn1"
`shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1 {status = Confirmed}))
_ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
getConn store "conn1"
`returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)
setRcvQueueStatus store rcvQueue1 Confirmed
`returnsResult` ()
getConn store "conn1"
`returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1 {status = Confirmed})
testSetSndQueueStatus :: SpecWith SQLiteStore
testSetSndQueueStatus =
it "should update status of SndQueue" . withStoreTransaction $ \db -> do
it "should update status of SndQueue" $ \store -> do
g <- newTVarIO =<< drgNew
_ <- createSndConn db g cData1 sndQueue1
getConn db "conn1"
`shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1))
setSndQueueStatus db sndQueue1 Confirmed
`shouldReturn` ()
getConn db "conn1"
`shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1 {status = Confirmed}))
_ <- runExceptT $ createSndConn store g cData1 sndQueue1
getConn store "conn1"
`returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1)
setSndQueueStatus store sndQueue1 Confirmed
`returnsResult` ()
getConn store "conn1"
`returnsResult` SomeConn SCSnd (SndConnection cData1 sndQueue1 {status = Confirmed})
testSetQueueStatusDuplex :: SpecWith SQLiteStore
testSetQueueStatusDuplex =
it "should update statuses of RcvQueue and SndQueue in DuplexConnection" . withStoreTransaction $ \db -> do
it "should update statuses of RcvQueue and SndQueue in DuplexConnection" $ \store -> do
g <- newTVarIO =<< drgNew
_ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
_ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
getConn db "conn1"
`shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1))
setRcvQueueStatus db rcvQueue1 Secured
`shouldReturn` ()
getConn db "conn1"
`shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1))
setSndQueueStatus db sndQueue1 Confirmed
`shouldReturn` ()
getConn db "conn1"
`shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed}))
_ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
_ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
getConn store "conn1"
`returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)
setRcvQueueStatus store rcvQueue1 Secured
`returnsResult` ()
getConn store "conn1"
`returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1)
setSndQueueStatus store sndQueue1 Confirmed
`returnsResult` ()
getConn store "conn1"
`returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed})
hw :: ByteString
hw = encodeUtf8 "Hello world!"
@@ -395,30 +398,27 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
broker = (brokerId, ts)
},
msgType = AM_A_MSG_,
msgFlags = SMP.noMsgFlags,
msgBody = hw,
internalHash,
externalPrevSndHash = "hash_from_sender"
}
testCreateRcvMsg_ :: DB.Connection -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvMsgData -> Expectation
testCreateRcvMsg_ db expectedPrevSndId expectedPrevHash connId rcvMsgData@RcvMsgData {..} = do
testCreateRcvMsg_ :: SQLiteStore -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvMsgData -> Expectation
testCreateRcvMsg_ st expectedPrevSndId expectedPrevHash connId rcvMsgData@RcvMsgData {..} = do
let MsgMeta {recipient = (internalId, _)} = msgMeta
updateRcvIds db connId
`shouldReturn` (InternalId internalId, internalRcvId, expectedPrevSndId, expectedPrevHash)
createRcvMsg db connId rcvMsgData
`shouldReturn` ()
updateRcvIds st connId
`returnsResult` (InternalId internalId, internalRcvId, expectedPrevSndId, expectedPrevHash)
createRcvMsg st connId rcvMsgData
`returnsResult` ()
testCreateRcvMsg :: SpecWith SQLiteStore
testCreateRcvMsg =
it "should reserve internal ids and create a RcvMsg" $ \st -> do
g <- newTVarIO =<< drgNew
let ConnData {connId} = cData1
_ <- withTransaction st $ \db -> do
createRcvConn db g cData1 rcvQueue1 SCMInvitation
withTransaction st $ \db -> do
testCreateRcvMsg_ db 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
testCreateRcvMsg_ db 1 "hash_dummy" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
_ <- runExceptT $ createRcvConn st g cData1 rcvQueue1 SCMInvitation
testCreateRcvMsg_ st 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
testCreateRcvMsg_ st 1 "hash_dummy" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
mkSndMsgData :: InternalId -> InternalSndId -> MsgHash -> SndMsgData
mkSndMsgData internalId internalSndId internalHash =
@@ -427,42 +427,37 @@ mkSndMsgData internalId internalSndId internalHash =
internalSndId,
internalTs = ts,
msgType = AM_A_MSG_,
msgFlags = SMP.noMsgFlags,
msgBody = hw,
internalHash,
prevMsgHash = internalHash
}
testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation
testCreateSndMsg_ db expectedPrevHash connId sndMsgData@SndMsgData {..} = do
updateSndIds db connId
`shouldReturn` (internalId, internalSndId, expectedPrevHash)
createSndMsg db connId sndMsgData
`shouldReturn` ()
testCreateSndMsg_ :: SQLiteStore -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation
testCreateSndMsg_ store expectedPrevHash connId sndMsgData@SndMsgData {..} = do
updateSndIds store connId
`returnsResult` (internalId, internalSndId, expectedPrevHash)
createSndMsg store connId sndMsgData
`returnsResult` ()
testCreateSndMsg :: SpecWith SQLiteStore
testCreateSndMsg =
it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \st -> do
it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \store -> do
g <- newTVarIO =<< drgNew
let ConnData {connId} = cData1
_ <- withTransaction st $ \db -> do
createSndConn db g cData1 sndQueue1
withTransaction st $ \db -> do
testCreateSndMsg_ db "" connId $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
testCreateSndMsg_ db "hash_dummy" connId $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
_ <- runExceptT $ createSndConn store g cData1 sndQueue1
testCreateSndMsg_ store "" connId $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
testCreateSndMsg_ store "hash_dummy" connId $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
testCreateRcvAndSndMsgs :: SpecWith SQLiteStore
testCreateRcvAndSndMsgs =
it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \st -> do
it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \store -> do
g <- newTVarIO =<< drgNew
let ConnData {connId} = cData1
_ <- withTransaction st $ \db -> do
g <- newTVarIO =<< drgNew
createRcvConn db g cData1 rcvQueue1 SCMInvitation
withTransaction st $ \db -> do
_ <- upgradeRcvConnToDuplex db "conn1" sndQueue1
testCreateRcvMsg_ db 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
testCreateRcvMsg_ db 1 "rcv_hash_1" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
testCreateSndMsg_ db "" connId $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"
testCreateRcvMsg_ db 2 "rcv_hash_2" connId $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
testCreateSndMsg_ db "snd_hash_1" connId $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
testCreateSndMsg_ db "snd_hash_2" connId $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"
_ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation
_ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
testCreateRcvMsg_ store 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
testCreateRcvMsg_ store 1 "rcv_hash_1" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
testCreateSndMsg_ store "" connId $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"
testCreateRcvMsg_ store 2 "rcv_hash_2" connId $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
testCreateSndMsg_ store "snd_hash_1" connId $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
testCreateSndMsg_ store "snd_hash_2" connId $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"
-29
View File
@@ -1,29 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module AgentTests.SchemaDump where
import Control.Monad (void)
import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import System.Process (readCreateProcess, shell)
import Test.Hspec
testDB :: FilePath
testDB = "tests/tmp/test_agent_schema.db"
schema :: FilePath
schema = "src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql"
schemaDumpTest :: Spec
schemaDumpTest =
it "verify and overwrite schema dump" testVerifySchemaDump
testVerifySchemaDump :: IO ()
testVerifySchemaDump = do
void $ createSQLiteStore testDB Migrations.app False
void $ readCreateProcess (shell $ "touch " <> schema) ""
savedSchema <- readFile schema
savedSchema `seq` pure ()
void $ readCreateProcess (shell $ "sqlite3 " <> testDB <> " '.schema --indent' > " <> schema) ""
currentSchema <- readFile schema
savedSchema `shouldBe` currentSchema
-225
View File
@@ -1,225 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module NtfClient where
import Control.Monad
import Control.Monad.Except (runExceptT)
import Control.Monad.IO.Unlift
import Crypto.Random
import Data.Aeson (FromJSON (..), ToJSON (..), (.:))
import qualified Data.Aeson as J
import qualified Data.Aeson.Types as JT
import Data.ByteString.Builder (lazyByteString)
import Data.ByteString.Char8 (ByteString)
import Data.Text (Text)
import GHC.Generics (Generic)
import Network.HTTP.Types (Status)
import qualified Network.HTTP.Types as N
import qualified Network.HTTP2.Server as H
import Network.Socket
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
import Simplex.Messaging.Notifications.Server.Env
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Transport
import Simplex.Messaging.Protocol
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.HTTP2 (http2TLSParams)
import Simplex.Messaging.Transport.HTTP2.Client
import Simplex.Messaging.Transport.HTTP2.Server
import Simplex.Messaging.Transport.KeepAlive
import Test.Hspec
import UnliftIO.Async
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM
import UnliftIO.Timeout (timeout)
testHost :: HostName
testHost = "localhost"
ntfTestPort :: ServiceName
ntfTestPort = "6001"
apnsTestPort :: ServiceName
apnsTestPort = "6010"
testKeyHash :: C.KeyHash
testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
ntfTestStoreLogFile :: FilePath
ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
testNtfClient client =
runTransportClient Nothing testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
Right th -> client th
Left e -> error $ show e
ntfServerCfg :: NtfServerConfig
ntfServerCfg =
NtfServerConfig
{ transports = undefined,
subIdBytes = 24,
regCodeBytes = 32,
clientQSize = 1,
subQSize = 1,
pushQSize = 1,
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig =
defaultAPNSPushClientConfig
{ apnsPort = apnsTestPort,
http2cfg = defaultHTTP2ClientConfig {caStoreFile = "tests/fixtures/ca.crt"}
},
inactiveClientExpiration = Just defaultInactiveClientExpiration,
storeLogFile = Nothing,
resubscribeDelay = 1000,
-- CA certificate private key is not needed for initialization
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt",
-- stats config
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/ntf-server-stats.daily.log",
serverStatsBackupFile = Nothing
}
withNtfServerStoreLog :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ThreadId -> m a) -> m a
withNtfServerStoreLog t = withNtfServerCfg t ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile}
withNtfServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
withNtfServerThreadOn t port' = withNtfServerCfg t ntfServerCfg {transports = [(port', t)]}
withNtfServerCfg :: (MonadUnliftIO m, MonadRandom m) => ATransport -> NtfServerConfig -> (ThreadId -> m a) -> m a
withNtfServerCfg t cfg =
serverBracket
(\started -> runNtfServerBlocking started cfg {transports = [(ntfTestPort, t)]})
(pure ())
serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
serverBracket process afterProcess f = do
started <- newEmptyTMVarIO
E.bracket
(forkIOWithUnmask ($ process started))
(\t -> killThread t >> afterProcess >> waitFor started "stop")
(\t -> waitFor started "start" >> f t)
where
waitFor started s =
5_000_000 `timeout` atomically (takeTMVar started) >>= \case
Nothing -> error $ "server did not " <> s
_ -> pure ()
withNtfServerOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> m a -> m a
withNtfServerOn t port' = withNtfServerThreadOn t port' . const
withNtfServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
withNtfServer t = withNtfServerOn t ntfTestPort
runNtfTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (THandle c -> m a) -> m a
runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
ntfServerTest ::
forall c smp.
(Transport c, Encoding smp) =>
TProxy c ->
(Maybe C.ASignature, ByteString, ByteString, smp) ->
IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg)
ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
where
tPut' h (sig, corrId, queueId, smp) = do
let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
[Right ()] <- tPut h [(sig, t')]
pure ()
tGet' h = do
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
pure (Nothing, corrId, qId, cmd)
ntfTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
ntfTest _ test' = runNtfTest test' `shouldReturn` ()
data APNSMockRequest = APNSMockRequest
{ notification :: APNSNotification,
sendApnsResponse :: APNSMockResponse -> IO ()
}
data APNSMockResponse = APNSRespOk | APNSRespError Status Text
data APNSMockServer = APNSMockServer
{ action :: Async (),
apnsQ :: TBQueue APNSMockRequest,
http2Server :: HTTP2Server
}
apnsMockServerConfig :: HTTP2ServerConfig
apnsMockServerConfig =
HTTP2ServerConfig
{ qSize = 1,
http2Port = apnsTestPort,
serverSupported = http2TLSParams,
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
}
withAPNSMockServer :: (APNSMockServer -> IO ()) -> IO ()
withAPNSMockServer = E.bracket (getAPNSMockServer apnsMockServerConfig) closeAPNSMockServer
deriving instance Generic APNSAlertBody
instance FromJSON APNSAlertBody where
parseJSON (J.Object v) = do
title <- v .: "title"
subtitle <- v .: "subtitle"
body <- v .: "body"
pure APNSAlertObject {title, subtitle, body}
parseJSON (J.String v) = pure $ APNSAlertText v
parseJSON invalid = JT.prependFailure "parsing Coord failed, " (JT.typeMismatch "Object" invalid)
instance FromJSON APNSNotificationBody where parseJSON = J.genericParseJSON apnsJSONOptions {J.rejectUnknownFields = True}
deriving instance FromJSON APNSNotification
deriving instance ToJSON APNSErrorResponse
getAPNSMockServer :: HTTP2ServerConfig -> IO APNSMockServer
getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
http2Server <- getHTTP2Server config
apnsQ <- newTBQueueIO qSize
action <- async $ runAPNSMockServer apnsQ http2Server
pure APNSMockServer {action, apnsQ, http2Server}
where
runAPNSMockServer apnsQ HTTP2Server {reqQ} = forever $ do
HTTP2Request {reqBody, sendResponse} <- atomically $ readTBQueue reqQ
let sendApnsResponse = \case
APNSRespOk -> sendResponse $ H.responseNoBody N.ok200 []
APNSRespError status reason ->
sendResponse . H.responseBuilder status [] . lazyByteString $ J.encode APNSErrorResponse {reason}
case J.decodeStrict' reqBody of
Just notification ->
atomically $ writeTBQueue apnsQ APNSMockRequest {notification, sendApnsResponse}
_ -> do
putStrLn $ "runAPNSMockServer J.decodeStrict' error, reqBody: " <> show reqBody
sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body"
closeAPNSMockServer :: APNSMockServer -> IO ()
closeAPNSMockServer APNSMockServer {action, http2Server} = do
closeHTTP2Server http2Server
uninterruptibleCancel action
-167
View File
@@ -1,167 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module NtfServerTests where
import Control.Concurrent (threadDelay)
import Control.Monad.Except (runExceptT)
import qualified Data.Aeson as J
import qualified Data.Aeson.Types as JT
import Data.Bifunctor (first)
import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Char8 (ByteString)
import Data.Text.Encoding (encodeUtf8)
import NtfClient
import SMPClient as SMP
import ServerTests
( createAndSecureQueue,
sampleDhPubKey,
samplePubKey,
sampleSig,
signSendRecv,
tGet1,
tPut1,
(#==),
_SEND',
pattern Resp,
)
import qualified Simplex.Messaging.Agent.Protocol as AP
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Push.APNS
import qualified Simplex.Messaging.Notifications.Server.Push.APNS as APNS
import Simplex.Messaging.Parsers (parse, parseAll)
import Simplex.Messaging.Protocol hiding (notification)
import Simplex.Messaging.Transport
import Test.Hspec
import UnliftIO.STM
ntfServerTests :: ATransport -> Spec
ntfServerTests t = do
describe "Notifications server protocol syntax" $ ntfSyntaxTests t
describe "Notification subscriptions" $ testNotificationSubscription t
ntfSyntaxTests :: ATransport -> Spec
ntfSyntaxTests (ATransport t) = do
it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN)
describe "NEW" $ do
it "no parameters" $ (sampleSig, "bcda", "", TNEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)
it "many parameters" $ (sampleSig, "cdab", "", (TNEW_, (' ', '\x01', 'A'), ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
it "no signature" $ ("", "dabc", "", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
it "token ID" $ (sampleSig, "abcd", "12345678", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
where
(>#>) ::
Encoding smp =>
(Maybe C.ASignature, ByteString, ByteString, smp) ->
(Maybe C.ASignature, ByteString, ByteString, BrokerMsg) ->
Expectation
command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response
pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission NtfResponse
pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command))
sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
Right () <- tPut1 h (sgn, t)
tGet1 h
signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
Right sig <- runExceptT $ C.sign pk t
Right () <- tPut1 h (Just sig, t)
tGet1 h
(.->) :: J.Value -> J.Key -> Either String ByteString
v .-> key =
let J.Object o = v
in U.decodeLenient . encodeUtf8 <$> JT.parseEither (J..: key) o
testNotificationSubscription :: ATransport -> Spec
testNotificationSubscription (ATransport t) =
it "should create notification subscription and notify when message is received" $ do
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
(nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
(tknPub, tknKey) <- C.generateSignatureKeyPair C.SEd25519
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
let tkn = DeviceToken PPApnsTest "abcd"
withAPNSMockServer $ \APNSMockServer {apnsQ} ->
smpTest2 t $ \rh sh ->
ntfTest t $ \nh -> do
-- create queue
(sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue rh sPub
-- register and verify token
RespNtf "1" "" (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", "", TNEW $ NewNtfTkn tkn tknPub dhPub)
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse = send} <-
atomically $ readTBQueue apnsQ
send APNSRespOk
let dhSecret = C.dh' ntfDh dhPriv
Right verification = ntfData .-> "verification"
Right nonce = C.cbNonce <$> ntfData .-> "nonce"
Right code = NtfRegCode <$> C.cbDecrypt dhSecret nonce verification
RespNtf "2" _ NROk <- signSendRecvNtf nh tknKey ("2", tId, TVFY code)
RespNtf "2a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("2a", tId, TCHK)
-- enable queue notifications
(rcvNtfPubDhKey, rcvNtfPrivDhKey) <- C.generateKeyPair'
Resp "3" _ (NID nId rcvNtfSrvPubDhKey) <- signSendRecv rh rKey ("3", rId, NKEY nPub rcvNtfPubDhKey)
let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
q = SMPQueueNtf srv nId
rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
RespNtf "4" _ (NRSubId _subId) <- signSendRecvNtf nh tknKey ("4", "", SNEW $ NewNtfSub tId q nKey)
-- send message
threadDelay 50000
Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello")
-- receive notification
APNSMockRequest {notification, sendApnsResponse = send'} <- atomically $ readTBQueue apnsQ
let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData'} = notification
Right nonce' = C.cbNonce <$> ntfData' .-> "nonce"
Right message = ntfData' .-> "message"
Right ntfDataDecrypted = C.cbDecrypt dhSecret nonce' message
Right APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer, notifierId}, nmsgNonce, encNMsgMeta} =
parse strP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted
Right nMsgMeta = C.cbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta
Right NMsgMeta {msgId, msgTs} = parse smpP (AP.INTERNAL "error parsing NMsgMeta") nMsgMeta
smpServer `shouldBe` srv
notifierId `shouldBe` nId
send' APNSRespOk
-- receive message
Resp "" _ (MSG RcvMessage {msgId = mId1, msgBody = EncRcvMsgBody body}) <- tGet1 rh
Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId1) body)
mId1 `shouldBe` msgId
mTs `shouldBe` msgTs
(msgBody, "hello") #== "delivered from queue"
Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, ACK mId1)
pure ()
-- replace token
let tkn' = DeviceToken PPApnsTest "efgh"
RespNtf "7" tId' NROk <- signSendRecvNtf nh tknKey ("7", tId, TRPL tkn')
tId `shouldBe` tId'
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}, sendApnsResponse = send2} <-
atomically $ readTBQueue apnsQ
send2 APNSRespOk
let Right verification2 = ntfData2 .-> "verification"
Right nonce2 = C.cbNonce <$> ntfData2 .-> "nonce"
Right code2 = NtfRegCode <$> C.cbDecrypt dhSecret nonce2 verification2
RespNtf "8" _ NROk <- signSendRecvNtf nh tknKey ("8", tId, TVFY code2)
RespNtf "8a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("8a", tId, TCHK)
-- send message
Resp "9" _ OK <- signSendRecv sh sKey ("9", sId, _SEND' "hello 2")
APNSMockRequest {notification = notification3, sendApnsResponse = send3} <- atomically $ readTBQueue apnsQ
let APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData3} = notification3
Right nonce3 = C.cbNonce <$> ntfData3 .-> "nonce"
Right message3 = ntfData3 .-> "message"
Right ntfDataDecrypted3 = C.cbDecrypt dhSecret nonce3 message3
Right APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} =
parse strP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3
smpServer3 `shouldBe` srv
notifierId3 `shouldBe` nId
send3 APNSRespOk
+9 -35
View File
@@ -11,7 +11,6 @@ import Crypto.Random
import qualified Data.ByteString.Char8 as B
import qualified Data.List.NonEmpty as L
import Network.Socket (HostName, ServiceName)
import NtfClient (ntfTestPort)
import SMPClient
( serverBracket,
testKeyHash,
@@ -25,10 +24,9 @@ import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultClientConfig)
import Simplex.Messaging.Client (SMPClientConfig (..), smpDefaultConfig)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.KeepAlive
import Test.Hspec
import UnliftIO.Concurrent
import UnliftIO.Directory
@@ -155,43 +153,20 @@ smpAgentTest1_1_1 test' =
_test [h] = test' h
_test _ = error "expected 1 handle"
testSMPServer :: SMPServer
testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"
testSMPServer2 :: SMPServer
testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5002"
initAgentServers :: InitialAgentServers
initAgentServers =
InitialAgentServers
{ smp = L.fromList [testSMPServer],
ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"],
netCfg = NetworkConfig {socksProxy = Nothing, tcpTimeout = 5000000}
}
initAgentServers2 :: InitialAgentServers
initAgentServers2 = initAgentServers {smp = L.fromList [testSMPServer, testSMPServer2]}
agentCfg :: AgentConfig
agentCfg =
cfg :: AgentConfig
cfg =
defaultAgentConfig
{ tcpPort = agentTestPort,
initialSMPServers = L.fromList ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@127.0.0.1:5001"],
tbqSize = 1,
dbFile = testDB,
smpCfg =
defaultClientConfig
smpDefaultConfig
{ qSize = 1,
defaultTransport = (testPort, transport @TLS),
tcpTimeout = 500_000
},
ntfCfg =
defaultClientConfig
{ qSize = 1,
defaultTransport = (ntfTestPort, transport @TLS)
},
reconnectInterval = defaultReconnectInterval {initialInterval = 50_000},
ntfWorkerDelay = 1000,
ntfSMPWorkerDelay = 1000,
reconnectInterval = (reconnectInterval defaultAgentConfig) {initialInterval = 50_000},
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
@@ -199,10 +174,9 @@ agentCfg =
withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m () -> (ThreadId -> m a) -> m a
withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
let cfg' = agentCfg {tcpPort = port', dbFile = db'}
initServers' = initAgentServers {smp = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
let cfg' = cfg {tcpPort = port', dbFile = db', initialSMPServers = L.fromList [SMPServer "127.0.0.1" smpPort' testKeyHash]}
in serverBracket
(\started -> runSMPAgentBlocking t started cfg' initServers')
(\started -> runSMPAgentBlocking t started cfg')
afterProcess
withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> (ThreadId -> m a) -> m a
@@ -216,7 +190,7 @@ withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a
testSMPAgentClientOn port' client = do
runTransportClient Nothing agentTestHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
runTransportClient agentTestHost port' testKeyHash $ \h -> do
line <- liftIO $ getLn h
if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
then client h
+16 -43
View File
@@ -3,7 +3,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@@ -20,10 +19,9 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server (runSMPServerBlocking)
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.StoreLog (openReadStoreLog)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Version
import Test.Hspec
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
@@ -31,7 +29,7 @@ import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar)
import UnliftIO.Timeout (timeout)
testHost :: HostName
testHost = "localhost"
testHost = "127.0.0.1"
testPort :: ServiceName
testPort = "5001"
@@ -45,25 +43,13 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
testStoreLogFile :: FilePath
testStoreLogFile = "tests/tmp/smp-server-store.log"
testStoreLogFile2 :: FilePath
testStoreLogFile2 = "tests/tmp/smp-server-store.log.2"
testStoreMsgsFile :: FilePath
testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
testServerStatsBackupFile :: FilePath
testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
testSMPClient client =
runTransportClient Nothing testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case
runTransportClient testHost testPort testKeyHash $ \h ->
liftIO (runExceptT $ clientHandshake h testKeyHash) >>= \case
Right th -> client th
Left e -> error $ show e
cfgV2 :: ServerConfig
cfgV2 = cfg {smpServerVRange = mkVersionRange 1 2}
cfg :: ServerConfig
cfg =
ServerConfig
@@ -73,38 +59,25 @@ cfg =
msgQueueQuota = 4,
queueIdBytes = 24,
msgIdBytes = 24,
storeLogFile = Nothing,
storeMsgsFile = Nothing,
allowNewQueues = True,
messageExpiration = Just defaultMessageExpiration,
inactiveClientExpiration = Just defaultInactiveClientExpiration,
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/smp-server-stats.daily.log",
serverStatsBackupFile = Nothing,
storeLog = Nothing,
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt",
smpServerVRange = supportedSMPServerVRange
certificateFile = "tests/fixtures/server.crt"
}
withSmpServerStoreMsgLogOnV2 :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
withSmpServerStoreMsgLogOnV2 t = withSmpServerConfigOn t cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
withSmpServerStoreMsgLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
withSmpServerConfigOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServerConfig -> ServiceName -> (ThreadId -> m a) -> m a
withSmpServerConfigOn t cfg' port' =
withSmpServerStoreLogOn t port' client = do
s <- liftIO $ openReadStoreLog testStoreLogFile
serverBracket
(\started -> runSMPServerBlocking started cfg' {transports = [(port', t)]})
(\started -> runSMPServerBlocking started cfg {transports = [(port', t)], storeLog = Just s})
(pure ())
client
withSmpServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
withSmpServerThreadOn t = withSmpServerConfigOn t cfg
withSmpServerThreadOn t port' =
serverBracket
(\started -> runSMPServerBlocking started cfg {transports = [(port', t)]})
(pure ())
serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
serverBracket process afterProcess f = do
@@ -145,10 +118,10 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
where
tPut' h (sig, corrId, queueId, smp) = do
let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
[Right ()] <- tPut h [(sig, t')]
Right () <- tPut h (sig, t')
pure ()
tGet' h = do
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
(Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h
pure (Nothing, corrId, qId, cmd)
smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation

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