Compare commits

...
17 Commits
Author SHA1 Message Date
Evgeny Poberezkin 180b4b9dcb version 3.2.0 (#499) 2022-08-16 20:45:35 +01:00
Evgeny Poberezkin 0437796232 support multiple server hosts with notifications (#498)
* support multiple server hosts with notifications

* remove unused type

* remove unused import

* update server hosts during parsing
2022-08-14 21:10:34 +01:00
Evgeny Poberezkin 02bba01c16 send host events when server hosts are connected and disconnected (#496) 2022-08-13 11:57:36 +01:00
Evgeny Poberezkin 68138c08d2 support multiple server hostnames per queue (#494)
* store SMP client version per queue

* use versioned format for queue addresses (not compatible with v1)

* multiple server hosts in queue URI/data, versioned encoding (cross-version tests fail)

* choose server host based on socksProxy setting

* test works

* multiple server addresses mostly work

* add onion hosts for provided servers

* update SMP hosts
2022-08-12 11:32:04 +01:00
Evgeny Poberezkin 6bfaa4985e expire messages after 2 days, increase max message sending interval (#490)
* expire messages after 2 days, increase max message sending interval

* rename
2022-08-11 10:15:08 +01:00
Evgeny Poberezkin 7d99c4b35c reconnect agent clients on any network config change (#489)
* reconnect agent clients on any network config change

* add Eq instances
2022-08-03 09:59:49 +01:00
Evgeny Poberezkin e9db0a1162 allow passing all network configuration to the agent (#488) 2022-08-02 13:30:00 +01:00
Evgeny Poberezkin b8c23ea8d5 3.1.3 2022-08-01 11:36:46 +01:00
Evgeny Poberezkin b76ef03dbe ntf: server stats (#487)
* nts: server stats

* ntf: collect stats, refactor

* rename property

* fixes
2022-08-01 08:42:23 +01:00
Evgeny Poberezkin fcaddb7848 agent functions to get/set network configuration (#484)
* agent functions to get/set network configuration

* fix condition
2022-07-25 13:50:46 +01:00
Evgeny Poberezkin d788c3ca95 access servers via SOCKS proxy (#482)
* access servers via SOCKS proxy

* config to pass tcp timeout and option SOCKS5 proxy to the agent
2022-07-23 13:57:10 +01:00
Evgeny Poberezkin e07121266a 3.1.2 2022-07-22 11:29:20 +01:00
Evgeny Poberezkin 2f39f055c1 Merge branch 'stable' 2022-07-22 11:28:39 +01:00
shandEvgeny Poberezkin 5d06dde757 docker: add selfhosted version (#481)
* docker: add selfhosted version

* switch to ghcup

* readme

* master -> stable

* delete git checkout

* rename docker files

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2022-07-22 11:26:20 +01:00
Evgeny Poberezkin eb1f9370c1 fix GET from contact connection (#480) 2022-07-21 19:42:31 +01:00
Evgeny Poberezkin d810db4eed send servers in agent events (#478)
* send servers in agent events

* remove some changes

* command/function to get connection servers

* getConnectionServers return type
2022-07-20 13:56:43 +01:00
shandEvgeny Poberezkin d8f07e8dde add hosted docker container (#479)
* add docker container

* Apply suggestions from code review

* Update README.md

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2022-07-20 11:21:10 +01:00
50 changed files with 1441 additions and 451 deletions
+8
View File
@@ -1,3 +1,11 @@
# 3.2.0
SMP agent:
- Support multiple server hostnames (including onion hostnames) in server addresses.
- Network configuration options.
- Options to define rules to choose server hostname.
# 3.1.0
SMP server and agent:
+20 -12
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](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.
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.
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,7 +27,7 @@ SimpleXMQ is implemented in Haskell - it benefits from robust software transacti
### SMP server
[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution, including low power/low memory devices. OpenSSL library is required for initialization.
[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.
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]`.
@@ -39,7 +39,7 @@ Starting from version 2.3.0, when store log is enabled, the server would also en
> **Please note:** On initialization SMP server creates a chain of two certificates: a self-signed CA certificate ("offline") and a server certificate used for TLS handshake ("online"). **You should store CA certificate private key securely and delete it from the server. If server TLS credential is compromised this key can be used to sign a new one, keeping the same server identity and established connections.** CA private key location by default is `/etc/opt/simplex/ca.key`.
SMP server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
SMP server implements [SMP protocol](./protocol/simplex-messaging.md).
#### Running SMP server on MacOS
@@ -62,7 +62,7 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
### SMP client library
[SMP client](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:
[SMP client](./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.
@@ -70,13 +70,13 @@ Now `openssl version` should be saying "OpenSSL". You can now run `smp-server in
### SMP agent
[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.
[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.
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.
Haskell type [ACommand](./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](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.
[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.
## Using SMP server and SMP agent
@@ -110,7 +110,15 @@ You can run your SMP server as a Linux process, optionally using a service manag
See [this section](#smp-server) for more information. Run `smp-server -h` and `smp-server init -h` for explanation of commands and options.
[<img alt="Linode" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)
<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)
## Deploy SMP server on Linode
@@ -134,7 +142,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="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
[<img alt="DigitalOcean" src="/img/digitalocean.png" align="right" width="300">](https://marketplace.digitalocean.com/apps/simplex-server)
## Deploy SMP server on DigitalOcean
@@ -162,12 +170,12 @@ smp-server init [-l] -n <fqdn>
## SMP server design
![SMP server design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/server.svg)
![SMP server design](./design/server.svg)
## SMP agent design
![SMP agent design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/agent2.svg)
![SMP agent design](./design/agent2.svg)
## License
[AGPL v3](https://github.com/simplex-chat/simplexmq/blob/master/LICENSE)
[AGPL v3](./LICENSE)
+32 -21
View File
@@ -1,9 +1,12 @@
{-# 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 (..))
@@ -42,7 +45,7 @@ ntfServerCLIConfig =
fingerprintFile = combine cfgPath "fingerprint",
defaultServerPort = "443",
executableName = "ntf-server",
serverVersion = "SMP notifications server v1.1.1",
serverVersion = "SMP notifications server v1.2.0",
mkIniFile = \enableStoreLog defaultServerPort ->
"[STORE_LOG]\n\
\# The server uses STM memory for persistence,\n\
@@ -50,28 +53,36 @@ ntfServerCLIConfig =
\# This option enables saving memory to append only log,\n\
\# and restoring it when the server is started.\n\
\# Log is compacted on start (deleted objects are removed).\n\
\# The messages are not logged.\n"
<> ("enable: " <> (if enableStoreLog then "on" else "off") <> "\n\n")
<> "[TRANSPORT]\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 _ ->
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
}
mkServerConfig = \storeLogFile transports ini ->
let settingIsOn section name = if lookupValue section name ini == Right "on" then Just () else Nothing
logStats = settingIsOn "STORE_LOG" "log_stats"
in NtfServerConfig
{ transports,
subIdBytes = 24,
regCodeBytes = 32,
clientQSize = 16,
subQSize = 64,
pushQSize = 128,
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig = defaultAPNSPushClientConfig,
inactiveClientExpiration = Nothing,
storeLogFile,
resubscribeDelay = 50000, -- 50ms
caCertificateFile = caCrtFile,
privateKeyFile = serverKeyFile,
certificateFile = serverCrtFile,
logStatsInterval = logStats $> 86400, -- seconds
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log"
}
}
+4 -1
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
@@ -8,6 +9,7 @@ import Control.Logger.Simple
import qualified Data.List.NonEmpty as L
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Server (runSMPAgent)
import Simplex.Messaging.Client (defaultNetworkConfig)
import Simplex.Messaging.Transport (TLS, Transport (..))
cfg :: AgentConfig
@@ -17,7 +19,8 @@ servers :: InitialAgentServers
servers =
InitialAgentServers
{ smp = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"],
ntf = []
ntf = [],
netCfg = defaultNetworkConfig
}
logCfg :: LogConfig
-1
View File
@@ -2,7 +2,6 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main where
+1
View File
File diff suppressed because one or more lines are too long

After

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

+2 -1
View File
@@ -1,5 +1,5 @@
name: simplexmq
version: 3.1.0
version: 3.2.0
synopsis: SimpleXMQ message broker
description: |
This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -55,6 +55,7 @@ dependencies:
- 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.*
+26
View File
@@ -0,0 +1,26 @@
# 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.
+25
View File
@@ -0,0 +1,25 @@
# 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
@@ -0,0 +1 @@
smp-server configuration, certificate and fingerprint will be stored here
+23
View File
@@ -0,0 +1,23 @@
#!/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
@@ -0,0 +1 @@
smp-server general logs, stored messages and statistics (if enabled) will be stored here
@@ -0,0 +1,53 @@
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" ]
@@ -0,0 +1,20 @@
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" ]
+8 -1
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 3.1.0
version: 3.2.0
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -50,6 +50,7 @@ library
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
Simplex.Messaging.Client
Simplex.Messaging.Client.Agent
Simplex.Messaging.Crypto
@@ -61,6 +62,7 @@ library
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
@@ -127,6 +129,7 @@ library
, 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.*
@@ -188,6 +191,7 @@ executable ntf-server
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
@@ -249,6 +253,7 @@ executable smp-agent
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
@@ -310,6 +315,7 @@ executable smp-server
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
@@ -390,6 +396,7 @@ test-suite smp-server-test
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlite-simple ==0.4.*
, stm ==2.5.*
, template-haskell ==2.16.*
+91 -45
View File
@@ -54,8 +54,11 @@ module Simplex.Messaging.Agent
ackMessage,
suspendConnection,
deleteConnection,
getConnectionServers,
setSMPServers,
setNtfServers,
setNetworkConfig,
getNetworkConfig,
registerNtfToken,
verifyNtfToken,
checkNtfToken,
@@ -88,7 +91,6 @@ import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Clock.System (systemToUTCTime)
import qualified Database.SQLite.Simple as DB
-- import GHC.Conc (unsafeIOToSTM)
import Simplex.Messaging.Agent.Client
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.NtfSubSupervisor
@@ -116,6 +118,8 @@ import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
-- import GHC.Conc (unsafeIOToSTM)
-- | Creates an SMP agent client instance
getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> InitialAgentServers -> m AgentClient
getSMPAgentClient cfg initServers = newSMPAgentEnv cfg >>= runReaderT runAgent
@@ -194,6 +198,10 @@ suspendConnection c = withAgentEnv c . suspendConnection' c
deleteConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
deleteConnection c = withAgentEnv c . deleteConnection' c
-- | get servers used for connection
getConnectionServers :: AgentErrorMonad m => AgentClient -> ConnId -> m ConnectionStats
getConnectionServers c = withAgentEnv c . getConnectionServers' c
-- | Change servers to be used for creating new queues
setSMPServers :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServer -> m ()
setSMPServers c = withAgentEnv c . setSMPServers' c
@@ -201,6 +209,18 @@ setSMPServers c = withAgentEnv c . setSMPServers' c
setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m ()
setNtfServers c = withAgentEnv c . setNtfServers' c
-- | set SOCKS5 proxy on/off and optionally set TCP timeout
setNetworkConfig :: AgentErrorMonad m => AgentClient -> NetworkConfig -> m ()
setNetworkConfig c cfg' = do
cfg <- atomically $ do
swapTVar (useNetworkConfig c) cfg'
liftIO . when (cfg /= cfg') $ do
closeProtocolServerClients c smpClients
closeProtocolServerClients c ntfClients
getNetworkConfig :: AgentErrorMonad m => AgentClient -> m NetworkConfig
getNetworkConfig = readTVarIO . useNetworkConfig
-- | Register device notifications token
registerNtfToken :: AgentErrorMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
registerNtfToken c = withAgentEnv c .: registerNtfToken' c
@@ -273,14 +293,16 @@ processCommand c (connId, cmd) = case cmd of
ACK msgId -> ackMessage' c connId msgId $> (connId, OK)
OFF -> suspendConnection' c connId $> (connId, OK)
DEL -> deleteConnection' c connId $> (connId, OK)
CHK -> (connId,) . STAT <$> getConnectionServers' c connId
newConn :: AgentMonad m => AgentClient -> ConnId -> SConnectionMode c -> m (ConnId, ConnectionRequestUri c)
newConn c connId cMode = do
srv <- getSMPServer c
(rq, qUri) <- newRcvQueue c srv
clientVRange <- asks $ smpClientVRange . config
(rq, qUri) <- newRcvQueue c srv clientVRange
g <- asks idsDrg
agentVersion <- asks $ smpAgentVersion . config
let cData = ConnData {connId, connAgentVersion = agentVersion, duplexHandshake = Nothing} -- connection mode is determined by the accepting agent
connAgentVersion <- asks $ maxVersion . smpAgentVRange . config
let cData = ConnData {connId, connAgentVersion, duplexHandshake = Nothing} -- connection mode is determined by the accepting agent
connId' <- withStore c $ \db -> createRcvConn db g cData rq cMode
addSubscription c rq connId'
ns <- asks ntfSupervisor
@@ -297,7 +319,8 @@ newConn c connId cMode = do
joinConn :: AgentMonad m => AgentClient -> ConnId -> ConnectionRequestUri c -> ConnInfo -> m ConnId
joinConn c connId (CRInvitationUri (ConnReqUriData _ agentVRange (qUri :| _)) e2eRcvParamsUri) cInfo = do
aVRange <- asks $ smpAgentVRange . config
case ( qUri `compatibleVersion` SMP.smpClientVRange,
clientVRange <- asks $ smpClientVRange . config
case ( qUri `compatibleVersion` clientVRange,
e2eRcvParamsUri `compatibleVersion` CR.e2eEncryptVRange,
agentVRange `compatibleVersion` aVRange
) of
@@ -325,7 +348,8 @@ joinConn c connId (CRInvitationUri (ConnReqUriData _ agentVRange (qUri :| _)) e2
_ -> throwError $ AGENT A_VERSION
joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInfo = do
aVRange <- asks $ smpAgentVRange . config
case ( qUri `compatibleVersion` SMP.smpClientVRange,
clientVRange <- asks $ smpClientVRange . config
case ( qUri `compatibleVersion` clientVRange,
agentVRange `compatibleVersion` aVRange
) of
(Just qInfo, Just vrsn) -> do
@@ -334,12 +358,11 @@ joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInf
pure connId'
_ -> throwError $ AGENT A_VERSION
createReplyQueue :: AgentMonad m => AgentClient -> ConnId -> m SMPQueueInfo
createReplyQueue c connId = do
createReplyQueue :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> m SMPQueueInfo
createReplyQueue c connId SndQueue {smpClientVersion} = do
srv <- getSMPServer c
(rq, qUri) <- newRcvQueue c srv
-- TODO reply queue version should be the same as send queue, ignoring it in v1
let qInfo = toVersionT qUri SMP.smpClientVersion
(rq, qUri) <- newRcvQueue c srv $ versionToRange smpClientVersion
let qInfo = toVersionT qUri smpClientVersion
addSubscription c rq connId
withStore c $ \db -> upgradeSndConnToDuplex db connId rq
ns <- asks ntfSupervisor
@@ -375,9 +398,9 @@ rejectContact' c contactConnId invId =
withStore c $ \db -> deleteInvitation db contactConnId invId
processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SMPConfirmation -> m ()
processConfirmation c rq@RcvQueue {e2ePrivKey} SMPConfirmation {senderKey, e2ePubKey} = do
processConfirmation c rq@RcvQueue {e2ePrivKey, smpClientVersion = v} SMPConfirmation {senderKey, e2ePubKey, smpClientVersion = v'} = do
let dhSecret = C.dh' e2ePubKey e2ePrivKey
withStore' c $ \db -> setRcvQueueConfirmedE2E db rq dhSecret
withStore' c $ \db -> setRcvQueueConfirmedE2E db rq dhSecret $ min v v'
secureQueue c rq senderKey
withStore' c $ \db -> setRcvQueueStatus db rq Secured
@@ -435,7 +458,7 @@ subscribeConnections' c connIds = do
addRcvQueue :: Map SMPServer (Map ConnId (RcvQueue, ConnData)) -> ConnId -> (RcvQueue, ConnData) -> Map SMPServer (Map ConnId (RcvQueue, ConnData))
addRcvQueue m connId rq@(RcvQueue {server}, _) = M.alter (Just . maybe (M.singleton connId rq) (M.insert connId rq)) server m
subscribe :: (SMPServer, Map ConnId (RcvQueue, ConnData)) -> m (Map ConnId (Either AgentErrorType ()))
subscribe (srv, qs) = subscribeQueues c srv (M.map fst qs)
subscribe (srv, qs) = snd <$> subscribeQueues c srv (M.map fst qs)
sendNtfCreate :: NtfSupervisor -> [Map ConnId (Either AgentErrorType ())] -> m ()
sendNtfCreate ns rcvRs =
forM_ (concatMap M.assocs rcvRs) $ \case
@@ -473,7 +496,7 @@ getConnectionMessage' c connId = do
withStore c (`getConn` connId) >>= \case
SomeConn _ (DuplexConnection _ rq _) -> getQueueMessage c rq
SomeConn _ (RcvConnection _ rq) -> getQueueMessage c rq
SomeConn _ ContactConnection {} -> throwError $ CMD PROHIBITED
SomeConn _ (ContactConnection _ rq) -> getQueueMessage c rq
SomeConn _ SndConnection {} -> throwError $ CONN SIMPLEX
getNotificationMessage' :: forall m. AgentMonad m => AgentClient -> C.CbNonce -> ByteString -> m (NotificationInfo, [SMPMsgMeta])
@@ -570,7 +593,7 @@ getPendingMsgQ c connId SndQueue {server, sndId} = do
runSmpQueueMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> m ()
runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {connId, duplexHandshake} sq = do
mq <- atomically $ getPendingMsgQ c connId sq
ri <- asks $ reconnectInterval . config
ri <- asks $ messageRetryInterval . config
forever $ do
atomically $ endAgentOperation c AOSndNetwork
msgId <- atomically $ readTQueue mq
@@ -601,12 +624,8 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {connId, duplexHandsh
-- in duplexHandshake mode (v2) HELLO is only sent once, without retrying,
-- because the queue must be secured by the time the confirmation or the first HELLO is received
| duplexHandshake == Just True -> connErr
| otherwise -> do
helloTimeout <- asks $ helloTimeout . config
currentTime <- liftIO getCurrentTime
if diffUTCTime currentTime internalTs > helloTimeout
then connErr
else retrySending loop
| otherwise ->
ifM (msgExpired helloTimeout) connErr (retrySending loop)
where
connErr = case rq_ of
-- party initiating connection
@@ -615,10 +634,18 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {connId, duplexHandsh
_ -> connError msgId NOT_ACCEPTED
AM_REPLY_ -> notifyDel msgId $ ERR e
AM_A_MSG_ -> notifyDel msgId $ MERR mId e
SMP (SMP.CMD _) -> notifyDel msgId err
SMP SMP.LARGE_MSG -> notifyDel msgId err
SMP {} -> notify err >> retrySending loop
_ -> retrySending loop
_
-- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server),
-- the message sending would be retried
| temporaryAgentError e || e == BROKER HOST -> do
let timeoutSel = if msgType == AM_HELLO_ then helloTimeout else messageTimeout
ifM (msgExpired timeoutSel) (notifyDel msgId err) (retrySending loop)
| otherwise -> notifyDel msgId err
where
msgExpired timeoutSel = do
msgTimeout <- asks $ timeoutSel . config
currentTime <- liftIO getCurrentTime
pure $ diffUTCTime currentTime internalTs > msgTimeout
Right () -> do
case msgType of
AM_CONN_INFO -> do
@@ -646,7 +673,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {connId, duplexHandsh
-- and this branch should never be reached as receive is created before the confirmation,
-- so the condition is not necessary here, strictly speaking.
_ -> unless (duplexHandshake == Just True) $ do
qInfo <- createReplyQueue c connId
qInfo <- createReplyQueue c connId sq
void . enqueueMessage c cData sq SMP.noMsgFlags $ REPLY [qInfo]
AM_A_MSG_ -> notify $ SENT mId
_ -> pure ()
@@ -708,6 +735,16 @@ deleteConnection' c connId =
ns <- asks ntfSupervisor
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCDelete)
getConnectionServers' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats
getConnectionServers' c connId = connServers <$> withStore c (`getConn` connId)
where
connServers :: SomeConn -> ConnectionStats
connServers = \case
SomeConn _ (RcvConnection _ RcvQueue {server}) -> ConnectionStats {rcvServers = [server], sndServers = []}
SomeConn _ (SndConnection _ SndQueue {server}) -> ConnectionStats {rcvServers = [], sndServers = [server]}
SomeConn _ (DuplexConnection _ RcvQueue {server = s1} SndQueue {server = s2}) -> ConnectionStats {rcvServers = [s1], sndServers = [s2]}
SomeConn _ (ContactConnection _ RcvQueue {server}) -> ConnectionStats {rcvServers = [server], sndServers = []}
-- | Change servers to be used for creating new queues, in Reader monad
setSMPServers' :: AgentMonad m => AgentClient -> NonEmpty SMPServer -> m ()
setSMPServers' c = atomically . writeTVar (smpServers c)
@@ -944,13 +981,14 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm
SMP.ClientRcvMsgBody {msgTs = srvTs, msgFlags, msgBody} <- decryptSMPMessage v rq msg
clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <-
parseMessage msgBody
unless (phVer `isCompatible` SMP.smpClientVRange) . throwError $ AGENT A_VERSION
clientVRange <- asks $ smpClientVRange . config
unless (phVer `isCompatible` clientVRange) . throwError $ AGENT A_VERSION
case (e2eDhSecret, e2ePubKey_) of
(Nothing, Just e2ePubKey) -> do
let e2eDh = C.dh' e2ePubKey e2ePrivKey
decryptClientMessage e2eDh clientMsg >>= \case
(SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption, encConnInfo, agentVersion}) ->
smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo agentVersion >> ack
smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo phVer agentVersion >> ack
(SMP.PHEmpty, AgentInvitation {connReq, connInfo}) ->
smpInvitation connReq connInfo >> ack
_ -> prohibited >> ack
@@ -1047,11 +1085,13 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm
parseMessage :: Encoding a => ByteString -> m a
parseMessage = liftEither . parse smpP (AGENT A_MESSAGE)
smpConfirmation :: C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> m ()
smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo agentVersion = do
smpConfirmation :: C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m ()
smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do
logServer "<--" c srv rId "MSG <CONF>"
aVRange <- asks $ smpAgentVRange . config
unless (agentVersion `isCompatible` aVRange) . throwError $ AGENT A_VERSION
AgentConfig {smpAgentVRange, smpClientVRange} <- asks config
unless
(agentVersion `isCompatible` smpAgentVRange && smpClientVersion `isCompatible` smpClientVRange)
(throwError $ AGENT A_VERSION)
case status of
New -> case (conn, e2eEncryption) of
-- party initiating connection
@@ -1063,9 +1103,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm
(Right agentMsgBody, CR.SMDNoChange) ->
parseMessage agentMsgBody >>= \case
AgentConnInfo connInfo ->
processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = []} False
AgentConnInfoReply smpQueues connInfo -> do
processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues} True
processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = [], smpClientVersion} False
AgentConnInfoReply smpQueues connInfo ->
processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion} True
_ -> prohibited
where
processConf connInfo senderConf duplexHS = do
@@ -1074,14 +1114,16 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm
confId <- withStore c $ \db -> do
setHandshakeVersion db connId agentVersion duplexHS
createConfirmation db g newConfirmation
notify $ CONF confId connInfo
let srvs = map queueServer $ smpReplyQueues senderConf
notify $ CONF confId srvs connInfo
queueServer (SMPQueueInfo _ SMPQueueAddress {smpServer}) = smpServer
_ -> prohibited
-- party accepting connection
(DuplexConnection _ _ sq, Nothing) -> do
withStore c (\db -> runExceptT $ agentRatchetDecrypt db connId encConnInfo) >>= parseMessage >>= \case
AgentConnInfo connInfo -> do
notify $ INFO connInfo
processConfirmation c rq $ SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = []}
processConfirmation c rq $ SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = [], smpClientVersion}
when (duplexHandshake == Just True) $ enqueueDuplexHello sq
_ -> prohibited
_ -> prohibited
@@ -1120,15 +1162,18 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm
_ -> prohibited
smpInvitation :: ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
smpInvitation connReq cInfo = do
smpInvitation connReq@(CRInvitationUri crData _) cInfo = do
logServer "<--" c srv rId "MSG <KEY>"
case conn of
ContactConnection {} -> do
g <- asks idsDrg
let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo}
invId <- withStore c $ \db -> createInvitation db g newInv
notify $ REQ invId cInfo
let srvs = L.map queueServer $ crSmpQueues crData
notify $ REQ invId srvs cInfo
_ -> prohibited
where
queueServer (SMPQueueUri _ SMPQueueAddress {smpServer}) = smpServer
checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity
checkMsgIntegrity prevExtSndId extSndId internalPrevMsgHash receivedPrevMsgHash
@@ -1141,8 +1186,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, v, sessId, rId, cm
connectReplyQueues :: AgentMonad m => AgentClient -> ConnData -> ConnInfo -> L.NonEmpty SMPQueueInfo -> m ()
connectReplyQueues c cData@ConnData {connId} ownConnInfo (qInfo :| _) = do
-- TODO make this proof on receiving confirmation too
case qInfo `proveCompatible` SMP.smpClientVRange of
clientVRange <- asks $ smpClientVRange . config
case qInfo `proveCompatible` clientVRange of
Nothing -> throwError $ AGENT A_VERSION
Just qInfo' -> do
sq <- newSndQueue qInfo'
@@ -1164,7 +1209,7 @@ confirmQueue (Compatible agentVersion) c connId sq connInfo e2eEncryption = do
mkAgentMessage :: Version -> m AgentMessage
mkAgentMessage 1 = pure $ AgentConnInfo connInfo
mkAgentMessage _ = do
qInfo <- createReplyQueue c connId
qInfo <- createReplyQueue c connId sq
pure $ AgentConnInfoReply (qInfo :| []) connInfo
enqueueConfirmation :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
@@ -1214,7 +1259,7 @@ newSndQueue_ ::
C.SAlgorithm a ->
Compatible SMPQueueInfo ->
m SndQueue
newSndQueue_ a (Compatible (SMPQueueInfo _clientVersion smpServer senderId rcvE2ePubDhKey)) = do
newSndQueue_ a (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do
-- this function assumes clientVersion is compatible - it was tested before
(sndPublicKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
(e2ePubKey, e2ePrivKey) <- liftIO C.generateKeyPair'
@@ -1226,5 +1271,6 @@ newSndQueue_ a (Compatible (SMPQueueInfo _clientVersion smpServer senderId rcvE2
sndPrivateKey,
e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey,
e2ePubKey = Just e2ePubKey,
status = New
status = New,
smpClientVersion
}
+119 -77
View File
@@ -19,6 +19,7 @@ module Simplex.Messaging.Agent.Client
newAgentClient,
withAgentLock,
closeAgentClient,
closeProtocolServerClients,
newRcvQueue,
subscribeQueue,
subscribeQueues,
@@ -28,7 +29,7 @@ module Simplex.Messaging.Agent.Client
getSubscriptions,
sendConfirmation,
sendInvitation,
RetryInterval (..),
temporaryAgentError,
secureQueue,
enableQueueNotifications,
disableQueueNotifications,
@@ -100,14 +101,36 @@ import Simplex.Messaging.Client
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
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
( AProtocolType (..),
BrokerMsg,
ErrorType,
MsgFlags (..),
MsgId,
NotifierId,
NtfPrivateSignKey,
NtfPublicVerifyKey,
NtfServer,
ProtoServer,
Protocol (..),
ProtocolServer (..),
ProtocolTypeI (..),
QueueId,
QueueIdsKeys (..),
RcvMessage (..),
RcvNtfPublicDhKey,
SMPMsgMeta (..),
SndPublicVerifyKey,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.Timeout (timeout)
@@ -130,6 +153,7 @@ data AgentClient = AgentClient
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,
@@ -170,7 +194,7 @@ data AgentState = ASActive | ASSuspending | ASSuspended
deriving (Eq, Show)
newAgentClient :: InitialAgentServers -> Env -> STM AgentClient
newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do
let qSize = tbqSize $ config agentEnv
active <- newTVar True
rcvQ <- newTBQueue qSize
@@ -180,6 +204,7 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
smpClients <- TM.empty
ntfServers <- newTVar ntf
ntfClients <- TM.empty
useNetworkConfig <- newTVar netCfg
subscrSrvrs <- TM.empty
pendingSubscrSrvrs <- TM.empty
subscrConns <- TM.empty
@@ -197,7 +222,7 @@ newAgentClient InitialAgentServers {smp, ntf} agentEnv = do
asyncClients <- newTVar []
clientId <- stateTVar (clientCounter agentEnv) $ \i -> let i' = i + 1 in (i', i')
lock <- newTMVar ()
return AgentClient {active, rcvQ, subQ, msgQ, smpServers, smpClients, ntfServers, ntfClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, ntfNetworkOp, rcvNetworkOp, msgDeliveryOp, sndNetworkOp, databaseOp, agentState, getMsgLocks, reconnections, asyncClients, clientId, agentEnv, lock}
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}
agentDbPath :: AgentClient -> FilePath
agentDbPath AgentClient {agentEnv = Env {store = SQLiteStore {dbFilePath}}} = dbFilePath
@@ -220,54 +245,55 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
atomically (getClientVar srv smpClients)
>>= either
(newProtocolClient c srv smpClients connectClient reconnectClient)
(waitForProtocolClient smpCfg)
(waitForProtocolClient c)
where
connectClient :: m SMPClient
connectClient = do
cfg <- asks $ smpCfg . config
cfg <- atomically . updateClientConfig c =<< asks (smpCfg . config)
u <- askUnliftIO
liftEitherError (protocolClientError SMP) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u)
clientDisconnected :: UnliftIO m -> IO ()
clientDisconnected u = do
removeClientAndSubs >>= (`forM_` serverDown u)
clientDisconnected :: UnliftIO m -> SMPClient -> IO ()
clientDisconnected u client = do
removeClientAndSubs >>= (`forM_` serverDown)
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
where
updateSubs cVar = do
cs <- readTVar cVar
modifyTVar' (subscrConns c) (`M.withoutKeys` M.keysSet cs)
addPendingSubs cVar cs
pure cs
removeClientAndSubs :: IO (Maybe (Map ConnId RcvQueue))
removeClientAndSubs = atomically $ do
TM.delete srv smpClients
TM.lookupDelete srv (subscrSrvrs c) >>= mapM updateSubs
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 cVar cs = do
let ps = pendingSubscrSrvrs c
TM.lookup srv ps >>= \case
Just v -> TM.union cs v
_ -> TM.insert srv cVar ps
serverDown :: UnliftIO m -> Map ConnId RcvQueue -> IO ()
serverDown u cs = unless (M.null cs) $
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 :: Map ConnId RcvQueue -> IO ()
serverDown cs = unless (M.null cs) $
whenM (readTVarIO active) $ do
let conns = M.keys cs
notifySub "" $ hostEvent DISCONNECT client
unless (null conns) . notifySub "" $ DOWN srv conns
atomically $ mapM_ (releaseGetLock c) cs
unliftIO u reconnectServer
reconnectServer :: m ()
reconnectServer = do
a <- async tryReconnectClient
atomically $ modifyTVar' (reconnections c) (a :)
reconnectServer :: m ()
reconnectServer = do
a <- async tryReconnectClient
atomically $ modifyTVar' (reconnections c) (a :)
tryReconnectClient :: m ()
tryReconnectClient = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop ->
reconnectClient `catchError` const loop
tryReconnectClient :: m ()
tryReconnectClient = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop ->
reconnectClient `catchError` const loop
reconnectClient :: m ()
reconnectClient =
@@ -277,8 +303,11 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
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
(client_, (errs, oks)) <- second (M.mapEither id) <$> subscribeQueues c srv qs
liftIO $ do
mapM_ (notifySub "" . hostEvent CONNECT) client_
unless (M.null oks) $ do
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
@@ -292,16 +321,17 @@ getNtfServerClient c@AgentClient {active, ntfClients} srv = do
atomically (getClientVar srv ntfClients)
>>= either
(newProtocolClient c srv ntfClients connectClient $ pure ())
(waitForProtocolClient ntfCfg)
(waitForProtocolClient c)
where
connectClient :: m NtfClient
connectClient = do
cfg <- asks $ ntfCfg . config
cfg <- atomically . updateClientConfig c =<< asks (ntfCfg . config)
liftEitherError (protocolClientError NTF) (getProtocolClient srv cfg Nothing clientDisconnected)
clientDisconnected :: IO ()
clientDisconnected = do
clientDisconnected :: NtfClient -> IO ()
clientDisconnected client = do
atomically $ TM.delete srv ntfClients
atomically $ writeTBQueue (subQ c) ("", "", hostEvent DISCONNECT client)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
getClientVar :: forall a s. ProtocolServer s -> TMap (ProtocolServer s) (TMVar a) -> STM (Either (TMVar a) (TMVar a))
@@ -313,10 +343,10 @@ getClientVar srv clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM.l
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)
waitForProtocolClient :: AgentMonad m => AgentClient -> ClientVar msg -> m (ProtocolClient msg)
waitForProtocolClient c clientVar = do
NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
liftEither $ case client_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
@@ -324,7 +354,7 @@ waitForProtocolClient clientConfig clientVar = do
newProtocolClient ::
forall msg m.
AgentMonad m =>
(AgentMonad m, ProtocolTypeI (ProtoType msg)) =>
AgentClient ->
ProtoServer msg ->
TMap (ProtoServer msg) (ClientVar msg) ->
@@ -340,9 +370,10 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
Right client -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
atomically $ putTMVar clientVar r
atomically $ writeTBQueue (subQ c) ("", "", hostEvent CONNECT client)
successAction client
Left e -> do
if e == BROKER NETWORK || e == BROKER TIMEOUT
if temporaryAgentError e
then retryAction
else atomically $ do
putTMVar clientVar (Left e)
@@ -357,11 +388,19 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
hostEvent :: forall msg. ProtocolTypeI (ProtoType msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> ProtocolClient msg -> ACommand 'Agent
hostEvent event client = event (AProtocolType $ protocolTypeI @(ProtoType msg)) $ transportHost client
updateClientConfig :: AgentClient -> ProtocolClientConfig -> STM ProtocolClientConfig
updateClientConfig AgentClient {useNetworkConfig} cfg = do
networkConfig <- readTVar useNetworkConfig
pure cfg {networkConfig}
closeAgentClient :: MonadIO m => AgentClient -> m ()
closeAgentClient c = liftIO $ do
atomically $ writeTVar (active c) False
closeProtocolServerClients (clientTimeout smpCfg) $ smpClients c
closeProtocolServerClients (clientTimeout ntfCfg) $ ntfClients c
closeProtocolServerClients c smpClients
closeProtocolServerClients c ntfClients
cancelActions $ reconnections c
cancelActions $ asyncClients c
cancelActions $ smpQueueMsgDeliveries c
@@ -372,15 +411,17 @@ closeAgentClient c = liftIO $ do
clear smpQueueMsgQueues
clear getMsgLocks
where
clientTimeout sel = tcpTimeout . sel . config $ agentEnv c
clear :: (AgentClient -> TMap k a) -> IO ()
clear sel = atomically $ writeTVar (sel c) M.empty
closeProtocolServerClients :: Int -> TMap (ProtoServer msg) (ClientVar msg) -> IO ()
closeProtocolServerClients tcpTimeout cs = readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (ProtoServer msg) (ClientVar msg)) -> IO ()
closeProtocolServerClients c clientsSel =
readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
where
closeClient cVar =
tcpTimeout `timeout` atomically (readTMVar cVar) >>= \case
cs = clientsSel c
closeClient cVar = do
NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
Just (Right client) -> closeProtocolClient client `catchAll_` pure ()
_ -> pure ()
@@ -424,22 +465,24 @@ protocolClientError protocolError_ = \case
PCEUnexpectedResponse _ -> BROKER UNEXPECTED
PCEResponseTimeout -> BROKER TIMEOUT
PCENetworkError -> BROKER NETWORK
PCEIncompatibleHost -> BROKER HOST
PCETransportError e -> BROKER $ TRANSPORT e
e@PCESignatureError {} -> INTERNAL $ show e
e@PCEIOError {} -> INTERNAL $ show e
newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri)
newRcvQueue c srv =
newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> VersionRange -> m (RcvQueue, SMPQueueUri)
newRcvQueue c srv vRange =
asks (cmdSignAlg . config) >>= \case
C.SignAlg a -> newRcvQueue_ a c srv
C.SignAlg a -> newRcvQueue_ a c srv vRange
newRcvQueue_ ::
(C.SignatureAlgorithm a, C.AlgorithmI a, AgentMonad m) =>
C.SAlgorithm a ->
AgentClient ->
SMPServer ->
VersionRange ->
m (RcvQueue, SMPQueueUri)
newRcvQueue_ a c srv = do
newRcvQueue_ a c srv vRange = do
(recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
(dhKey, privDhKey) <- liftIO C.generateKeyPair'
(e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
@@ -457,9 +500,10 @@ newRcvQueue_ a c srv = do
e2eDhSecret = Nothing,
sndId = Just sndId,
status = New,
smpClientVersion = maxVersion vRange,
clientNtfCreds = Nothing
}
pure (rq, SMPQueueUri srv sndId SMP.smpClientVRange e2eDhKey)
pure (rq, SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey)
subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
@@ -491,14 +535,14 @@ temporaryAgentError = \case
_ -> 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 :: AgentMonad m => AgentClient -> SMPServer -> Map ConnId RcvQueue -> m (Maybe SMPClient, 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
(eitherToMaybe smp_,) . 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"
@@ -507,7 +551,7 @@ subscribeQueues c srv qs = do
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
_ -> pure $ (Nothing, M.fromList errs)
where
checkQueue rq@(connId, RcvQueue {rcvId, server}) = do
prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c
@@ -555,7 +599,7 @@ logServer dir AgentClient {clientId} srv qId cmdStr =
showServer :: ProtocolServer s -> ByteString
showServer ProtocolServer {host, port} =
B.pack $ host <> if null port then "" else ':' : port
strEncode host <> B.pack (if null port then "" else ':' : port)
logSecret :: ByteString -> ByteString
logSecret bs = encode $ B.take 3 bs
@@ -569,7 +613,7 @@ sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey,
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 =
sendInvitation c (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo =
withLogClient_ c smpServer senderId "SEND <INV>" $ \smp -> do
msg <- mkInvitation
liftClient SMP $ sendSMPMessage smp Nothing senderId MsgFlags {notification = True} msg
@@ -578,7 +622,7 @@ sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) (C
-- this is only encrypted with per-queue E2E, not with double ratchet
mkInvitation = do
let agentEnvelope = AgentInvitation {agentVersion, connReq, connInfo}
agentCbEncryptOnce dhPublicKey . smpEncode $
agentCbEncryptOnce v dhPublicKey . smpEncode $
SMP.ClientMessage SMP.PHEmpty $ smpEncode agentEnvelope
getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMeta)
@@ -682,27 +726,25 @@ agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
withLogClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
agentCbEncrypt SndQueue {e2eDhSecret} e2ePubKey msg = do
agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do
cmNonce <- liftIO C.randomCbNonce
let paddedLen = maybe SMP.e2eEncMessageLength (const SMP.e2eEncConfirmationLength) e2ePubKey
cmEncBody <-
liftEither . first cryptoError $
C.cbEncrypt e2eDhSecret cmNonce msg paddedLen
-- TODO per-queue client version
let cmHeader = SMP.PubHeader (maxVersion SMP.smpClientVRange) e2ePubKey
let cmHeader = SMP.PubHeader smpClientVersion e2ePubKey
pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}
-- add encoding as AgentInvitation'?
agentCbEncryptOnce :: AgentMonad m => C.PublicKeyX25519 -> ByteString -> m ByteString
agentCbEncryptOnce dhRcvPubKey msg = do
agentCbEncryptOnce :: AgentMonad m => Version -> C.PublicKeyX25519 -> ByteString -> m ByteString
agentCbEncryptOnce clientVersion dhRcvPubKey msg = do
(dhSndPubKey, dhSndPrivKey) <- liftIO C.generateKeyPair'
let e2eDhSecret = C.dh' dhRcvPubKey dhSndPrivKey
cmNonce <- liftIO C.randomCbNonce
cmEncBody <-
liftEither . first cryptoError $
C.cbEncrypt e2eDhSecret cmNonce msg SMP.e2eEncConfirmationLength
-- TODO per-queue client version
let cmHeader = SMP.PubHeader (maxVersion SMP.smpClientVRange) (Just dhSndPubKey)
let cmHeader = SMP.PubHeader clientVersion (Just dhSndPubKey)
pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}
-- | NaCl crypto-box decrypt - both for messages received from the server
+25 -12
View File
@@ -13,6 +13,7 @@ module Simplex.Messaging.Agent.Env.SQLite
( AgentMonad,
AgentConfig (..),
InitialAgentServers (..),
NetworkConfig (..),
defaultAgentConfig,
defaultReconnectInterval,
Env (..),
@@ -39,10 +40,11 @@ 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.Protocol (NtfServer, supportedSMPClientVRange)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (TLS, Transport (..))
import Simplex.Messaging.Transport.Client (defaultSMPPort)
import Simplex.Messaging.Version
import System.Random (StdGen, newStdGen)
import UnliftIO (Async)
@@ -53,7 +55,8 @@ type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorTy
data InitialAgentServers = InitialAgentServers
{ smp :: NonEmpty SMPServer,
ntf :: [NtfServer]
ntf :: [NtfServer],
netCfg :: NetworkConfig
}
data AgentConfig = AgentConfig
@@ -66,6 +69,8 @@ data AgentConfig = AgentConfig
smpCfg :: ProtocolClientConfig,
ntfCfg :: ProtocolClientConfig,
reconnectInterval :: RetryInterval,
messageRetryInterval :: RetryInterval,
messageTimeout :: NominalDiffTime,
helloTimeout :: NominalDiffTime,
ntfCron :: Word16,
ntfWorkerDelay :: Int,
@@ -75,19 +80,25 @@ data AgentConfig = AgentConfig
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
smpAgentVersion :: Version,
smpAgentVRange :: VersionRange
smpAgentVRange :: VersionRange,
smpClientVRange :: VersionRange
}
defaultReconnectInterval :: RetryInterval
defaultReconnectInterval =
RetryInterval
{ initialInterval = second,
increaseAfter = 10 * second,
maxInterval = 10 * second
{ initialInterval = 2_000000,
increaseAfter = 10_000000,
maxInterval = 180_000000
}
defaultMessageRetryInterval :: RetryInterval
defaultMessageRetryInterval =
RetryInterval
{ initialInterval = 1_000000,
increaseAfter = 10_000000,
maxInterval = 60_000000
}
where
second = 1_000_000
defaultAgentConfig :: AgentConfig
defaultAgentConfig =
@@ -98,9 +109,11 @@ defaultAgentConfig =
tbqSize = 64,
dbFile = "smp-agent.db",
yesToMigrations = False,
smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
reconnectInterval = defaultReconnectInterval,
messageRetryInterval = defaultMessageRetryInterval,
messageTimeout = 2 * nominalDay,
helloTimeout = 2 * nominalDay,
ntfCron = 20, -- minutes
ntfWorkerDelay = 100000, -- microseconds
@@ -112,8 +125,8 @@ defaultAgentConfig =
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
smpAgentVRange = supportedSMPAgentVRange,
smpClientVRange = supportedSMPClientVRange
}
data Env = Env
+117 -42
View File
@@ -6,6 +6,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
@@ -32,7 +33,6 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
module Simplex.Messaging.Agent.Protocol
( -- * Protocol parameters
currentSMPAgentVersion,
supportedSMPAgentVRange,
e2eEncConnInfoLength,
e2eEncUserMsgLength,
@@ -40,10 +40,12 @@ module Simplex.Messaging.Agent.Protocol
-- * SMP agent protocol types
ConnInfo,
ACommand (..),
ACmd (..),
AParty (..),
SAParty (..),
MsgHash,
MsgMeta (..),
ConnectionStats (..),
SMPConfirmation (..),
AgentMsgEnvelope (..),
AgentMessage (..),
@@ -55,6 +57,7 @@ module Simplex.Messaging.Agent.Protocol
SrvLoc (..),
SMPQueueUri (..),
SMPQueueInfo (..),
SMPQueueAddress (..),
ConnectionMode (..),
SConnectionMode (..),
AConnectionMode (..),
@@ -94,6 +97,8 @@ module Simplex.Messaging.Agent.Protocol
serializeQueueStatus,
queueStatusT,
agentMessageType,
extraSMPServerHosts,
updateSMPServerHosts,
-- * TCP transport functions
tPut,
@@ -116,7 +121,10 @@ import Data.Composition ((.:), (.:.))
import Data.Functor (($>))
import Data.Int (Int64)
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
@@ -135,18 +143,24 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol
( ErrorType,
( AProtocolType,
ErrorType,
MsgBody,
MsgFlags,
MsgId,
NMsgMeta,
ProtocolServer (..),
SMPServer,
SndPublicVerifyKey,
SrvLoc (..),
legacyEncodeServer,
legacyServerP,
legacyStrEncodeServer,
pattern SMPServer,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts_ (..))
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import Test.QuickCheck (Arbitrary (..))
@@ -208,15 +222,17 @@ data ACommand (p :: AParty) where
NEW :: AConnectionMode -> ACommand Client -- response INV
INV :: AConnectionRequestUri -> ACommand Agent
JOIN :: AConnectionRequestUri -> ConnInfo -> ACommand Client -- response OK
CONF :: ConfirmationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
LET :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
REQ :: InvitationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
REQ :: InvitationId -> L.NonEmpty SMPServer -> 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
CONNECT :: AProtocolType -> TransportHost -> ACommand Agent
DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent
DOWN :: SMPServer -> [ConnId] -> ACommand Agent
UP :: SMPServer -> [ConnId] -> ACommand Agent
SEND :: MsgFlags -> MsgBody -> ACommand Client
@@ -227,6 +243,8 @@ data ACommand (p :: AParty) where
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
@@ -235,6 +253,22 @@ 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)
@@ -325,7 +359,9 @@ data SMPConfirmation = SMPConfirmation
-- | 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]
smpReplyQueues :: [SMPQueueInfo],
-- | SMP client version
smpClientVersion :: Version
}
deriving (Show)
@@ -553,20 +589,36 @@ type ConfirmationId = ByteString
type InvitationId = ByteString
data SMPQueueInfo = SMPQueueInfo
{ clientVersion :: Version,
smpServer :: SMPServer,
senderId :: SMP.SenderId,
dhPublicKey :: C.PublicKeyX25519
}
extraSMPServerHosts :: Map TransportHost TransportHost
extraSMPServerHosts =
M.fromList
[ ("smp4.simplex.im", "o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"),
("smp5.simplex.im", "jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion"),
("smp6.simplex.im", "bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"),
("smp8.simplex.im", "beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion"),
("smp9.simplex.im", "jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion"),
("smp10.simplex.im", "rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion")
]
updateSMPServerHosts :: SMPServer -> SMPServer
updateSMPServerHosts srv@ProtocolServer {host} = case host of
h :| [] -> case M.lookup h extraSMPServerHosts of
Just h' -> srv {host = [h, h']}
_ -> srv
_ -> srv
data SMPQueueInfo = SMPQueueInfo {clientVersion :: Version, queueAddress :: SMPQueueAddress}
deriving (Eq, Show)
instance Encoding SMPQueueInfo where
smpEncode SMPQueueInfo {clientVersion, smpServer, senderId, dhPublicKey} =
smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey})
| clientVersion > 1 = smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
| otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey)
smpP = do
(clientVersion, smpServer, senderId, dhPublicKey) <- smpP
pure SMPQueueInfo {clientVersion, smpServer, senderId, dhPublicKey}
clientVersion <- smpP
smpServer <- if clientVersion > 1 then smpP else updateSMPServerHosts <$> legacyServerP
(senderId, dhPublicKey) <- smpP
pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey}
-- This instance seems contrived and there was a temptation to split a common part of both types.
-- But this is created to allow backward and forward compatibility where SMPQueueUri
@@ -575,43 +627,51 @@ instance Encoding SMPQueueInfo where
instance VersionI SMPQueueInfo where
type VersionRangeT SMPQueueInfo = SMPQueueUri
version = clientVersion
toVersionRangeT SMPQueueInfo {smpServer, senderId, dhPublicKey} vr =
SMPQueueUri {clientVRange = vr, smpServer, senderId, dhPublicKey}
toVersionRangeT (SMPQueueInfo _v addr) vr = SMPQueueUri vr addr
instance VersionRangeI SMPQueueUri where
type VersionT SMPQueueUri = SMPQueueInfo
versionRange = clientVRange
toVersionT SMPQueueUri {smpServer, senderId, dhPublicKey} v =
SMPQueueInfo {clientVersion = v, smpServer, senderId, dhPublicKey}
toVersionT (SMPQueueUri _vr addr) v = SMPQueueInfo v addr
-- | SMP queue information sent out-of-band.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages
data SMPQueueUri = SMPQueueUri
data SMPQueueUri = SMPQueueUri {clientVRange :: VersionRange, queueAddress :: SMPQueueAddress}
deriving (Eq, Show)
data SMPQueueAddress = SMPQueueAddress
{ smpServer :: SMPServer,
senderId :: SMP.SenderId,
clientVRange :: VersionRange,
dhPublicKey :: C.PublicKeyX25519
}
deriving (Eq, Show)
instance StrEncoding SMPQueueUri where
-- v1 uses short SMP queue URI format
strEncode SMPQueueUri {smpServer = srv, senderId = qId, clientVRange = _vr, dhPublicKey = k} =
strEncode srv <> "/" <> strEncode qId <> "#" <> strEncode k
strP = do
smpServer <- strP <* A.char '/'
senderId <- strP <* optional (A.char '/') <* A.char '#'
(vr, dhPublicKey) <- unversioned <|> versioned
pure SMPQueueUri {smpServer, senderId, clientVRange = vr, dhPublicKey}
strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey})
| minVersion vr > 1 = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams
| otherwise = legacyStrEncodeServer srv <> "/" <> strEncode qId <> "#/?" <> query (queryParams <> srvParam)
where
unversioned = (SMP.smpClientVRange,) <$> strP <* A.endOfInput
query = strEncode . QSP QEscape
queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)]
srvParam = [("srv", strEncode $ TransportHosts_ hs) | length hs > 0]
hs = L.tail $ host srv
strP = do
srv@ProtocolServer {host = h :| host} <- strP <* A.char '/'
senderId <- strP <* optional (A.char '/') <* A.char '#'
(vr, hs, dhPublicKey) <- unversioned <|> versioned
let srv' = srv {host = h :| host <> hs}
smpServer = if maxVersion vr == 1 then updateSMPServerHosts srv' else srv'
pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey}
where
unversioned = (versionToRange 1,[],) <$> strP <* A.endOfInput
versioned = do
dhKey_ <- optional strP
query <- optional (A.char '/') *> A.char '?' *> strP
vr <- queryParam "v" query
dhKey <- maybe (queryParam "dh" query) pure dhKey_
pure (vr, dhKey)
hs_ <- queryParam_ "srv" query
pure (vr, maybe [] thList_ hs_, dhKey)
data ConnectionRequestUri (m :: ConnectionMode) where
CRInvitationUri :: ConnReqUriData -> E2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation
@@ -747,7 +807,7 @@ data AgentErrorType
AGENT {agentErr :: SMPAgentError}
| -- | agent implementation or dependency errors
INTERNAL {internalErr :: String}
deriving (Eq, Generic, Read, Show, Exception)
deriving (Eq, Generic, Show, Exception)
instance ToJSON AgentErrorType where
toJSON = J.genericToJSON $ sumTypeJSON id
@@ -797,6 +857,8 @@ data BrokerErrorType
UNEXPECTED
| -- | network error
NETWORK
| -- | no compatible server host (e.g. onion when public is required, or vice versa)
HOST
| -- | handshake or other transport error
TRANSPORT {transportErr :: TransportError}
| -- | command response timeout
@@ -872,8 +934,10 @@ commandP =
<|> "INFO " *> infoCmd
<|> "SUB" $> ACmd SClient SUB
<|> "END" $> ACmd SAgent END
<|> "DOWN " *> downsResp
<|> "UP " *> upsResp
<|> "CONNECT " *> connectResp
<|> "DISCONNECT " *> disconnectResp
<|> "DOWN " *> downResp
<|> "UP " *> upResp
<|> "SEND " *> sendCmd
<|> "MID " *> msgIdResp
<|> "SENT " *> sentResp
@@ -882,6 +946,8 @@ 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
@@ -889,20 +955,23 @@ 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 <*> A.takeByteString
confMsg = ACmd SAgent .:. CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> A.takeByteString
letCmd = ACmd SClient .: LET <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
reqMsg = ACmd SAgent .: REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString
reqMsg = ACmd SAgent .:. REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> 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
connectResp = ACmd SAgent .: CONNECT <$> strP_ <*> strP
disconnectResp = ACmd SAgent .: DISCONNECT <$> strP_ <*> strP
downResp = ACmd SAgent .: DOWN <$> strP_ <*> connections
upResp = ACmd SAgent .: UP <$> strP_ <*> connections
sendCmd = ACmd SClient .: SEND <$> smpP <* A.space <*> 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
ackCmd = ACmd SClient . ACK <$> A.decimal
statResp = ACmd SAgent . STAT <$> strP
connections = strP `A.sepBy'` A.char ','
msgMetaP = do
integrity <- strP
@@ -922,14 +991,16 @@ serializeCommand = \case
NEW cMode -> "NEW " <> strEncode cMode
INV cReq -> "INV " <> strEncode cReq
JOIN cReq cInfo -> B.unwords ["JOIN", strEncode cReq, serializeBinary cInfo]
CONF confId cInfo -> B.unwords ["CONF", confId, serializeBinary cInfo]
CONF confId srvs cInfo -> B.unwords ["CONF", confId, strEncodeList srvs, serializeBinary cInfo]
LET confId cInfo -> B.unwords ["LET", confId, serializeBinary cInfo]
REQ invId cInfo -> B.unwords ["REQ", invId, serializeBinary cInfo]
REQ invId srvs cInfo -> B.unwords ["REQ", invId, strEncode srvs, serializeBinary cInfo]
ACPT invId cInfo -> B.unwords ["ACPT", invId, serializeBinary cInfo]
RJCT invId -> "RJCT " <> invId
INFO cInfo -> "INFO " <> serializeBinary cInfo
SUB -> "SUB"
END -> "END"
CONNECT p h -> B.unwords ["CONNECT", strEncode p, strEncode h]
DISCONNECT p h -> B.unwords ["DISCONNECT", strEncode p, strEncode h]
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
@@ -940,6 +1011,8 @@ serializeCommand = \case
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"
@@ -1000,6 +1073,8 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
ACPT {} -> Right cmd
-- ERROR response does not always have connId
ERR _ -> Right cmd
CONNECT {} -> Right cmd
DISCONNECT {} -> Right cmd
DOWN {} -> Right cmd
UP {} -> Right cmd
-- other responses must have connId
@@ -1012,9 +1087,9 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
SEND msgFlags body -> SEND msgFlags <$$> getBody body
MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
JOIN qUri cInfo -> JOIN qUri <$$> getBody cInfo
CONF confId cInfo -> CONF confId <$$> getBody cInfo
CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
LET confId cInfo -> LET confId <$$> getBody cInfo
REQ invId cInfo -> REQ invId <$$> getBody cInfo
REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
ACPT invId cInfo -> ACPT invId <$$> getBody cInfo
INFO cInfo -> INFO <$$> getBody cInfo
cmd -> pure $ Right cmd
@@ -28,3 +28,9 @@ queryParam name (QSP _ q) =
case find ((== name) . fst) q of
Just (_, p) -> either fail pure $ parseAll strP p
_ -> fail $ "no qs param " <> B.unpack name
queryParam_ :: StrEncoding a => ByteString -> QueryStringParams -> Parser (Maybe a)
queryParam_ name (QSP _ q) =
case find ((== name) . fst) q of
Just (_, p) -> either fail pure $ parseAll strP p
_ -> pure Nothing
+5 -1
View File
@@ -52,6 +52,8 @@ data RcvQueue = RcvQueue
sndId :: Maybe SMP.SenderId,
-- | queue status
status :: QueueStatus,
-- | SMP client version
smpClientVersion :: Version,
-- | credentials used in context of notifications
clientNtfCreds :: Maybe ClientNtfCreds
}
@@ -81,7 +83,9 @@ data SndQueue = SndQueue
-- | shared DH secret agreed for simple per-queue e2e encryption
e2eDhSecret :: C.DhSecretX25519,
-- | queue status
status :: QueueStatus
status :: QueueStatus,
-- | SMP client version
smpClientVersion :: Version
}
deriving (Eq, Show)
+44 -23
View File
@@ -104,6 +104,7 @@ import qualified Data.ByteString.Base64.URL as U
import Data.Char (toLower)
import Data.Functor (($>))
import Data.List (find, foldl')
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text (Text)
@@ -127,8 +128,9 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_)
import Simplex.Messaging.Protocol (MsgBody, MsgFlags, NtfServer, ProtocolServer (..), RcvNtfDhSecret, pattern NtfServer)
import Simplex.Messaging.Protocol (MsgBody, MsgFlags, NtfServer, ProtocolServer (..), RcvNtfDhSecret, SndPublicVerifyKey, pattern NtfServer)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (bshow, eitherToMaybe, ($>>=), (<$$>))
import Simplex.Messaging.Version
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
@@ -319,18 +321,20 @@ setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} stat
|]
[":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId]
setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> IO ()
setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret =
setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> Version -> IO ()
setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret smpClientVersion =
DB.executeNamed
db
[sql|
UPDATE rcv_queues
SET e2e_dh_secret = :e2e_dh_secret,
status = :status
status = :status,
smp_client_version = :smp_client_version
WHERE host = :host AND port = :port AND rcv_id = :rcv_id
|]
[ ":status" := Confirmed,
":e2e_dh_secret" := e2eDhSecret,
":smp_client_version" := smpClientVersion,
":host" := host,
":port" := port,
":rcv_id" := rcvId
@@ -367,16 +371,28 @@ setRcvQueueNtfCreds db connId clientNtfCreds =
Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
Nothing -> (Nothing, Nothing, Nothing, Nothing)
type SMPConfirmationRow = (SndPublicVerifyKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe Version)
smpConfirmation :: SMPConfirmationRow -> SMPConfirmation
smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) =
SMPConfirmation
{ senderKey,
e2ePubKey,
connInfo,
smpReplyQueues = fromMaybe [] smpReplyQueues_,
smpClientVersion = fromMaybe 1 smpClientVersion_
}
createConfirmation :: DB.Connection -> TVar ChaChaDRG -> NewConfirmation -> IO (Either StoreError ConfirmationId)
createConfirmation db gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues}, ratchetState} =
createConfirmation db gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues, smpClientVersion}, ratchetState} =
createWithRandomId gVar $ \confirmationId ->
DB.execute
db
[sql|
INSERT INTO conn_confirmations
(confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, 0);
(confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, smp_client_version, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, ?, 0);
|]
(confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues)
(confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues, smpClientVersion)
acceptConfirmation :: DB.Connection -> ConfirmationId -> ConnInfo -> IO (Either StoreError AcceptedConfirmation)
acceptConfirmation db confirmationId ownConnInfo = do
@@ -395,17 +411,17 @@ acceptConfirmation db confirmationId ownConnInfo = do
DB.query
db
[sql|
SELECT conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues
SELECT conn_id, ratchet_state, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version
FROM conn_confirmations
WHERE confirmation_id = ?;
|]
(Only confirmationId)
where
confirmation (connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues_) =
confirmation ((connId, ratchetState) :. confRow) =
AcceptedConfirmation
{ confirmationId,
connId,
senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = fromMaybe [] smpReplyQueues_},
senderConf = smpConfirmation confRow,
ratchetState,
ownConnInfo
}
@@ -416,17 +432,17 @@ getAcceptedConfirmation db connId =
DB.query
db
[sql|
SELECT confirmation_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, own_conn_info
SELECT confirmation_id, ratchet_state, own_conn_info, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version
FROM conn_confirmations
WHERE conn_id = ? AND accepted = 1;
|]
(Only connId)
where
confirmation (confirmationId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues_, ownConnInfo) =
confirmation ((confirmationId, ratchetState, ownConnInfo) :. confRow) =
AcceptedConfirmation
{ confirmationId,
connId,
senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = fromMaybe [] smpReplyQueues_},
senderConf = smpConfirmation confRow,
ratchetState,
ownConnInfo
}
@@ -985,6 +1001,10 @@ instance ToField [SMPQueueInfo] where toField = toField . smpEncodeList
instance FromField [SMPQueueInfo] where fromField = blobFieldParser smpListP
instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 . strEncode
instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
listToEither :: e -> [a] -> Either e a
listToEither _ (x : _) = Right x
listToEither e _ = Left e
@@ -1062,9 +1082,9 @@ insertRcvQueue_ dbConn connId RcvQueue {..} = do
dbConn
[sql|
INSERT INTO rcv_queues
( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status) VALUES (?,?,?,?,?,?,?,?,?,?);
(host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status, smp_client_version) VALUES (?,?,?,?,?,?,?,?,?,?,?);
|]
(host server, port server, rcvId, connId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)
((host server, port server, rcvId, connId) :. (rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, smpClientVersion))
-- * createSndConn helpers
@@ -1074,9 +1094,9 @@ insertSndQueue_ dbConn connId SndQueue {..} = do
dbConn
[sql|
INSERT INTO snd_queues
(host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status) VALUES (?,?,?,?,?, ?,?, ?,?);
(host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, smp_client_version) VALUES (?,?,?,?,?,?,?,?,?,?);
|]
(host server, port server, sndId, connId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)
(host server, port server, sndId, connId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, smpClientVersion)
-- * getConn helpers
@@ -1109,7 +1129,7 @@ getRcvQueueByConnId_ dbConn connId =
dbConn
[sql|
SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status,
q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status, q.smp_client_version,
q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
FROM rcv_queues q
INNER JOIN servers s ON q.host = s.host AND q.port = s.port
@@ -1117,12 +1137,13 @@ getRcvQueueByConnId_ dbConn connId =
|]
(Only connId)
where
rcvQueue ((keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
rcvQueue ((keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, smpClientVersion_) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
let server = SMPServer host port keyHash
smpClientVersion = fromMaybe 1 smpClientVersion_
clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
_ -> Nothing
in RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, clientNtfCreds}
in RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, smpClientVersion, clientNtfCreds}
getSndQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue)
getSndQueueByConnId_ dbConn connId =
@@ -1130,16 +1151,16 @@ getSndQueueByConnId_ dbConn connId =
<$> DB.query
dbConn
[sql|
SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status
SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.smp_client_version
FROM snd_queues q
INNER JOIN servers s ON q.host = s.host AND q.port = s.port
WHERE q.conn_id = ?;
|]
(Only connId)
where
sndQueue [(keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)] =
sndQueue [(keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, smpClientVersion)] =
let server = SMPServer host port keyHash
in Just SndQueue {server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status}
in Just SndQueue {server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, smpClientVersion}
sndQueue _ = Nothing
-- * updateRcvIds helpers
@@ -1,5 +1,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -17,18 +18,25 @@ where
import Control.Monad (forM_)
import Data.List (intercalate, sortBy)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as M
import Data.Ord (comparing)
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (Connection, Only (..), Query (..))
import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.QQ (sql)
import qualified Database.SQLite3 as SQLite3
import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport.Client (TransportHost)
data Migration = Migration {name :: String, up :: Text}
deriving (Show)
@@ -39,7 +47,8 @@ schemaMigrations =
("20220301_snd_queue_keys", m20220301_snd_queue_keys),
("20220322_notifications", m20220322_notifications),
("20220607_v2", m20220608_v2),
("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode)
("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode),
("m20220811_onion_hosts", m20220811_onion_hosts)
]
-- | The list of migrations in ascending order by date
@@ -55,10 +64,15 @@ get conn migrations =
run :: Connection -> [Migration] -> IO ()
run conn ms = DB.withImmediateTransaction conn . forM_ ms $
\Migration {name, up} -> insert name >> execSQL up
\Migration {name, up} -> insert name >> execSQL up >> updateServers name
where
insert name = DB.execute conn "INSERT INTO migrations (name, ts) VALUES (?, ?);" . (name,) =<< getCurrentTime
execSQL = SQLite3.exec $ DB.connectionHandle conn
updateServers = \case
"m20220811_onion_hosts" -> forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
in DB.execute conn "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
_ -> pure ()
initialize :: Connection -> IO ()
initialize conn =
@@ -0,0 +1,16 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220811_onion_hosts :: Query
m20220811_onion_hosts =
[sql|
ALTER TABLE conn_confirmations ADD COLUMN smp_client_version INTEGER;
UPDATE ntf_servers
SET ntf_host = 'ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion'
WHERE ntf_host = 'ntf2.simplex.im';
|]
@@ -113,7 +113,8 @@ CREATE TABLE conn_confirmations(
own_conn_info BLOB,
created_at TEXT NOT NULL DEFAULT(datetime('now'))
,
smp_reply_queues BLOB NULL
smp_reply_queues BLOB NULL,
smp_client_version INTEGER
) WITHOUT ROWID;
CREATE TABLE conn_invitations(
invitation_id BLOB NOT NULL PRIMARY KEY,
+99 -23
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
@@ -25,7 +26,7 @@
-- 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),
ProtocolClient (thVersion, sessionId, transportHost),
SMPClient,
getProtocolClient,
closeProtocolClient,
@@ -50,7 +51,10 @@ module Simplex.Messaging.Client
-- * Supporting types and client configuration
ProtocolClientError (..),
ProtocolClientConfig (..),
NetworkConfig (..),
defaultClientConfig,
defaultNetworkConfig,
chooseTransportHost,
ServerTransmission,
)
where
@@ -62,21 +66,26 @@ import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (rights)
import Data.Functor (($>))
import Data.List (find)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import GHC.Generics (Generic)
import Network.Socket (ServiceName)
import Numeric.Natural
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Parsers (dropPrefix, enumJSON)
import Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (runTransportClient)
import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), runTransportClient)
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (bshow, liftError, raceAny_)
@@ -92,6 +101,7 @@ data ProtocolClient msg = ProtocolClient
sessionId :: SessionId,
thVersion :: Version,
protocolServer :: ProtoServer msg,
transportHost :: TransportHost,
tcpTimeout :: Int,
clientCorrId :: TVar Natural,
sentCommands :: TMap CorrId (Request msg),
@@ -108,18 +118,65 @@ 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)
data HostMode
= -- | prefer (or require) onion hosts when connecting via SOCKS proxy
HMOnionViaSocks
| -- | prefer (or require) onion hosts
HMOnion
| -- | prefer (or require) public hosts
HMPublic
deriving (Eq, Show, Generic)
instance FromJSON HostMode where
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "HM"
instance ToJSON HostMode where
toJSON = J.genericToJSON . enumJSON $ dropPrefix "HM"
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HM"
-- | network configuration for the client
data NetworkConfig = NetworkConfig
{ -- | use SOCKS5 proxy
socksProxy :: Maybe SocksProxy,
-- | determines critera which host is chosen from the list
hostMode :: HostMode,
-- | if above criteria is not met, if the below setting is True return error, otherwise use the first host
requiredHostMode :: Bool,
-- | timeout for the initial client TCP/TLS connection (microseconds)
tcpConnectTimeout :: Int,
-- | timeout of protocol commands (microseconds)
tcpTimeout :: Int,
-- | TCP keep-alive options, Nothing to skip enabling keep-alive
tcpKeepAlive :: Maybe KeepAliveOpts,
-- | period for SMP ping commands (microseconds)
smpPingInterval :: Int
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON NetworkConfig where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
defaultNetworkConfig :: NetworkConfig
defaultNetworkConfig =
NetworkConfig
{ socksProxy = Nothing,
hostMode = HMOnionViaSocks,
requiredHostMode = False,
tcpConnectTimeout = 7_500_000,
tcpTimeout = 5_000_000,
tcpKeepAlive = Just defaultKeepAliveOpts,
smpPingInterval = 600_000_000 -- 10min
}
-- | protocol client configuration.
data ProtocolClientConfig = ProtocolClientConfig
{ -- | size of TBQueue to use for server commands and responses
qSize :: Natural,
-- | default server port if port is not specified in ProtocolServer
defaultTransport :: (ServiceName, ATransport),
-- | timeout of TCP commands (microseconds)
tcpTimeout :: Int,
-- | TCP keep-alive options, Nothing to skip enabling keep-alive
tcpKeepAlive :: Maybe KeepAliveOpts,
-- | period for SMP ping commands (microseconds)
smpPing :: Int,
-- | network configuration
networkConfig :: NetworkConfig,
-- | SMP client-server protocol version range
smpServerVRange :: VersionRange
}
@@ -130,9 +187,7 @@ defaultClientConfig =
ProtocolClientConfig
{ qSize = 64,
defaultTransport = ("443", transport @TLS),
tcpTimeout = 5_000_000,
tcpKeepAlive = Just defaultKeepAliveOpts,
smpPing = 600_000_000, -- 10min
networkConfig = defaultNetworkConfig,
smpServerVRange = supportedSMPServerVRange
}
@@ -143,18 +198,36 @@ data Request msg = Request
type Response msg = Either ProtocolClientError msg
chooseTransportHost :: NetworkConfig -> NonEmpty TransportHost -> Either ProtocolClientError TransportHost
chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts =
firstOrError $ case hostMode of
HMOnionViaSocks -> maybe publicHost (const onionHost) socksProxy
HMOnion -> onionHost
HMPublic -> publicHost
where
firstOrError
| requiredHostMode = maybe (Left PCEIncompatibleHost) Right
| otherwise = Right . fromMaybe (L.head hosts)
isOnionHost = \case THOnionHost _ -> True; _ -> False
onionHost = find isOnionHost hosts
publicHost = find (not . isOnionHost) hosts
-- | Connects to 'ProtocolServer' using passed client configuration
-- 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, smpPing, smpServerVRange} msgQ disconnected =
(atomically mkProtocolClient >>= runClient useTransport)
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
getProtocolClient :: forall msg. Protocol msg => ProtoServer msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient msg -> IO ()) -> IO (Either ProtocolClientError (ProtocolClient msg))
getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig, smpServerVRange} msgQ disconnected = do
case chooseTransportHost networkConfig (host protocolServer) of
Right useHost ->
(atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
Left e -> pure $ Left e
where
mkProtocolClient :: STM (ProtocolClient msg)
mkProtocolClient = do
NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpKeepAlive, socksProxy, smpPingInterval} = networkConfig
mkProtocolClient :: TransportHost -> STM (ProtocolClient msg)
mkProtocolClient transportHost = do
connected <- newTVar False
clientCorrId <- newTVar 0
sentCommands <- TM.empty
@@ -167,6 +240,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
thVersion = undefined,
connected,
protocolServer,
transportHost,
tcpTimeout,
clientCorrId,
sentCommands,
@@ -175,14 +249,14 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
msgQ
}
runClient :: (ServiceName, ATransport) -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
runClient (port', ATransport t) c = do
runClient :: (ServiceName, ATransport) -> TransportHost -> ProtocolClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
runClient (port', ATransport t) useHost c = do
thVar <- newEmptyTMVarIO
action <-
async $
runTransportClient (host protocolServer) port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
runTransportClient socksProxy useHost port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c thVar)
`finally` atomically (putTMVar thVar $ Left PCENetworkError)
th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
th_ <- tcpConnectTimeout `timeout` atomically (takeTMVar thVar)
pure $ case th_ of
Just (Right THandle {sessionId, thVersion}) -> Right c {action, sessionId, thVersion}
Just (Left e) -> Left e
@@ -205,7 +279,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
let c' = c {sessionId, thVersion} :: ProtocolClient msg
-- TODO remove ping if 0 is passed (or Nothing?)
raceAny_ [send c' th, process c', receive c' th, ping c']
`finally` disconnected
`finally` disconnected c'
send :: Transport c => ProtocolClient msg -> THandle c -> IO ()
send ProtocolClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
@@ -215,7 +289,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
ping :: ProtocolClient msg -> IO ()
ping c = forever $ do
threadDelay smpPing
threadDelay smpPingInterval
runExceptT $ sendProtocolCommand c Nothing "" protocolPing
process :: ProtocolClient msg -> IO ()
@@ -268,6 +342,8 @@ data ProtocolClientError
| -- | Failure to establish TCP connection.
-- Forwarded to the agent client as `ERR BROKER NETWORK`.
PCENetworkError
| -- | No host compatible with network configuration
PCEIncompatibleHost
| -- | TCP transport handshake or some other transport error.
-- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
PCETransportError TransportError
+6 -5
View File
@@ -26,6 +26,7 @@ import Numeric.Natural
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
@@ -125,8 +126,8 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
waitForSMPClient :: SMPClientVar -> ExceptT ProtocolClientError IO SMPClient
waitForSMPClient smpVar = do
let ProtocolClientConfig {tcpTimeout} = smpCfg agentCfg
smpClient_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar smpVar)
let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar smpVar)
liftEither $ case smpClient_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
@@ -161,8 +162,8 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
connectClient :: ExceptT ProtocolClientError IO SMPClient
connectClient = ExceptT $ getProtocolClient srv (smpCfg agentCfg) (Just msgQ) clientDisconnected
clientDisconnected :: IO ()
clientDisconnected = do
clientDisconnected :: SMPClient -> IO ()
clientDisconnected _ = do
removeClientAndSubs >>= (`forM_` serverDown)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
@@ -264,7 +265,7 @@ subscribeQueue ca srv sub = do
showServer :: SMPServer -> ByteString
showServer ProtocolServer {host, port} =
B.pack $ host <> if null port then "" else ':' : port
strEncode host <> (B.pack $ if null port then "" else ':' : port)
smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT ProtocolClientError IO ()
smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId
@@ -23,6 +23,7 @@ import Data.Type.Equality
import Data.Word (Word16)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
@@ -332,12 +333,16 @@ data SMPQueueNtf = SMPQueueNtf
instance Encoding SMPQueueNtf where
smpEncode SMPQueueNtf {smpServer, notifierId} = smpEncode (smpServer, notifierId)
smpP = do
(smpServer, notifierId) <- smpP
pure $ SMPQueueNtf {smpServer, notifierId}
smpServer <- updateSMPServerHosts <$> smpP
notifierId <- smpP
pure SMPQueueNtf {smpServer, notifierId}
instance StrEncoding SMPQueueNtf where
strEncode SMPQueueNtf {smpServer, notifierId} = strEncode smpServer <> "/" <> strEncode notifierId
strP = SMPQueueNtf <$> strP <* A.char '/' <*> strP
strP = do
smpServer <- updateSMPServerHosts <$> strP
notifierId <- A.char '/' *> strP
pure SMPQueueNtf {smpServer, notifierId}
data PushProvider = PPApnsDev | PPApnsProd | PPApnsTest
deriving (Eq, Ord, Show)
+116 -9
View File
@@ -4,8 +4,10 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
@@ -18,30 +20,41 @@ import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Reader
import Crypto.Random (MonadRandom)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.List (intercalate)
import Data.Map.Strict (Map)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Clock.System (getSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Network.Socket (ServiceName)
import Simplex.Messaging.Client (ProtocolClientError (..))
import Simplex.Messaging.Client.Agent
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Env
import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), PushNotification (..), PushProviderError (..))
import Simplex.Messaging.Notifications.Server.Stats
import Simplex.Messaging.Notifications.Server.Store
import Simplex.Messaging.Notifications.Server.StoreLog
import Simplex.Messaging.Notifications.Transport
import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server
import Simplex.Messaging.Server.Stats
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..))
import Simplex.Messaging.Transport.Server (runTransportServer)
import Simplex.Messaging.Util
import System.Exit (exitFailure)
import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
import System.Mem.Weak (deRefWeak)
import UnliftIO (IOMode (..), async, uninterruptibleCancel)
import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId, threadDelay)
import UnliftIO.Directory (doesFileExist, renameFile)
import UnliftIO.Exception
import UnliftIO.STM
@@ -54,12 +67,13 @@ runNtfServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> NtfSer
runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtfServerEnv cfg
ntfServer :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerConfig -> TMVar Bool -> m ()
ntfServer NtfServerConfig {transports} started = do
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) `finally` stopServer
raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
where
runServer :: (ServiceName, ATransport) -> m ()
runServer (tcpPort, ATransport t) = do
@@ -76,8 +90,55 @@ ntfServer NtfServerConfig {transports} started = do
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
@@ -137,9 +198,12 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
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 ()
@@ -149,19 +213,21 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
atomically (readTBQueue agentQ) >>= \case
CAConnected _ -> pure ()
CADisconnected srv subs -> do
logInfo . T.pack $ "SMP server disconnected " <> host srv <> " (" <> show (length subs) <> ") subscriptions"
logInfo $ "SMP server disconnected " <> showServer' srv <> " (" <> tshow (length subs) <> ") subscriptions"
forM_ subs $ \(_, ntfId) -> do
let smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSInactive
CAReconnected srv ->
logInfo $ "SMP server reconnected " <> T.pack (host srv)
logInfo $ "SMP server reconnected " <> showServer' srv
CAResubscribed srv sub -> do
let ntfId = snd sub
smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSActive
CASubError srv (_, ntfId) err -> do
logError . T.pack $ "SMP subscription error on server " <> host srv <> ": " <> show err
logError $ "SMP subscription error on server " <> showServer' srv <> ": " <> tshow err
handleSubError (SMPQueueNtf srv ntfId) err
where
showServer' = decodeLatin1 . strEncode . host
handleSubError :: SMPQueueNtf -> ProtocolClientError -> m ()
handleSubError smpQueue = \case
@@ -172,6 +238,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r
PCETransportError e -> updateErr "TransportError " e
PCESignatureError e -> updateErr "SignatureError " e
PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost"
PCEResponseTimeout -> pure ()
PCENetworkError -> pure ()
where
@@ -193,18 +260,21 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
status <- readTVarIO tknStatus
case (status, ntf) of
(_, PNVerification _) -> do
(_, 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) -> do
(NTActive, PNCheckMessages) ->
void $ deliverNotification pp tkn ntf
(NTActive, PNMessage {}) -> do
stats <- asks serverStats
atomically $ updatePeriodStats (activeTokens stats) ntfTknId
void $ deliverNotification pp tkn ntf
_ -> do
incNtfStat ntfDelivered
_ ->
liftIO $ logError "bad notification token status"
where
deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> m (Either PushProviderError ())
@@ -347,6 +417,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
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
@@ -368,6 +439,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
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"
@@ -386,6 +458,8 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
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"
@@ -395,6 +469,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
cancelInvervalNotifications tknId
withNtfLog (`logDeleteToken` tknId)
incNtfStat tknDeleted
pure NROk
TCRN 0 -> do
logDebug "TCRN 0"
@@ -434,6 +509,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
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
@@ -454,6 +530,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
atomically $ deleteNtfSubscription st subId
atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
withNtfLog (`logDeleteSubscription` subId)
incNtfStat subDeleted
pure NROk
PING -> pure NRPong
getId :: m NtfEntityId
@@ -471,3 +548,33 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
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
@@ -11,6 +11,7 @@ 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 (..))
@@ -21,6 +22,7 @@ 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)
@@ -48,7 +50,12 @@ data NtfServerConfig = NtfServerConfig
-- CA certificate private key is not needed for initialization
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath
certificateFile :: FilePath,
-- stats config - see SMP server config
logStatsInterval :: Maybe Int,
logStatsStartTime :: Int,
serverStatsLogFile :: FilePath,
serverStatsBackupFile :: Maybe FilePath
}
defaultInactiveClientExpiration :: ExpirationConfig
@@ -67,7 +74,8 @@ data NtfEnv = NtfEnv
idsDrg :: TVar ChaChaDRG,
serverIdentity :: C.KeyHash,
tlsServerParams :: T.ServerParams,
serverIdentity :: C.KeyHash
serverIdentity :: C.KeyHash,
serverStats :: NtfServerStats
}
newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
@@ -79,7 +87,8 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
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,
@@ -0,0 +1,113 @@
{-# 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}
+50 -14
View File
@@ -38,8 +38,7 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
module Simplex.Messaging.Protocol
( -- * SMP protocol parameters
smpClientVersion,
smpClientVRange,
supportedSMPClientVRange,
maxMessageLength,
e2eEncConfirmationLength,
e2eEncMessageLength,
@@ -65,6 +64,8 @@ module Simplex.Messaging.Protocol
PrivHeader (..),
Protocol (..),
ProtocolType (..),
AProtocolType (..),
ProtocolTypeI (..),
ProtocolServer (..),
ProtoServer,
SMPServer,
@@ -111,6 +112,9 @@ module Simplex.Messaging.Protocol
_smpP,
encodeRcvMsgBody,
clientRcvMsgBodyP,
legacyEncodeServer,
legacyServerP,
legacyStrEncodeServer,
-- * TCP transport functions
tPut,
@@ -133,7 +137,7 @@ 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.Maybe (isJust, isNothing)
import Data.String
import Data.Time.Clock.System (SystemTime (..))
import Data.Type.Equality
@@ -146,15 +150,16 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
import Simplex.Messaging.Util (bshow, (<$?>))
import Simplex.Messaging.Version
import Test.QuickCheck (Arbitrary (..))
smpClientVersion :: Version
smpClientVersion = 1
currentSMPClientVersion :: Version
currentSMPClientVersion = 2
smpClientVRange :: VersionRange
smpClientVRange = mkVersionRange 1 smpClientVersion
supportedSMPClientVRange :: VersionRange
supportedSMPClientVRange = mkVersionRange 1 currentSMPClientVersion
maxMessageLength :: Int
maxMessageLength = 16088
@@ -555,14 +560,14 @@ instance Encoding ClientMessage where
type SMPServer = ProtocolServer 'PSMP
pattern SMPServer :: HostName -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
pattern SMPServer :: NonEmpty TransportHost -> 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 :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
{-# COMPLETE NtfServer #-}
@@ -575,7 +580,7 @@ instance StrEncoding ProtocolType where
PSMP -> "smp"
PNTF -> "ntf"
strP =
A.takeTill (== ':') >>= \case
A.takeTill (\c -> c == ':' || c == ' ') >>= \case
"smp" -> pure PSMP
"ntf" -> pure PNTF
_ -> fail "bad ProtocolType"
@@ -592,6 +597,11 @@ deriving instance Show (SProtocolType p)
data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)
deriving instance Show AProtocolType
instance Eq AProtocolType where
AProtocolType p == AProtocolType p' = isJust $ testEquality p p'
instance TestEquality SProtocolType where
testEquality SPSMP SPSMP = Just Refl
testEquality SPNTF SPNTF = Just Refl
@@ -615,6 +625,10 @@ instance StrEncoding AProtocolType where
strEncode (AProtocolType p) = strEncode p
strP = aProtocolType <$> strP
instance ToJSON AProtocolType where
toEncoding = strToJEncoding
toJSON = strToJSON
checkProtocolType :: forall t p p'. (ProtocolTypeI p, ProtocolTypeI p') => t p' -> Either String (t p)
checkProtocolType p = case testEquality (protocolTypeI @p) (protocolTypeI @p') of
Just Refl -> Right p
@@ -630,7 +644,7 @@ instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
-- | server location and transport key digest (hash).
data ProtocolServer p = ProtocolServer
{ scheme :: SProtocolType p,
host :: HostName,
host :: NonEmpty TransportHost,
port :: ServiceName,
keyHash :: C.KeyHash
}
@@ -648,17 +662,39 @@ instance ProtocolTypeI p => Encoding (ProtocolServer p) where
instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
strEncode ProtocolServer {scheme, host, port, keyHash} =
strEncode scheme <> "://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)
strEncodeServer scheme (strEncode host) port keyHash
strP = do
scheme <- strP <* "://"
keyHash <- strP <* A.char '@'
SrvLoc host port <- strP
TransportHosts host <- strP
port <- portP <|> pure ""
pure ProtocolServer {scheme, host, port, keyHash}
where
portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
toJSON = strToJSON
toEncoding = strToJEncoding
legacyEncodeServer :: ProtocolServer p -> ByteString
legacyEncodeServer ProtocolServer {host, port, keyHash} =
smpEncode (L.head host, port, keyHash)
legacyServerP :: forall p. ProtocolTypeI p => Parser (ProtocolServer p)
legacyServerP = do
(h, port, keyHash) <- smpP
pure ProtocolServer {scheme = protocolTypeI @p, host = [h], port, keyHash}
legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
strEncodeServer scheme (strEncode $ L.head host) port keyHash
strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> ByteString
strEncodeServer scheme host port keyHash =
strEncode scheme <> "://" <> strEncode keyHash <> "@" <> host <> portStr
where
portStr = B.pack $ if null port then "" else ':' : port
data SrvLoc = SrvLoc HostName ServiceName
deriving (Eq, Ord, Show)
@@ -667,7 +703,7 @@ instance StrEncoding SrvLoc where
strP = SrvLoc <$> host <*> (port <|> pure "")
where
host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
port = B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
port = show <$> (A.char ':' *> (A.decimal :: Parser Int))
-- | Transmission correlation ID.
newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
+9 -27
View File
@@ -50,12 +50,8 @@ import Data.List (intercalate)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing)
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Calendar.Month.Compat (pattern MonthDay)
import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
@@ -177,7 +173,7 @@ smpServer started = 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, dayMsgQueues, weekMsgQueues, monthMsgQueues} <- asks serverStats
ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues} <- asks serverStats
let interval = 1000000 * logInterval
withFile statsFilePath AppendMode $ \h -> liftIO $ do
hSetBuffering h LineBuffering
@@ -189,17 +185,9 @@ smpServer started = do
qDeleted' <- atomically $ swapTVar qDeleted 0
msgSent' <- atomically $ swapTVar msgSent 0
msgRecv' <- atomically $ swapTVar msgRecv 0
let day = utctDay ts
(_, wDay) = mondayStartWeek day
MonthDay _ mDay = day
(dayMsgQueues', weekMsgQueues', monthMsgQueues') <-
atomically $ (,,) <$> periodCount 1 dayMsgQueues <*> periodCount wDay weekMsgQueues <*> periodCount mDay monthMsgQueues
hPutStrLn h $ intercalate "," [iso8601Show $ utctDay fromTime', show qCreated', show qSecured', show qDeleted', show msgSent', show msgRecv', dayMsgQueues', weekMsgQueues', monthMsgQueues']
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
where
periodCount :: Int -> TVar (Set RecipientId) -> STM String
periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
periodCount _ _ = pure ""
runClient :: Transport c => TProxy c -> c -> m ()
runClient _ h = do
@@ -538,15 +526,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
updateStats = do
stats <- asks serverStats
atomically $ modifyTVar (msgRecv stats) (+ 1)
atomically $ updateActiveQueues stats queueId
updateActiveQueues :: ServerStats -> RecipientId -> STM ()
updateActiveQueues stats qId = do
updatePeriod dayMsgQueues
updatePeriod weekMsgQueues
updatePeriod monthMsgQueues
where
updatePeriod pSel = modifyTVar (pSel stats) (S.insert qId)
atomically $ updatePeriodStats (activeQueues stats) queueId
sendMessage :: QueueRec -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
sendMessage qr msgFlags msgBody
@@ -571,7 +551,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
when (sent == OK) $ do
stats <- asks serverStats
atomically $ modifyTVar (msgSent stats) (+ 1)
atomically $ updateActiveQueues stats $ recipientId qr
atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
pure resp
where
mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
@@ -743,7 +723,9 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
liftIO (strDecode <$> B.readFile f) >>= \case
Right d -> do
s <- asks serverStats
atomically $ setServerStatsData s d
atomically $ setServerStats s d
renameFile f $ f <> ".bak"
logInfo "server stats restored"
Left e -> logInfo $ "error restoring server stats: " <> T.pack e
Left e -> do
logInfo $ "error restoring server stats: " <> T.pack e
liftIO exitFailure
+95 -28
View File
@@ -1,5 +1,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Server.Stats where
@@ -8,7 +10,9 @@ 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.Clock (UTCTime)
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
@@ -20,9 +24,7 @@ data ServerStats = ServerStats
qDeleted :: TVar Int,
msgSent :: TVar Int,
msgRecv :: TVar Int,
dayMsgQueues :: TVar (Set RecipientId),
weekMsgQueues :: TVar (Set RecipientId),
monthMsgQueues :: TVar (Set RecipientId)
activeQueues :: PeriodStats RecipientId
}
data ServerStatsData = ServerStatsData
@@ -32,9 +34,7 @@ data ServerStatsData = ServerStatsData
_qDeleted :: Int,
_msgSent :: Int,
_msgRecv :: Int,
_dayMsgQueues :: Set RecipientId,
_weekMsgQueues :: Set RecipientId,
_monthMsgQueues :: Set RecipientId
_activeQueues :: PeriodStatsData RecipientId
}
newServerStats :: UTCTime -> STM ServerStats
@@ -45,10 +45,8 @@ newServerStats ts = do
qDeleted <- newTVar 0
msgSent <- newTVar 0
msgRecv <- newTVar 0
dayMsgQueues <- newTVar S.empty
weekMsgQueues <- newTVar S.empty
monthMsgQueues <- newTVar S.empty
pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, dayMsgQueues, weekMsgQueues, monthMsgQueues}
activeQueues <- newPeriodStats
pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, activeQueues}
getServerStatsData :: ServerStats -> STM ServerStatsData
getServerStatsData s = do
@@ -58,25 +56,21 @@ getServerStatsData s = do
_qDeleted <- readTVar $ qDeleted s
_msgSent <- readTVar $ msgSent s
_msgRecv <- readTVar $ msgRecv s
_dayMsgQueues <- readTVar $ dayMsgQueues s
_weekMsgQueues <- readTVar $ weekMsgQueues s
_monthMsgQueues <- readTVar $ monthMsgQueues s
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues}
_activeQueues <- getPeriodStatsData $ activeQueues s
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues}
setServerStatsData :: ServerStats -> ServerStatsData -> STM ()
setServerStatsData s d = do
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)
writeTVar (dayMsgQueues s) (_dayMsgQueues d)
writeTVar (weekMsgQueues s) (_weekMsgQueues d)
writeTVar (monthMsgQueues s) (_monthMsgQueues d)
setPeriodStats (activeQueues s) (_activeQueues d)
instance StrEncoding ServerStatsData where
strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues} =
strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _activeQueues} =
B.unlines
[ "fromTime=" <> strEncode _fromTime,
"qCreated=" <> strEncode _qCreated,
@@ -84,9 +78,8 @@ instance StrEncoding ServerStatsData where
"qDeleted=" <> strEncode _qDeleted,
"msgSent=" <> strEncode _msgSent,
"msgRecv=" <> strEncode _msgRecv,
"dayMsgQueues=" <> strEncode _dayMsgQueues,
"weekMsgQueues=" <> strEncode _weekMsgQueues,
"monthMsgQueues=" <> strEncode _monthMsgQueues
"activeQueues:",
strEncode _activeQueues
]
strP = do
_fromTime <- "fromTime=" *> strP <* A.endOfLine
@@ -95,7 +88,81 @@ instance StrEncoding ServerStatsData where
_qDeleted <- "qDeleted=" *> strP <* A.endOfLine
_msgSent <- "msgSent=" *> strP <* A.endOfLine
_msgRecv <- "msgRecv=" *> strP <* A.endOfLine
_dayMsgQueues <- "dayMsgQueues=" *> strP <* A.endOfLine
_weekMsgQueues <- "weekMsgQueues=" *> strP <* A.endOfLine
_monthMsgQueues <- "monthMsgQueues=" *> strP <* optional A.endOfLine
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _dayMsgQueues, _weekMsgQueues, _monthMsgQueues}
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)
+1 -1
View File
@@ -99,7 +99,7 @@ supportedSMPServerVRange :: VersionRange
supportedSMPServerVRange = mkVersionRange 1 4
simplexMQVersion :: String
simplexMQVersion = "3.1.1"
simplexMQVersion = "3.2.0"
-- * Transport connection class
+123 -13
View File
@@ -1,43 +1,121 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Transport.Client
( runTransportClient,
runTLSTransportClient,
smpClientHandshake,
defaultSMPPort,
defaultSocksProxy,
SocksProxy,
TransportHost (..),
TransportHosts (..),
TransportHosts_ (..),
)
where
import Control.Applicative (optional)
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Default (def)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.String
import Data.Word (Word8)
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as XS
import Data.X509.Validation (Fingerprint (..))
import qualified Data.X509.Validation as XV
import GHC.IO.Exception (IOErrorType (..))
import Network.Socket
import Network.Socks5
import qualified Network.TLS as T
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll, parseString)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Util (bshow, (<$?>))
import System.IO.Error
import Text.Read (readMaybe)
import UnliftIO.Exception (IOException)
import qualified UnliftIO.Exception as E
data TransportHost
= THIPv4 (Word8, Word8, Word8, Word8)
| THOnionHost ByteString
| THDomainName HostName
deriving (Eq, Ord, Show)
instance Encoding TransportHost where
smpEncode = smpEncode . strEncode
smpP = parseAll strP <$?> smpP
instance StrEncoding TransportHost where
strEncode = \case
THIPv4 (a1, a2, a3, a4) -> B.intercalate "." $ map bshow [a1, a2, a3, a4]
THOnionHost host -> host
THDomainName host -> B.pack host
strP =
A.choice
[ THIPv4 <$> ((,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal),
THOnionHost <$> ((<>) <$> A.takeTill (== '.') <*> A.string ".onion"),
THDomainName . B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
]
where
ipNum = A.decimal <* A.char '.'
instance ToJSON TransportHost where
toEncoding = strToJEncoding
toJSON = strToJSON
newtype TransportHosts = TransportHosts {thList :: NonEmpty TransportHost}
instance StrEncoding TransportHosts where
strEncode = strEncodeList . L.toList . thList
strP = TransportHosts . L.fromList <$> strP `A.sepBy1'` A.char ','
newtype TransportHosts_ = TransportHosts_ {thList_ :: [TransportHost]}
instance StrEncoding TransportHosts_ where
strEncode = strEncodeList . thList_
strP = TransportHosts_ <$> strP `A.sepBy'` A.char ','
instance IsString TransportHost where fromString = parseString strDecode
instance IsString (NonEmpty TransportHost) where fromString = parseString strDecode
-- | Connect to passed TCP host:port and pass handle to the client.
runTransportClient :: (Transport c, MonadUnliftIO m) => HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
runTransportClient :: (Transport c, MonadUnliftIO m) => Maybe SocksProxy -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
runTransportClient = runTLSTransportClient supportedParameters Nothing
runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
runTLSTransportClient tlsParams caStore_ host port keyHash keepAliveOpts client = do
let clientParams = mkTLSClientParams tlsParams caStore_ host port keyHash
c <- liftIO $ startTCPClient host port clientParams keepAliveOpts
runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> Maybe SocksProxy -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
runTLSTransportClient tlsParams caStore_ socksProxy_ host port keyHash keepAliveOpts client = do
let clientParams = mkTLSClientParams tlsParams caStore_ (B.unpack $ strEncode host) port keyHash
connectTCP = case socksProxy_ of
Just proxy -> connectSocksClient proxy $ hostAddr host
_ -> connectTCPClient . B.unpack $ strEncode host
c <- liftIO $ do
sock <- connectTCP port
mapM_ (setSocketKeepAlive sock) keepAliveOpts
connectTLS clientParams sock >>= getClientConnection
client c `E.finally` liftIO (closeConnection c)
where
hostAddr = \case
THIPv4 addr -> SocksAddrIPV4 $ tupleToHostAddress addr
THOnionHost h -> SocksAddrDomainName h
THDomainName h -> SocksAddrDomainName $ B.pack h
startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>= tryOpen err
connectTCPClient :: HostName -> ServiceName -> IO Socket
connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
where
err :: IOException
err = mkIOError NoSuchThing "no address" Nothing Nothing
@@ -47,20 +125,52 @@ startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>
let hints = defaultHints {addrSocketType = Stream}
in getAddrInfo (Just hints) (Just host) (Just port)
tryOpen :: IOException -> [AddrInfo] -> IO c
tryOpen :: IOException -> [AddrInfo] -> IO Socket
tryOpen e [] = E.throwIO e
tryOpen _ (addr : as) =
E.try (open addr) >>= either (`tryOpen` as) pure
open :: AddrInfo -> IO c
open :: AddrInfo -> IO Socket
open addr = do
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
connect sock $ addrAddress addr
mapM_ (setSocketKeepAlive sock) keepAliveOpts
ctx <- connectTLS clientParams sock
getClientConnection ctx
pure sock
-- readCertificateStore :: FilePath -> IO (Maybe CertificateStore)
defaultSMPPort :: PortNumber
defaultSMPPort = 5223
connectSocksClient :: SocksProxy -> SocksHostAddress -> ServiceName -> IO Socket
connectSocksClient (SocksProxy addr) hostAddr _port = do
let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
fst <$> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port)
defaultSocksHost :: HostAddress
defaultSocksHost = tupleToHostAddress (127, 0, 0, 1)
defaultSocksProxy :: SocksProxy
defaultSocksProxy = SocksProxy $ SockAddrInet 9050 defaultSocksHost
newtype SocksProxy = SocksProxy SockAddr
deriving (Eq)
instance Show SocksProxy where show (SocksProxy addr) = show addr
instance StrEncoding SocksProxy where
strEncode = B.pack . show
strP = do
host <- maybe defaultSocksHost tupleToHostAddress <$> optional ipv4P
port <- fromMaybe 9050 <$> optional (A.char ':' *> (fromInteger <$> A.decimal))
pure . SocksProxy $ SockAddrInet port host
where
ipv4P = (,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal
ipNum = A.decimal <* A.char '.'
instance ToJSON SocksProxy where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromJSON SocksProxy where
parseJSON = strParseJSON "SocksProxy"
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
mkTLSClientParams supported caStore_ host port keyHash_ = do
@@ -19,7 +19,7 @@ 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.Client (TransportHost (..), runTLSTransportClient)
import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
import UnliftIO.STM
@@ -122,7 +122,7 @@ sendRequest HTTP2Client {reqQ, config} req = do
runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
runHTTP2Client tlsParams caStore host port keepAliveOpts client =
runTLSTransportClient tlsParams caStore host port Nothing keepAliveOpts $ \c ->
runTLSTransportClient tlsParams caStore Nothing (THDomainName host) port Nothing keepAliveOpts $ \c ->
withTlsConfig c 16384 (`run` client)
where
run = H.run $ ClientConfig "https" (B.pack host) 20
+8 -1
View File
@@ -1,10 +1,15 @@
{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Messaging.Transport.KeepAlive where
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import Foreign.C (CInt (..))
import GHC.Generics (Generic)
import Network.Socket
data KeepAliveOpts = KeepAliveOpts
@@ -12,7 +17,9 @@ data KeepAliveOpts = KeepAliveOpts
keepIntvl :: Int,
keepCnt :: Int
}
deriving (Show)
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON KeepAliveOpts where toEncoding = J.genericToEncoding J.defaultOptions
defaultKeepAliveOpts :: KeepAliveOpts
defaultKeepAliveOpts =
+4
View File
@@ -15,6 +15,7 @@ module Simplex.Messaging.Version
pattern Compatible,
mkVersionRange,
safeVersionRange,
versionToRange,
isCompatible,
proveCompatible,
compatibleVersion,
@@ -53,6 +54,9 @@ safeVersionRange v1 v2
| v1 <= v2 = Just $ VRange v1 v2
| otherwise = Nothing
versionToRange :: Version -> VersionRange
versionToRange v = VRange v v
instance Encoding VersionRange where
smpEncode (VRange v1 v2) = smpEncode (v1, v2)
smpP =
+22 -14
View File
@@ -78,9 +78,17 @@ agentTests (ATransport t) = do
it "should deliver messages if one of connections has quota exceeded" $
smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t
tGetAgent :: Transport c => c -> IO (ATransmissionOrError 'Agent)
tGetAgent h = do
t@(_, _, cmd) <- tGet SAgent h
case cmd of
Right CONNECT {} -> tGetAgent h
Right DISCONNECT {} -> tGetAgent h
_ -> pure t
-- | receive message to handle `h`
(<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
(<#:) = tGet SAgent
(<#:) = tGetAgent
-- | send transmission `t` to handle `h` and get response
(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent)
@@ -114,7 +122,7 @@ h <#= p = (h <#:) >>= (`shouldSatisfy` p . correctTransmission)
h #:# err = tryGet `shouldReturn` ()
where
tryGet =
10000 `timeout` tGet SAgent h >>= \case
10000 `timeout` tGetAgent h >>= \case
Just _ -> error err
_ -> return ()
@@ -126,7 +134,7 @@ 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)
@@ -159,7 +167,7 @@ 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")
@@ -193,9 +201,9 @@ 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)
@@ -206,9 +214,9 @@ testContactConnection _ alice bob tom = do
bob #: ("13", "alice", "ACK 4") #> ("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)
@@ -224,11 +232,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)
@@ -246,7 +254,7 @@ 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)
@@ -387,7 +395,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")
@@ -426,7 +434,7 @@ 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)
@@ -447,7 +455,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)
+33 -25
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 (ProtocolServer (..), supportedSMPClientVRange)
import Simplex.Messaging.Version
import Test.Hspec
@@ -21,15 +21,23 @@ uri = "smp.simplex.im"
srv :: SMPServer
srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251")
queue :: SMPQueueUri
queue =
SMPQueueUri
queueAddr :: SMPQueueAddress
queueAddr =
SMPQueueAddress
{ smpServer = srv,
senderId = "\223\142z\251",
clientVRange = smpClientVRange,
dhPublicKey = testDhKey
}
queueAddrNoPort :: SMPQueueAddress
queueAddrNoPort = queueAddr {smpServer = srv {port = ""}}
queue :: SMPQueueUri
queue = SMPQueueUri supportedSMPClientVRange queueAddr
queueV1 :: SMPQueueUri
queueV1 = SMPQueueUri (mkVersionRange 1 1) queueAddr
testDhKey :: C.PublicKeyX25519
testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
@@ -44,7 +52,7 @@ connReqData =
ConnReqUriData
{ crScheme = simplexChat,
crAgentVRange = mkVersionRange 1 1,
crSmpQueues = [queue]
crSmpQueues = [queueV1]
}
testDhPubKey :: C.PublicKeyX448
@@ -65,40 +73,40 @@ connectionRequest12 :: AConnectionRequestUri
connectionRequest12 =
ACR SCMInvitation $
CRInvitationUri
connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queue, queue]}
connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]}
testE2ERatchetParams13
connectionRequestTests :: Spec
connectionRequestTests =
describe "connection request parsing / serializing" $ do
it "should serialize SMP queue URIs" $ do
strEncode (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
`shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr
strEncode (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort}
`shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri
strEncode queue {clientVRange = mkVersionRange 1 2}
`shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr
`shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri
it "should parse SMP queue URIs" $ do
strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1&dh=" <> testDhKeyStr)
`shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-2&dh=" <> testDhKeyStr)
`shouldBe` Right (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort}
strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr)
`shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}}
`shouldBe` Right (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort}
strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr)
`shouldBe` Right queue
strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc")
`shouldBe` Right queue
strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1-2&dh=" <> testDhKeyStr)
`shouldBe` Right queue {clientVRange = mkVersionRange 1 2}
`shouldBe` Right queueV1
strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-2&extra_param=abc")
`shouldBe` Right queue {clientVRange = mkVersionRange 1 2}
`shouldBe` Right queue
strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr)
`shouldBe` Right queueV1
strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc")
`shouldBe` Right queueV1
it "should serialize connection requests" $ do
strEncode connectionRequest
`shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
<> testDhKeyStrUri
`shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
strEncode connectionRequest12
`shouldBe` "https://simplex.chat/invitation#/?v=1-2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
<> testDhKeyStrUri
<> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
<> testDhKeyStrUri
`shouldBe` "https://simplex.chat/invitation#/?v=1-2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
it "should parse connection requests" $ do
strDecode
+15 -10
View File
@@ -47,7 +47,12 @@ a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t)
a =##> p = a >>= \t -> liftIO (t `shouldSatisfy` p)
get :: MonadIO m => AgentClient -> m (ATransmission 'Agent)
get c = atomically (readTBQueue $ subQ c)
get c = do
t@(_, _, cmd) <- atomically (readTBQueue $ subQ c)
case cmd of
CONNECT {} -> get c
DISCONNECT {} -> get c
_ -> pure t
pattern Msg :: MsgBody -> ACommand 'Agent
pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
@@ -56,7 +61,7 @@ smpCfgV1 :: ProtocolClientConfig
smpCfgV1 = (smpCfg agentCfg) {smpServerVRange = mkVersionRange 1 1}
agentCfgV1 :: AgentConfig
agentCfgV1 = agentCfg {smpAgentVersion = 1, smpAgentVRange = mkVersionRange 1 1, smpCfg = smpCfgV1}
agentCfgV1 = agentCfg {smpAgentVRange = mkVersionRange 1 1, smpClientVRange = mkVersionRange 1 1, smpCfg = smpCfgV1}
functionalAPITests :: ATransport -> Spec
functionalAPITests t = do
@@ -163,7 +168,7 @@ runAgentClientTest alice bob baseId = do
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")
@@ -199,9 +204,9 @@ 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
("", _, REQ invId _ "bob's connInfo") <- get alice
bobId <- acceptContact alice invId "alice's connInfo"
("", _, CONF confId "alice's connInfo") <- get bob
("", _, 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)
@@ -250,7 +255,7 @@ testAsyncInitiatingOffline = do
aliceId <- joinConnection bob cReq "bob's connInfo"
alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
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")
@@ -266,7 +271,7 @@ testAsyncJoiningOfflineBeforeActivation = 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
subscribeConnection bob' aliceId
@@ -287,7 +292,7 @@ testAsyncBothOffline = do
disconnectAgentClient bob
alice' <- liftIO $ getSMPAgentClient agentCfg initAgentServers
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
subscribeConnection bob' aliceId
@@ -316,7 +321,7 @@ testAsyncServerOffline t = do
srv1 `shouldBe` testSMPServer
conns1 `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")
@@ -389,7 +394,7 @@ makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnI
makeConnection alice bob = 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")
+4 -4
View File
@@ -212,7 +212,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
-- establish connection
(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 bob ##> ("", aliceId, INFO "alice's connInfo")
get alice ##> ("", bobId, CON)
@@ -276,7 +276,7 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
aliceId <- joinConnection bob qInfo "bob's connInfo"
liftIO $ print 0
void $ messageNotification apnsQ
("", _, CONF confId "bob's connInfo") <- get alice
("", _, CONF confId _ "bob's connInfo") <- get alice
liftIO $ threadDelay 500000
allowConnection alice bobId confId "alice's connInfo"
liftIO $ print 1
@@ -330,7 +330,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
-- establish connection
(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 bob ##> ("", aliceId, INFO "alice's connInfo")
get alice ##> ("", bobId, CON)
@@ -395,7 +395,7 @@ testChangeToken APNSMockServer {apnsQ} = do
-- establish connection
(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 bob ##> ("", aliceId, INFO "alice's connInfo")
get alice ##> ("", bobId, CON)
+6 -2
View File
@@ -161,6 +161,7 @@ rcvQueue1 =
e2eDhSecret = Nothing,
sndId = Just "2345",
status = New,
smpClientVersion = 1,
clientNtfCreds = Nothing
}
@@ -173,7 +174,8 @@ sndQueue1 =
sndPrivateKey = testPrivateSignKey,
e2ePubKey = Nothing,
e2eDhSecret = testDhSecret,
status = New
status = New,
smpClientVersion = 1
}
testCreateRcvConn :: SpecWith SQLiteStore
@@ -305,7 +307,8 @@ testUpgradeRcvConnToDuplex =
sndPrivateKey = testPrivateSignKey,
e2ePubKey = Nothing,
e2eDhSecret = testDhSecret,
status = New
status = New,
smpClientVersion = 1
}
upgradeRcvConnToDuplex db "conn1" anotherSndQueue
`shouldReturn` Left (SEBadConnType CSnd)
@@ -328,6 +331,7 @@ testUpgradeSndConnToDuplex =
e2eDhSecret = Nothing,
sndId = Just "4567",
status = New,
smpClientVersion = 1,
clientNtfCreds = Nothing
}
upgradeSndConnToDuplex db "conn1" anotherRcvQueue
+14 -6
View File
@@ -24,12 +24,14 @@ 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.List.NonEmpty (NonEmpty)
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 (chooseTransportHost, defaultNetworkConfig)
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
@@ -51,7 +53,7 @@ import qualified UnliftIO.Exception as E
import UnliftIO.STM
import UnliftIO.Timeout (timeout)
testHost :: HostName
testHost :: NonEmpty TransportHost
testHost = "localhost"
ntfTestPort :: ServiceName
@@ -66,9 +68,10 @@ 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 testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
testNtfClient client = do
Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
runTransportClient Nothing host ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
Right th -> client th
Left e -> error $ show e
@@ -94,7 +97,12 @@ ntfServerCfg =
-- CA certificate private key is not needed for initialization
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
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
@@ -128,7 +136,7 @@ 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 :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => (THandle c -> m a) -> m a
runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
ntfServerTest ::
+26 -14
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -9,8 +10,9 @@ module SMPAgentClient where
import Control.Monad.IO.Unlift
import Crypto.Random
import qualified Data.ByteString.Char8 as B
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Network.Socket (HostName, ServiceName)
import Network.Socket (ServiceName)
import NtfClient (ntfTestPort)
import SMPClient
( serverBracket,
@@ -25,7 +27,8 @@ 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 (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig)
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.KeepAlive
@@ -33,7 +36,7 @@ import Test.Hspec
import UnliftIO.Concurrent
import UnliftIO.Directory
agentTestHost :: HostName
agentTestHost :: NonEmpty TransportHost
agentTestHost = "localhost"
agentTestPort :: ServiceName
@@ -55,14 +58,21 @@ testDB3 :: String
testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
smpAgentTest :: forall c. Transport c => TProxy c -> ARawTransmission -> IO ARawTransmission
smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> tGetRaw h
smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> get h
where
get h = do
t@(_, _, cmdStr) <- tGetRaw h
case parseAll commandP cmdStr of
Right (ACmd SAgent CONNECT {}) -> get h
Right (ACmd SAgent DISCONNECT {}) -> get h
_ -> pure t
runSmpAgentTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (c -> m a) -> m a
runSmpAgentTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => (c -> m a) -> m a
runSmpAgentTest test = withSmpServer t . withSmpAgent t $ testSMPAgentClient test
where
t = transport @c
runSmpAgentServerTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => ((ThreadId, ThreadId) -> c -> m a) -> m a
runSmpAgentServerTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => ((ThreadId, ThreadId) -> c -> m a) -> m a
runSmpAgentServerTest test =
withSmpServerThreadOn t testPort $
\server -> withSmpAgentThreadOn t (agentTestPort, testPort, testDB) $
@@ -73,7 +83,7 @@ runSmpAgentServerTest test =
smpAgentServerTest :: Transport c => ((ThreadId, ThreadId) -> c -> IO ()) -> Expectation
smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` ()
runSmpAgentTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => [(ServiceName, ServiceName, String)] -> ([c] -> m a) -> m a
runSmpAgentTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => [(ServiceName, ServiceName, String)] -> ([c] -> m a) -> m a
runSmpAgentTestN agents test = withSmpServer t $ run agents []
where
run :: [(ServiceName, ServiceName, String)] -> [c] -> m a
@@ -81,7 +91,7 @@ runSmpAgentTestN agents test = withSmpServer t $ run agents []
run (a@(p, _, _) : as) hs = withSmpAgentOn t a $ testSMPAgentClientOn p $ \h -> run as (h : hs)
t = transport @c
runSmpAgentTestN_1 :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => Int -> ([c] -> m a) -> m a
runSmpAgentTestN_1 :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => Int -> ([c] -> m a) -> m a
runSmpAgentTestN_1 nClients test = withSmpServer t . withSmpAgent t $ run nClients []
where
run :: Int -> [c] -> m a
@@ -165,7 +175,8 @@ initAgentServers :: InitialAgentServers
initAgentServers =
InitialAgentServers
{ smp = L.fromList [testSMPServer],
ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"],
netCfg = defaultNetworkConfig {tcpTimeout = 500_000}
}
initAgentServers2 :: InitialAgentServers
@@ -175,13 +186,13 @@ agentCfg :: AgentConfig
agentCfg =
defaultAgentConfig
{ tcpPort = agentTestPort,
tbqSize = 1,
tbqSize = 4,
dbFile = testDB,
smpCfg =
defaultClientConfig
{ qSize = 1,
defaultTransport = (testPort, transport @TLS),
tcpTimeout = 500_000
networkConfig = defaultNetworkConfig {tcpTimeout = 500_000}
},
ntfCfg =
defaultClientConfig
@@ -213,14 +224,15 @@ withSmpAgentOn t (port', smpPort', db') = withSmpAgentThreadOn t (port', smpPort
withSmpAgent :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a
testSMPAgentClientOn :: (Transport c, MonadUnliftIO m, MonadFail m) => ServiceName -> (c -> m a) -> m a
testSMPAgentClientOn port' client = do
runTransportClient agentTestHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig agentTestHost
runTransportClient Nothing useHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do
line <- liftIO $ getLn h
if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
then client h
else do
error $ "wrong welcome message: " <> B.unpack line
testSMPAgentClient :: (Transport c, MonadUnliftIO m) => (c -> m a) -> m a
testSMPAgentClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (c -> m a) -> m a
testSMPAgentClient = testSMPAgentClientOn agentTestPort
+9 -6
View File
@@ -14,7 +14,9 @@ import Control.Monad.Except (runExceptT)
import Control.Monad.IO.Unlift
import Crypto.Random
import Data.ByteString.Char8 (ByteString)
import Data.List.NonEmpty (NonEmpty)
import Network.Socket
import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Protocol
@@ -30,7 +32,7 @@ import qualified UnliftIO.Exception as E
import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar)
import UnliftIO.Timeout (timeout)
testHost :: HostName
testHost :: NonEmpty TransportHost
testHost = "localhost"
testPort :: ServiceName
@@ -54,9 +56,10 @@ 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 testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
testSMPClient client = do
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
runTransportClient Nothing useHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case
Right th -> client th
Left e -> error $ show e
@@ -125,10 +128,10 @@ withSmpServerOn t port' = withSmpServerThreadOn t port' . const
withSmpServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
withSmpServer t = withSmpServerOn t testPort
runSmpTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (THandle c -> m a) -> m a
runSmpTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => (THandle c -> m a) -> m a
runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
runSmpTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => Int -> ([THandle c] -> m a) -> m a
runSmpTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m, MonadFail m) => Int -> ([THandle c] -> m a) -> m a
runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients []
where
run :: Int -> [THandle c] -> m a