mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-31 09:38:24 +00:00
Compare commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
180b4b9dcb | ||
|
|
0437796232 | ||
|
|
02bba01c16 | ||
|
|
68138c08d2 | ||
|
|
6bfaa4985e | ||
|
|
7d99c4b35c | ||
|
|
e9db0a1162 | ||
|
|
b8c23ea8d5 | ||
|
|
b76ef03dbe | ||
|
|
fcaddb7848 | ||
|
|
d788c3ca95 | ||
|
|
e07121266a | ||
|
|
2f39f055c1 | ||
|
|
5d06dde757 | ||
|
|
eb1f9370c1 | ||
|
|
d810db4eed | ||
|
|
d8f07e8dde |
@@ -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:
|
||||
|
||||
@@ -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 agent design
|
||||
|
||||

|
||||

|
||||
|
||||
## License
|
||||
|
||||
[AGPL v3](https://github.com/simplex-chat/simplexmq/blob/master/LICENSE)
|
||||
[AGPL v3](./LICENSE)
|
||||
|
||||
+32
-21
@@ -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"
|
||||
}
|
||||
}
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -2,7 +2,6 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Main where
|
||||
|
||||
|
||||
File diff suppressed because one or more lines are too long
|
After Width: | Height: | Size: 8.1 KiB |
+1
-1
@@ -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
@@ -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.*
|
||||
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -0,0 +1 @@
|
||||
smp-server configuration, certificate and fingerprint will be stored here
|
||||
Executable
+23
@@ -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
|
||||
@@ -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
@@ -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.*
|
||||
|
||||
@@ -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
|
||||
}
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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}
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -99,7 +99,7 @@ supportedSMPServerVRange :: VersionRange
|
||||
supportedSMPServerVRange = mkVersionRange 1 4
|
||||
|
||||
simplexMQVersion :: String
|
||||
simplexMQVersion = "3.1.1"
|
||||
simplexMQVersion = "3.2.0"
|
||||
|
||||
-- * Transport connection class
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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")
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
@@ -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
@@ -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
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user