mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-01 02:58:24 +00:00
Compare commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
dc920d90d9 | ||
|
|
f53c1f5559 | ||
|
|
0942bf9f1e | ||
|
|
57fc190a91 | ||
|
|
43fb513ef7 | ||
|
|
fbccca9947 | ||
|
|
40000047af | ||
|
|
c2342cba05 | ||
|
|
f3b6ed4db0 | ||
|
|
95db734b2d | ||
|
|
e281efdcb8 |
@@ -1,3 +1,18 @@
|
||||
# 4.0.0
|
||||
|
||||
SMP server:
|
||||
|
||||
- Basic authentication. The server address can now include an optional password that is required to create messaging queues, so the contacts who message you will not be able to receive messages via your server, unless you share with them the address with the password. It is recommended to enable basic authentication on all private servers by adding `create_password` parameter into AUTH section of server INI file (the previously deployed servers do not have this section, you need to add it).
|
||||
- Disable creating new queues completely with `new_queues: off` parameter in AUTH section of INI file - it can be used to simplify migrating the exising connections to another server.
|
||||
- Updated server CLI with changed defaults:
|
||||
- interactive server initialization, use -y flag to initalize the server non-interactively.
|
||||
- store log is now enabled by default, so messaging queues and messages are restored when the server is restarted (to restore undelivered messages the server needs to be stopped with SIGINT signal).
|
||||
- a random password is now generated by default during the server initialization.
|
||||
|
||||
SMP agent:
|
||||
|
||||
- API to test SMP servers. It connects to the server, creates and deletes a messaging queue. The new SimpleX Chat client uses this API to allow you to test that you have the correct server address, with the valid certificate fingerprint and pasword, before enabling the new server.
|
||||
|
||||
# 3.4.0
|
||||
|
||||
SMP agent:
|
||||
|
||||
@@ -94,15 +94,92 @@ It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.
|
||||
|
||||
You can run your SMP server as a Linux process, optionally using a service manager for booting and restarts.
|
||||
|
||||
- For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
|
||||
Notice that `smp-server` requires `openssl` as run-time dependency (it is used to generate server certificates during initialization). Install it with your packet manager:
|
||||
|
||||
If you're using other Linux distribution and the binary is incompatible with it, you can build from source using [Haskell stack](https://docs.haskellstack.org/en/stable/README/):
|
||||
```sh
|
||||
# For Ubuntu
|
||||
apt update && apt install openssl
|
||||
```
|
||||
|
||||
```shell
|
||||
curl -sSL https://get.haskellstack.org/ | sh
|
||||
...
|
||||
stack install
|
||||
```
|
||||
### Install binaries
|
||||
|
||||
#### Using Docker
|
||||
|
||||
On Linux, you can deploy smp server using Docker.
|
||||
|
||||
1. Build your `smp-server` image:
|
||||
|
||||
```sh
|
||||
git clone https://github.com/simplex-chat/simplexmq
|
||||
cd simplexmq
|
||||
git checkout stable
|
||||
DOCKER_BUILDKIT=1 docker build -t smp-server -f ./download.Dockerfile .
|
||||
```
|
||||
2. Run your Docker container:
|
||||
```sh
|
||||
docker run -d \
|
||||
--name smp-server \
|
||||
-e addr="your_ip_or_domain" \
|
||||
-p 5223:5223 \
|
||||
-v ${PWD}/scripts/docker/config:/etc/opt/simplex \
|
||||
-v ${PWD}/scripts/docker/logs:/var/opt/simplex \
|
||||
smp-server
|
||||
```
|
||||
|
||||
#### Ubuntu
|
||||
|
||||
For Ubuntu you can download a binary from [the latest release](https://github.com/simplex-chat/simplexmq/releases).
|
||||
|
||||
### Build from source
|
||||
|
||||
#### Using Docker
|
||||
|
||||
> **Please note:** to build the app use source code from [stable branch](https://github.com/simplex-chat/simplexmq/tree/stable).
|
||||
|
||||
On Linux, you can build smp server using Docker.
|
||||
|
||||
1. Build your `smp-server` image:
|
||||
|
||||
```sh
|
||||
git clone https://github.com/simplex-chat/simplexmq
|
||||
cd simplexmq
|
||||
git checkout stable
|
||||
DOCKER_BUILDKIT=1 docker build -t smp-server -f ./build.Dockerfile .
|
||||
```
|
||||
2. Run your Docker container:
|
||||
```sh
|
||||
docker run -d \
|
||||
--name smp-server \
|
||||
-e addr="your_ip_or_domain" \
|
||||
-p 5223:5223 \
|
||||
-v ${PWD}/scripts/docker/config:/etc/opt/simplex \
|
||||
-v ${PWD}/scripts/docker/logs:/var/opt/simplex \
|
||||
smp-server
|
||||
```
|
||||
|
||||
#### Using your distribution
|
||||
|
||||
1. Install [Haskell GHCup](https://www.haskell.org/ghcup/), GHC 8.10.7 and cabal:
|
||||
|
||||
```sh
|
||||
curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
|
||||
ghcup install ghc 8.10.7
|
||||
ghcup install cabal
|
||||
ghcup set ghc 8.10.7
|
||||
ghcup set cabal
|
||||
```
|
||||
|
||||
2. Build the project:
|
||||
|
||||
```sh
|
||||
git clone https://github.com/simplex-chat/simplexmq
|
||||
cd simplexmq
|
||||
git checkout stable
|
||||
# On Ubuntu. Depending on your distribution, use your package manager to determine package names.
|
||||
apt-get update && apt-get install -y build-essential libgmp3-dev zlib1g-dev
|
||||
cabal update
|
||||
cabal install
|
||||
```
|
||||
|
||||
- Initialize SMP server with `smp-server init [-l] -n <fqdn>` or `smp-server init [-l] --ip <ip>` - depending on how you initialize it, either FQDN or IP will be used for server's address.
|
||||
|
||||
@@ -112,14 +189,6 @@ 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="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
|
||||
|
||||
+2
-72
@@ -1,18 +1,7 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Logger.Simple
|
||||
import Data.Functor (($>))
|
||||
import Data.Ini (lookupValue)
|
||||
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
|
||||
import Simplex.Messaging.Notifications.Server (runNtfServer)
|
||||
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
|
||||
import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI)
|
||||
import System.FilePath (combine)
|
||||
import Simplex.Messaging.Notifications.Server.Main
|
||||
|
||||
cfgPath :: FilePath
|
||||
cfgPath = "/etc/opt/simplex-notifications"
|
||||
@@ -26,63 +15,4 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
|
||||
main :: IO ()
|
||||
main = do
|
||||
setLogLevel LogDebug -- change to LogError in production
|
||||
withGlobalLogging logCfg $ protocolServerCLI ntfServerCLIConfig runNtfServer
|
||||
|
||||
ntfServerCLIConfig :: ServerCLIConfig NtfServerConfig
|
||||
ntfServerCLIConfig =
|
||||
let caCrtFile = combine cfgPath "ca.crt"
|
||||
serverKeyFile = combine cfgPath "server.key"
|
||||
serverCrtFile = combine cfgPath "server.crt"
|
||||
in ServerCLIConfig
|
||||
{ cfgDir = cfgPath,
|
||||
logDir = logPath,
|
||||
iniFile = combine cfgPath "ntf-server.ini",
|
||||
storeLogFile = combine logPath "ntf-server-store.log",
|
||||
caKeyFile = combine cfgPath "ca.key",
|
||||
caCrtFile,
|
||||
serverKeyFile,
|
||||
serverCrtFile,
|
||||
fingerprintFile = combine cfgPath "fingerprint",
|
||||
defaultServerPort = "443",
|
||||
executableName = "ntf-server",
|
||||
serverVersion = "SMP notifications server v1.2.0",
|
||||
mkIniFile = \enableStoreLog defaultServerPort ->
|
||||
"[STORE_LOG]\n\
|
||||
\# The server uses STM memory for persistence,\n\
|
||||
\# that will be lost on restart (e.g., as with redis).\n\
|
||||
\# This option enables saving memory to append only log,\n\
|
||||
\# and restoring it when the server is started.\n\
|
||||
\# Log is compacted on start (deleted objects are removed).\n\
|
||||
\enable: "
|
||||
<> (if enableStoreLog then "on" else "off")
|
||||
<> "\n\
|
||||
\log_stats: off\n\n\
|
||||
\[TRANSPORT]\n\
|
||||
\port: "
|
||||
<> defaultServerPort
|
||||
<> "\n\
|
||||
\websockets: off\n",
|
||||
mkServerConfig = \storeLogFile transports ini ->
|
||||
let settingIsOn section name = if lookupValue section name ini == Right "on" then Just () else Nothing
|
||||
logStats = settingIsOn "STORE_LOG" "log_stats"
|
||||
in NtfServerConfig
|
||||
{ transports,
|
||||
subIdBytes = 24,
|
||||
regCodeBytes = 32,
|
||||
clientQSize = 16,
|
||||
subQSize = 64,
|
||||
pushQSize = 128,
|
||||
smpAgentCfg = defaultSMPClientAgentConfig,
|
||||
apnsConfig = defaultAPNSPushClientConfig,
|
||||
inactiveClientExpiration = Nothing,
|
||||
storeLogFile,
|
||||
resubscribeDelay = 50000, -- 50ms
|
||||
caCertificateFile = caCrtFile,
|
||||
privateKeyFile = serverKeyFile,
|
||||
certificateFile = serverCrtFile,
|
||||
logStatsInterval = logStats $> 86400, -- seconds
|
||||
logStatsStartTime = 0, -- seconds from 00:00 UTC
|
||||
serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
|
||||
serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log"
|
||||
}
|
||||
}
|
||||
withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath
|
||||
|
||||
+2
-93
@@ -1,19 +1,7 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Logger.Simple
|
||||
import Data.Functor (($>))
|
||||
import Data.Ini (lookupValue)
|
||||
import Simplex.Messaging.Server (runSMPServer)
|
||||
import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI, readStrictIni)
|
||||
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
|
||||
import System.FilePath (combine)
|
||||
import Simplex.Messaging.Server.Main
|
||||
|
||||
cfgPath :: FilePath
|
||||
cfgPath = "/etc/opt/simplex"
|
||||
@@ -27,83 +15,4 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
|
||||
main :: IO ()
|
||||
main = do
|
||||
setLogLevel LogDebug
|
||||
withGlobalLogging logCfg . protocolServerCLI smpServerCLIConfig $ \cfg@ServerConfig {inactiveClientExpiration} -> do
|
||||
putStrLn $ case inactiveClientExpiration of
|
||||
Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
|
||||
_ -> "not expiring inactive clients"
|
||||
runSMPServer cfg
|
||||
|
||||
smpServerCLIConfig :: ServerCLIConfig ServerConfig
|
||||
smpServerCLIConfig =
|
||||
let caCrtFile = combine cfgPath "ca.crt"
|
||||
serverKeyFile = combine cfgPath "server.key"
|
||||
serverCrtFile = combine cfgPath "server.crt"
|
||||
in ServerCLIConfig
|
||||
{ cfgDir = cfgPath,
|
||||
logDir = logPath,
|
||||
iniFile = combine cfgPath "smp-server.ini",
|
||||
storeLogFile = combine logPath "smp-server-store.log",
|
||||
caKeyFile = combine cfgPath "ca.key",
|
||||
caCrtFile,
|
||||
serverKeyFile,
|
||||
serverCrtFile,
|
||||
fingerprintFile = combine cfgPath "fingerprint",
|
||||
defaultServerPort = "5223",
|
||||
executableName = "smp-server",
|
||||
serverVersion = "SMP server v" <> simplexMQVersion,
|
||||
mkIniFile = \enableStoreLog defaultServerPort ->
|
||||
"[STORE_LOG]\n\
|
||||
\# The server uses STM memory for persistence,\n\
|
||||
\# that will be lost on restart (e.g., as with redis).\n\
|
||||
\# This option enables saving memory to append only log,\n\
|
||||
\# and restoring it when the server is started.\n\
|
||||
\# Log is compacted on start (deleted objects are removed).\n"
|
||||
<> ("enable: " <> (if enableStoreLog then "on" else "off") <> "\n")
|
||||
<> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
|
||||
\# they are preserved in the .bak file until the next restart.\n"
|
||||
<> ("restore_messages: " <> (if enableStoreLog then "on" else "off") <> "\n")
|
||||
<> ("log_stats: off\n\n")
|
||||
<> "[TRANSPORT]\n"
|
||||
<> ("port: " <> defaultServerPort <> "\n")
|
||||
<> "websockets: off\n\n"
|
||||
<> "[INACTIVE_CLIENTS]\n\
|
||||
\# TTL and interval to check inactive clients\n\
|
||||
\disconnect: off\n"
|
||||
<> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
|
||||
<> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n"),
|
||||
mkServerConfig = \storeLogFile transports ini ->
|
||||
let settingIsOn section name = if lookupValue section name ini == Right "on" then Just () else Nothing
|
||||
logStats = settingIsOn "STORE_LOG" "log_stats"
|
||||
in ServerConfig
|
||||
{ transports,
|
||||
tbqSize = 16,
|
||||
serverTbqSize = 64,
|
||||
msgQueueQuota = 128,
|
||||
queueIdBytes = 24,
|
||||
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
|
||||
caCertificateFile = caCrtFile,
|
||||
privateKeyFile = serverKeyFile,
|
||||
certificateFile = serverCrtFile,
|
||||
storeLogFile,
|
||||
storeMsgsFile =
|
||||
let messagesPath = combine logPath "smp-server-messages.log"
|
||||
in case lookupValue "STORE_LOG" "restore_messages" ini of
|
||||
Right "on" -> Just messagesPath
|
||||
Right _ -> Nothing
|
||||
-- if the setting is not set, it is enabled when store log is enabled
|
||||
_ -> storeLogFile $> messagesPath,
|
||||
allowNewQueues = True,
|
||||
messageExpiration = Just defaultMessageExpiration,
|
||||
inactiveClientExpiration =
|
||||
settingIsOn "INACTIVE_CLIENTS" "disconnect"
|
||||
$> ExpirationConfig
|
||||
{ ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
|
||||
checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
|
||||
},
|
||||
logStatsInterval = logStats $> 86400, -- seconds
|
||||
logStatsStartTime = 0, -- seconds from 00:00 UTC
|
||||
serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
|
||||
serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
|
||||
smpServerVRange = supportedSMPServerVRange
|
||||
}
|
||||
}
|
||||
withGlobalLogging logCfg $ smpServerCLI cfgPath logPath
|
||||
|
||||
@@ -11,17 +11,15 @@ RUN curl https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup -o /usr/bin/ghc
|
||||
chmod +x /usr/bin/ghcup
|
||||
|
||||
# Install ghc
|
||||
RUN ghcup install ghc
|
||||
RUN ghcup install ghc 8.10.7
|
||||
# Install cabal
|
||||
RUN ghcup install cabal
|
||||
# Set both as default
|
||||
RUN ghcup set ghc && \
|
||||
RUN ghcup set ghc 8.10.7 && \
|
||||
ghcup set cabal
|
||||
|
||||
# Clone simplexmq repository
|
||||
RUN git clone https://github.com/simplex-chat/simplexmq
|
||||
# and cd to it
|
||||
WORKDIR ./simplexmq
|
||||
COPY . /project
|
||||
WORKDIR /project
|
||||
|
||||
# Adjust PATH
|
||||
ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH"
|
||||
@@ -41,7 +39,7 @@ RUN apt-get update && apt-get install -y openssl
|
||||
COPY --from=build /root/.cabal/bin/smp-server /usr/bin/smp-server
|
||||
|
||||
# Copy our helper script
|
||||
COPY ./entrypoint /usr/bin/entrypoint
|
||||
COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
|
||||
|
||||
# Open smp-server listening port
|
||||
EXPOSE 5223
|
||||
@@ -8,7 +8,7 @@ RUN curl -L https://github.com/simplex-chat/simplexmq/releases/latest/download/s
|
||||
chmod +x /usr/bin/smp-server
|
||||
|
||||
# Copy our helper script
|
||||
COPY ./entrypoint /usr/bin/entrypoint
|
||||
COPY ./scripts/docker/entrypoint /usr/bin/entrypoint
|
||||
|
||||
# Open smp-server listening port
|
||||
EXPOSE 5223
|
||||
File diff suppressed because one or more lines are too long
|
Before Width: | Height: | Size: 8.1 KiB |
+3
-1
@@ -1,5 +1,5 @@
|
||||
name: simplexmq
|
||||
version: 3.4.0
|
||||
version: 4.0.0
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: |
|
||||
This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
@@ -121,6 +121,8 @@ tests:
|
||||
- hspec-core == 2.7.*
|
||||
- HUnit == 1.6.*
|
||||
- QuickCheck == 2.14.*
|
||||
- silently == 1.2.*
|
||||
- main-tester == 0.2.*
|
||||
- timeit == 2.0.*
|
||||
|
||||
ghc-options:
|
||||
|
||||
@@ -0,0 +1,27 @@
|
||||
# SMP Basic Auth
|
||||
|
||||
## Problem
|
||||
|
||||
Users who host their own servers do not want unknown people to be able to create messaging queues on their servers after discovering server address in groups or after making a connection. As the number of self-hosted servers is growing it became more important than it was when we excluded it from the original design.
|
||||
|
||||
## Solution
|
||||
|
||||
Single access password that can be optionally included in server address that is passed to app configuration. It will not be allowed in the existing contexts (and parsing will fail), to avoid accidentally leaking it. Server address with password will look this way: `smp://fingerprint:password@hosts`
|
||||
|
||||
## Implementation plan
|
||||
|
||||
1. A separate type to include server and password, so it can only be used where allowed.
|
||||
|
||||
2. Server password to create queues will be configured in TRANSPORT section of INI file, as `create_password` parameter.
|
||||
|
||||
3. The password will only be required in server configuration/address to create queues only, it won't be required for other receiving queue operations on already existing queues.
|
||||
|
||||
4. If new command is attempted in the session that does not allow creating queues, the server will send `ERR AUTH` response
|
||||
|
||||
5. Passing password to the server can be done in one of the several ways, we need to decide:
|
||||
|
||||
- as a parameter of NEW command. Pros: a local change, that only needs checking when queue is created. Cons: protocol version change.
|
||||
- as a separate command AUTH. Pros: allows to include additional parameters and potentially be extended beyond basic auth. Cons: more complex to manage server state, can be more difficult syntax in the future, if extended.
|
||||
- as part of handshake (we currently ignore the unparsed part of handshake block, so it can be extended). Pros: probably, the simplest, and independent of the commands protocol – establishes create permission for the current session. Cons: the client won't know about whether it is able to create the queue until it tries (same as in case 1).
|
||||
|
||||
My preference is the last option. As a variant of the last option, we can add a server response/message that includes permission to create queues - it will only be sent to the clients who pass credential in handshake - that might simplify testing server connection (we currently do not do it). It might be unnecessary, as we could simply create and delete queue in case credential is passed as part of testing connection (and even sending a message to it).
|
||||
@@ -1,25 +0,0 @@
|
||||
# smp-server docker container
|
||||
0. Install `docker` to your host.
|
||||
|
||||
1. Build your `smp-server` image:
|
||||
- **Option 1** - Compile `smp-server` from source (stable branch):
|
||||
```sh
|
||||
DOCKER_BUILDKIT=1 docker build -t smp-server -f smp-server-build.Dockerfile .
|
||||
```
|
||||
- **Option 2** - Download latest `smp-server` from [latest Github release](https://github.com/simplex-chat/simplexmq/releases/latest):
|
||||
```sh
|
||||
DOCKER_BUILDKIT=1 docker build -t smp-server -f smp-server-download.Dockerfile .
|
||||
```
|
||||
|
||||
2. Run new docker container:
|
||||
```sh
|
||||
docker run -d \
|
||||
--name smp-server \
|
||||
-e addr="your_ip_or_domain" \
|
||||
-p 5223:5223 \
|
||||
-v ${PWD}/config:/etc/opt/simplex \
|
||||
-v ${PWD}/logs:/var/opt/simplex \
|
||||
smp-server
|
||||
```
|
||||
|
||||
Configuration files and logs will be written to [`config`](./config) and [`logs`](./logs) folders respectively.
|
||||
@@ -1 +0,0 @@
|
||||
smp-server configuration, certificate and fingerprint will be stored here
|
||||
@@ -7,8 +7,8 @@ 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" ;;
|
||||
*[a-zA-Z]*) smp-server init -y -l -n "$addr" ;;
|
||||
*) smp-server init -y -l --ip "$addr" ;;
|
||||
esac
|
||||
|
||||
fi
|
||||
|
||||
@@ -1 +0,0 @@
|
||||
smp-server general logs, stored messages and statistics (if enabled) will be stored here
|
||||
+6
-1
@@ -5,7 +5,7 @@ cabal-version: 1.12
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: simplexmq
|
||||
version: 3.4.0
|
||||
version: 4.0.0
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
<./docs/Simplex-Messaging-Client.html client> and
|
||||
@@ -66,6 +66,7 @@ library
|
||||
Simplex.Messaging.Notifications.Protocol
|
||||
Simplex.Messaging.Notifications.Server
|
||||
Simplex.Messaging.Notifications.Server.Env
|
||||
Simplex.Messaging.Notifications.Server.Main
|
||||
Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
Simplex.Messaging.Notifications.Server.Stats
|
||||
Simplex.Messaging.Notifications.Server.Store
|
||||
@@ -78,6 +79,7 @@ library
|
||||
Simplex.Messaging.Server.CLI
|
||||
Simplex.Messaging.Server.Env.STM
|
||||
Simplex.Messaging.Server.Expiration
|
||||
Simplex.Messaging.Server.Main
|
||||
Simplex.Messaging.Server.MsgStore
|
||||
Simplex.Messaging.Server.MsgStore.STM
|
||||
Simplex.Messaging.Server.QueueStore
|
||||
@@ -351,6 +353,7 @@ test-suite smp-server-test
|
||||
AgentTests.NotificationTests
|
||||
AgentTests.SchemaDump
|
||||
AgentTests.SQLiteTests
|
||||
CLITests
|
||||
CoreTests.CryptoTests
|
||||
CoreTests.EncodingTests
|
||||
CoreTests.ProtocolErrorTests
|
||||
@@ -393,6 +396,7 @@ test-suite smp-server-test
|
||||
, http2 ==3.0.*
|
||||
, ini ==0.4.1
|
||||
, iso8601-time ==0.1.*
|
||||
, main-tester ==0.2.*
|
||||
, memory ==0.15.*
|
||||
, mtl ==2.2.*
|
||||
, network >=3.1.2.7 && <3.2
|
||||
@@ -400,6 +404,7 @@ test-suite smp-server-test
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, silently ==1.2.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplexmq
|
||||
, socks ==0.6.*
|
||||
|
||||
@@ -63,6 +63,7 @@ module Simplex.Messaging.Agent
|
||||
deleteConnection,
|
||||
getConnectionServers,
|
||||
setSMPServers,
|
||||
testSMPServerConnection,
|
||||
setNtfServers,
|
||||
setNetworkConfig,
|
||||
getNetworkConfig,
|
||||
@@ -120,7 +121,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Parsers (parse)
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, sameSrvAddr)
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, sameSrvAddr, sameSrvAddr')
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util
|
||||
@@ -248,9 +249,13 @@ getConnectionServers :: AgentErrorMonad m => AgentClient -> ConnId -> m Connecti
|
||||
getConnectionServers c = withAgentEnv c . getConnectionServers' c
|
||||
|
||||
-- | Change servers to be used for creating new queues
|
||||
setSMPServers :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServer -> m ()
|
||||
setSMPServers :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m ()
|
||||
setSMPServers c = withAgentEnv c . setSMPServers' c
|
||||
|
||||
-- | Test SMP server
|
||||
testSMPServerConnection :: AgentErrorMonad m => AgentClient -> SMPServerWithAuth -> m (Maybe SMPTestFailure)
|
||||
testSMPServerConnection c = withAgentEnv c . runSMPServerTest c
|
||||
|
||||
setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m ()
|
||||
setNtfServers c = withAgentEnv c . setNtfServers' c
|
||||
|
||||
@@ -430,7 +435,7 @@ newConn :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> SConnectionM
|
||||
newConn c connId asyncMode enableNtfs cMode clientData =
|
||||
getSMPServer c >>= newConnSrv c connId asyncMode enableNtfs cMode clientData
|
||||
|
||||
newConnSrv :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServer -> m (ConnId, ConnectionRequestUri c)
|
||||
newConnSrv :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c)
|
||||
newConnSrv c connId asyncMode enableNtfs cMode clientData srv = do
|
||||
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
|
||||
(q, qUri) <- newRcvQueue c "" srv smpClientVRange
|
||||
@@ -464,7 +469,7 @@ joinConn c connId asyncMode enableNtfs cReq cInfo = do
|
||||
_ -> getSMPServer c
|
||||
joinConnSrv c connId asyncMode enableNtfs cReq cInfo srv
|
||||
|
||||
joinConnSrv :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> SMPServer -> m ConnId
|
||||
joinConnSrv :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> SMPServerWithAuth -> m ConnId
|
||||
joinConnSrv c connId asyncMode enableNtfs (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) cInfo srv = do
|
||||
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
|
||||
case ( qUri `compatibleVersion` smpClientVRange,
|
||||
@@ -516,7 +521,7 @@ joinConnSrv c connId False enableNtfs (CRContactUri ConnReqUriData {crAgentVRang
|
||||
joinConnSrv _c _connId True _enableNtfs (CRContactUri _) _cInfo _srv = do
|
||||
throwError $ CMD PROHIBITED
|
||||
|
||||
createReplyQueue :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServer -> m SMPQueueInfo
|
||||
createReplyQueue :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> m SMPQueueInfo
|
||||
createReplyQueue c ConnData {connId, enableNtfs} SndQueue {smpClientVersion} srv = do
|
||||
(rq, qUri) <- newRcvQueue c connId srv $ versionToRange smpClientVersion
|
||||
let qInfo = toVersionT qUri smpClientVersion
|
||||
@@ -880,15 +885,15 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
|
||||
internalErr s = cmdError $ INTERNAL $ s <> ": " <> show (agentCommandTag command)
|
||||
cmdError e = notify (ERR e) >> withStore' c (`deleteCommand` cmdId)
|
||||
notify cmd = atomically $ writeTBQueue subQ (corrId, connId, cmd)
|
||||
withNextSrv :: TVar [SMPServer] -> [SMPServer] -> (SMPServer -> m ()) -> m ()
|
||||
withNextSrv :: TVar [SMPServer] -> [SMPServer] -> (SMPServerWithAuth -> m ()) -> m ()
|
||||
withNextSrv usedSrvs initUsed action = do
|
||||
used <- readTVarIO usedSrvs
|
||||
srv <- getNextSMPServer c used
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c used
|
||||
atomically $ do
|
||||
srvs <- readTVar $ smpServers c
|
||||
let used' = if length used + 1 >= L.length srvs then initUsed else srv : used
|
||||
writeTVar usedSrvs used'
|
||||
action srv
|
||||
action srvAuth
|
||||
-- ^ ^ ^ async command processing /
|
||||
|
||||
enqueueMessages :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
|
||||
@@ -1124,8 +1129,8 @@ switchConnection' c connId = withConnLock c connId "switchConnection" $ do
|
||||
DuplexConnection cData rqs@(rq@RcvQueue {server, dbQueueId, sndId} :| rqs_) sqs -> do
|
||||
clientVRange <- asks $ smpClientVRange . config
|
||||
-- try to get the server that is different from all queues, or at least from the primary rcv queue
|
||||
srv <- getNextSMPServer c $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
|
||||
srv' <- if srv == server then getNextSMPServer c [server] else pure srv
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
|
||||
srv' <- if srv == server then getNextSMPServer c [server] else pure srvAuth
|
||||
(q, qUri) <- newRcvQueue c connId srv' clientVRange
|
||||
let rq' = (q :: RcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
void . withStore c $ \db -> addConnRcvQueue db connId rq'
|
||||
@@ -1191,7 +1196,7 @@ connectionStats = \case
|
||||
NewConnection _ -> ConnectionStats {rcvServers = [], sndServers = []}
|
||||
|
||||
-- | Change servers to be used for creating new queues, in Reader monad
|
||||
setSMPServers' :: AgentMonad m => AgentClient -> NonEmpty SMPServer -> m ()
|
||||
setSMPServers' :: AgentMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m ()
|
||||
setSMPServers' c = atomically . writeTVar (smpServers c)
|
||||
|
||||
registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
|
||||
@@ -1436,20 +1441,20 @@ debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs} = do
|
||||
where
|
||||
getLocks ls = atomically $ M.mapKeys (B.unpack . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls)
|
||||
|
||||
getSMPServer :: AgentMonad m => AgentClient -> m SMPServer
|
||||
getSMPServer :: AgentMonad m => AgentClient -> m SMPServerWithAuth
|
||||
getSMPServer c = readTVarIO (smpServers c) >>= pickServer
|
||||
|
||||
pickServer :: AgentMonad m => NonEmpty SMPServer -> m SMPServer
|
||||
pickServer :: AgentMonad m => NonEmpty SMPServerWithAuth -> m SMPServerWithAuth
|
||||
pickServer = \case
|
||||
srv :| [] -> pure srv
|
||||
servers -> do
|
||||
gen <- asks randomServer
|
||||
atomically $ (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
|
||||
|
||||
getNextSMPServer :: AgentMonad m => AgentClient -> [SMPServer] -> m SMPServer
|
||||
getNextSMPServer :: AgentMonad m => AgentClient -> [SMPServer] -> m SMPServerWithAuth
|
||||
getNextSMPServer c usedSrvs = do
|
||||
srvs <- readTVarIO $ smpServers c
|
||||
case L.nonEmpty $ deleteFirstsBy sameSrvAddr (L.toList srvs) usedSrvs of
|
||||
case L.nonEmpty $ deleteFirstsBy sameSrvAddr' (L.toList srvs) (map noAuthSrv usedSrvs) of
|
||||
Just srvs' -> pickServer srvs'
|
||||
_ -> pickServer srvs
|
||||
|
||||
@@ -1766,7 +1771,7 @@ connectReplyQueues c cData@ConnData {connId} ownConnInfo (qInfo :| _) = do
|
||||
dbQueueId <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq
|
||||
enqueueConfirmation c cData sq {dbQueueId} ownConnInfo Nothing
|
||||
|
||||
confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServer -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
|
||||
confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
|
||||
confirmQueue (Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo e2eEncryption = do
|
||||
aMessage <- mkAgentMessage agentVersion
|
||||
msg <- mkConfirmation aMessage
|
||||
@@ -1822,18 +1827,8 @@ agentRatchetDecrypt db connId encAgentMsg = do
|
||||
liftEither $ first (SEAgentError . cryptoError) agentMsgBody_
|
||||
|
||||
newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => ConnId -> Compatible SMPQueueInfo -> m SndQueue
|
||||
newSndQueue connId qInfo =
|
||||
asks (cmdSignAlg . config) >>= \case
|
||||
C.SignAlg a -> newSndQueue_ a connId qInfo
|
||||
|
||||
newSndQueue_ ::
|
||||
(C.SignatureAlgorithm a, C.AlgorithmI a, MonadUnliftIO m) =>
|
||||
C.SAlgorithm a ->
|
||||
ConnId ->
|
||||
Compatible SMPQueueInfo ->
|
||||
m SndQueue
|
||||
newSndQueue_ a connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do
|
||||
-- this function assumes clientVersion is compatible - it was tested before
|
||||
newSndQueue connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do
|
||||
C.SignAlg a <- asks $ cmdSignAlg . config
|
||||
(sndPublicKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
|
||||
(e2ePubKey, e2ePrivKey) <- liftIO C.generateKeyPair'
|
||||
pure
|
||||
|
||||
@@ -17,10 +17,13 @@
|
||||
|
||||
module Simplex.Messaging.Agent.Client
|
||||
( AgentClient (..),
|
||||
SMPTestFailure (..),
|
||||
SMPTestStep (..),
|
||||
newAgentClient,
|
||||
withConnLock,
|
||||
closeAgentClient,
|
||||
closeProtocolServerClients,
|
||||
runSMPServerTest,
|
||||
newRcvQueue,
|
||||
subscribeQueue,
|
||||
subscribeQueues,
|
||||
@@ -76,6 +79,7 @@ module Simplex.Messaging.Agent.Client
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.Async (Async, uninterruptibleCancel)
|
||||
import Control.Concurrent.STM (retry, stateTVar, throwSTM)
|
||||
@@ -120,7 +124,7 @@ 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.Parsers (dropPrefix, enumJSON, parse)
|
||||
import Simplex.Messaging.Protocol
|
||||
( AProtocolType (..),
|
||||
BrokerMsg,
|
||||
@@ -164,7 +168,7 @@ data AgentClient = AgentClient
|
||||
rcvQ :: TBQueue (ATransmission 'Client),
|
||||
subQ :: TBQueue (ATransmission 'Agent),
|
||||
msgQ :: TBQueue (ServerTransmission BrokerMsg),
|
||||
smpServers :: TVar (NonEmpty SMPServer),
|
||||
smpServers :: TVar (NonEmpty SMPServerWithAuth),
|
||||
smpClients :: TMap SMPServer SMPClientVar,
|
||||
ntfServers :: TVar [NtfServer],
|
||||
ntfClients :: TMap NtfServer NtfClientVar,
|
||||
@@ -279,7 +283,7 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
|
||||
where
|
||||
connectClient :: m SMPClient
|
||||
connectClient = do
|
||||
cfg <- atomically . updateClientConfig c =<< asks (smpCfg . config)
|
||||
cfg <- getClientConfig c smpCfg
|
||||
u <- askUnliftIO
|
||||
liftEitherError (protocolClientError SMP) (getProtocolClient srv cfg (Just msgQ) $ clientDisconnected u)
|
||||
|
||||
@@ -350,7 +354,7 @@ getNtfServerClient c@AgentClient {active, ntfClients} srv = do
|
||||
where
|
||||
connectClient :: m NtfClient
|
||||
connectClient = do
|
||||
cfg <- atomically . updateClientConfig c =<< asks (ntfCfg . config)
|
||||
cfg <- getClientConfig c ntfCfg
|
||||
liftEitherError (protocolClientError NTF) (getProtocolClient srv cfg Nothing clientDisconnected)
|
||||
|
||||
clientDisconnected :: NtfClient -> IO ()
|
||||
@@ -416,9 +420,10 @@ newProtocolClient c srv clients connectClient reconnectClient clientVar = tryCon
|
||||
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
|
||||
getClientConfig :: AgentMonad m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig
|
||||
getClientConfig AgentClient {useNetworkConfig} cfgSel = do
|
||||
cfg <- asks $ cfgSel . config
|
||||
networkConfig <- readTVarIO useNetworkConfig
|
||||
pure cfg {networkConfig}
|
||||
|
||||
closeAgentClient :: MonadIO m => AgentClient -> m ()
|
||||
@@ -515,26 +520,53 @@ protocolClientError protocolError_ = \case
|
||||
e@PCESignatureError {} -> INTERNAL $ show e
|
||||
e@PCEIOError {} -> INTERNAL $ show e
|
||||
|
||||
newRcvQueue :: AgentMonad m => AgentClient -> ConnId -> SMPServer -> VersionRange -> m (RcvQueue, SMPQueueUri)
|
||||
newRcvQueue c connId srv vRange =
|
||||
asks (cmdSignAlg . config) >>= \case
|
||||
C.SignAlg a -> newRcvQueue_ a c connId srv vRange
|
||||
data SMPTestStep = TSConnect | TSCreateQueue | TSSecureQueue | TSDeleteQueue | TSDisconnect
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
newRcvQueue_ ::
|
||||
(C.SignatureAlgorithm a, C.AlgorithmI a, AgentMonad m) =>
|
||||
C.SAlgorithm a ->
|
||||
AgentClient ->
|
||||
ConnId ->
|
||||
SMPServer ->
|
||||
VersionRange ->
|
||||
m (RcvQueue, SMPQueueUri)
|
||||
newRcvQueue_ a c connId srv vRange = do
|
||||
instance ToJSON SMPTestStep where
|
||||
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "TS"
|
||||
toJSON = J.genericToJSON . enumJSON $ dropPrefix "TS"
|
||||
|
||||
data SMPTestFailure = SMPTestFailure
|
||||
{ testStep :: SMPTestStep,
|
||||
testError :: AgentErrorType
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON SMPTestFailure where
|
||||
toEncoding = J.genericToEncoding J.defaultOptions
|
||||
toJSON = J.genericToJSON J.defaultOptions
|
||||
|
||||
runSMPServerTest :: AgentMonad m => AgentClient -> SMPServerWithAuth -> m (Maybe SMPTestFailure)
|
||||
runSMPServerTest c (ProtoServerWithAuth srv auth) = do
|
||||
cfg <- getClientConfig c smpCfg
|
||||
C.SignAlg a <- asks $ cmdSignAlg . config
|
||||
liftIO $ do
|
||||
getProtocolClient srv cfg Nothing (\_ -> pure ()) >>= \case
|
||||
Right smp -> do
|
||||
(rKey, rpKey) <- C.generateSignatureKeyPair a
|
||||
(sKey, _) <- C.generateSignatureKeyPair a
|
||||
(dhKey, _) <- C.generateKeyPair'
|
||||
r <- runExceptT $ do
|
||||
SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rpKey rKey dhKey auth
|
||||
liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey
|
||||
liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId
|
||||
ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp
|
||||
pure $ either Just (const Nothing) r <|> maybe (Just (SMPTestFailure TSDisconnect $ BROKER TIMEOUT)) (const Nothing) ok
|
||||
Left e -> pure . Just $ testErr TSConnect e
|
||||
where
|
||||
testErr :: SMPTestStep -> ProtocolClientError -> SMPTestFailure
|
||||
testErr step err = SMPTestFailure step $ protocolClientError SMP err
|
||||
|
||||
newRcvQueue :: AgentMonad m => AgentClient -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri)
|
||||
newRcvQueue c connId (ProtoServerWithAuth srv auth) vRange = do
|
||||
C.SignAlg a <- asks (cmdSignAlg . config)
|
||||
(recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
|
||||
(dhKey, privDhKey) <- liftIO C.generateKeyPair'
|
||||
(e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
|
||||
logServer "-->" c srv "" "NEW"
|
||||
QIK {rcvId, sndId, rcvPublicDhKey} <-
|
||||
withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
|
||||
withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth
|
||||
logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
|
||||
let rq =
|
||||
RcvQueue
|
||||
|
||||
@@ -59,7 +59,7 @@ import UnliftIO.STM
|
||||
type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
|
||||
|
||||
data InitialAgentServers = InitialAgentServers
|
||||
{ smp :: NonEmpty SMPServer,
|
||||
{ smp :: NonEmpty SMPServerWithAuth,
|
||||
ntf :: [NtfServer],
|
||||
netCfg :: NetworkConfig
|
||||
}
|
||||
|
||||
@@ -61,9 +61,12 @@ module Simplex.Messaging.Agent.Protocol
|
||||
SndQAddr,
|
||||
SMPServer,
|
||||
pattern SMPServer,
|
||||
pattern ProtoServerWithAuth,
|
||||
SMPServerWithAuth,
|
||||
SrvLoc (..),
|
||||
SMPQueue (..),
|
||||
sameQAddress,
|
||||
noAuthSrv,
|
||||
SMPQueueUri (..),
|
||||
SMPQueueInfo (..),
|
||||
SMPQueueAddress (..),
|
||||
@@ -164,12 +167,15 @@ import Simplex.Messaging.Protocol
|
||||
NMsgMeta,
|
||||
ProtocolServer (..),
|
||||
SMPServer,
|
||||
SMPServerWithAuth,
|
||||
SndPublicVerifyKey,
|
||||
SrvLoc (..),
|
||||
legacyEncodeServer,
|
||||
legacyServerP,
|
||||
legacyStrEncodeServer,
|
||||
noAuthSrv,
|
||||
sameSrvAddr,
|
||||
pattern ProtoServerWithAuth,
|
||||
pattern SMPServer,
|
||||
)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
|
||||
@@ -361,9 +361,10 @@ createSMPQueue ::
|
||||
RcvPrivateSignKey ->
|
||||
RcvPublicVerifyKey ->
|
||||
RcvPublicDhKey ->
|
||||
Maybe BasicAuth ->
|
||||
ExceptT ProtocolClientError IO QueueIdsKeys
|
||||
createSMPQueue c rpKey rKey dhKey =
|
||||
sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
|
||||
createSMPQueue c rpKey rKey dhKey auth =
|
||||
sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth) >>= \case
|
||||
IDS qik -> pure qik
|
||||
r -> throwE . PCEUnexpectedResponse $ bshow r
|
||||
|
||||
|
||||
@@ -0,0 +1,169 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Main where
|
||||
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor (($>))
|
||||
import Data.Ini (lookupValue, readIniFile)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Network.Socket (HostName)
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Server (runNtfServer)
|
||||
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
|
||||
import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
||||
import System.FilePath (combine)
|
||||
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
ntfServerCLI :: FilePath -> FilePath -> IO ()
|
||||
ntfServerCLI cfgPath logPath =
|
||||
getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
|
||||
Init opts ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
|
||||
_ -> initializeServer opts
|
||||
Start ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> readIniFile iniFile >>= either exitError runServer
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
Delete -> do
|
||||
confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
||||
deleteDirIfExists cfgPath
|
||||
deleteDirIfExists logPath
|
||||
putStrLn "Deleted configuration and log files"
|
||||
where
|
||||
iniFile = combine cfgPath "ntf-server.ini"
|
||||
serverVersion = "SMP notifications server v1.2.0"
|
||||
defaultServerPort = "443"
|
||||
executableName = "ntf-server"
|
||||
storeLogFilePath = combine logPath "ntf-server-store.log"
|
||||
initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
|
||||
clearDirIfExists cfgPath
|
||||
clearDirIfExists logPath
|
||||
createDirectoryIfMissing True cfgPath
|
||||
createDirectoryIfMissing True logPath
|
||||
let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
|
||||
fp <- createServerX509 cfgPath x509cfg
|
||||
let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
|
||||
srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp)) Nothing
|
||||
writeFile iniFile $ iniFileContent host
|
||||
putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
|
||||
warnCAPrivateKeyFile cfgPath x509cfg
|
||||
printServiceInfo serverVersion srv
|
||||
where
|
||||
iniFileContent host =
|
||||
"[STORE_LOG]\n\
|
||||
\# The server uses STM memory for persistence,\n\
|
||||
\# that will be lost on restart (e.g., as with redis).\n\
|
||||
\# This option enables saving memory to append only log,\n\
|
||||
\# and restoring it when the server is started.\n\
|
||||
\# Log is compacted on start (deleted objects are removed).\n"
|
||||
<> ("enable: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "log_stats: off\n\n"
|
||||
<> "[TRANSPORT]\n"
|
||||
<> "# host is only used to print server address on start\n"
|
||||
<> ("host: " <> host <> "\n")
|
||||
<> ("port: " <> defaultServerPort <> "\n")
|
||||
<> "websockets: off\n"
|
||||
runServer ini = do
|
||||
hSetBuffering stdout LineBuffering
|
||||
hSetBuffering stderr LineBuffering
|
||||
fp <- checkSavedFingerprint cfgPath defaultX509Config
|
||||
let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
|
||||
port = T.unpack $ strictIni "TRANSPORT" "port" ini
|
||||
cfg@NtfServerConfig {transports, storeLogFile} = serverConfig
|
||||
srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
|
||||
printServiceInfo serverVersion srv
|
||||
printServerConfig transports storeLogFile
|
||||
runNtfServer cfg
|
||||
where
|
||||
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
|
||||
logStats = settingIsOn "STORE_LOG" "log_stats" ini
|
||||
c = combine cfgPath . ($ defaultX509Config)
|
||||
serverConfig =
|
||||
NtfServerConfig
|
||||
{ transports = iniTransports ini,
|
||||
subIdBytes = 24,
|
||||
regCodeBytes = 32,
|
||||
clientQSize = 16,
|
||||
subQSize = 64,
|
||||
pushQSize = 128,
|
||||
smpAgentCfg = defaultSMPClientAgentConfig,
|
||||
apnsConfig = defaultAPNSPushClientConfig,
|
||||
inactiveClientExpiration = Nothing,
|
||||
storeLogFile = enableStoreLog $> storeLogFilePath,
|
||||
resubscribeDelay = 50000, -- 50ms
|
||||
caCertificateFile = c caCrtFile,
|
||||
privateKeyFile = c serverKeyFile,
|
||||
certificateFile = c 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"
|
||||
}
|
||||
|
||||
data CliCommand
|
||||
= Init InitOptions
|
||||
| Start
|
||||
| Delete
|
||||
|
||||
data InitOptions = InitOptions
|
||||
{ enableStoreLog :: Bool,
|
||||
signAlgorithm :: SignAlgorithm,
|
||||
ip :: HostName,
|
||||
fqdn :: Maybe HostName
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
|
||||
cliCommandP cfgPath logPath iniFile =
|
||||
hsubparser
|
||||
( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
|
||||
<> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
|
||||
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
|
||||
)
|
||||
where
|
||||
initP :: Parser InitOptions
|
||||
initP =
|
||||
InitOptions
|
||||
<$> switch
|
||||
( long "store-log"
|
||||
<> short 'l'
|
||||
<> help "Enable store log for persistence"
|
||||
)
|
||||
<*> option
|
||||
(maybeReader readMaybe)
|
||||
( long "sign-algorithm"
|
||||
<> short 'a'
|
||||
<> help "Signature algorithm used for TLS certificates: ED25519, ED448"
|
||||
<> value ED448
|
||||
<> showDefault
|
||||
<> metavar "ALG"
|
||||
)
|
||||
<*> strOption
|
||||
( long "ip"
|
||||
<> help
|
||||
"Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
|
||||
<> value "127.0.0.1"
|
||||
<> showDefault
|
||||
<> metavar "IP"
|
||||
)
|
||||
<*> (optional . strOption)
|
||||
( long "fqdn"
|
||||
<> short 'n'
|
||||
<> help "Server FQDN used as Common Name for TLS online certificate"
|
||||
<> showDefault
|
||||
<> metavar "FQDN"
|
||||
)
|
||||
@@ -70,8 +70,11 @@ module Simplex.Messaging.Protocol
|
||||
ProtoServer,
|
||||
SMPServer,
|
||||
pattern SMPServer,
|
||||
SMPServerWithAuth,
|
||||
NtfServer,
|
||||
pattern NtfServer,
|
||||
ProtoServerWithAuth (..),
|
||||
BasicAuth (..),
|
||||
SrvLoc (..),
|
||||
CorrId (..),
|
||||
QueueId,
|
||||
@@ -116,6 +119,8 @@ module Simplex.Messaging.Protocol
|
||||
legacyServerP,
|
||||
legacyStrEncodeServer,
|
||||
sameSrvAddr,
|
||||
sameSrvAddr',
|
||||
noAuthSrv,
|
||||
|
||||
-- * TCP transport functions
|
||||
tPut,
|
||||
@@ -129,12 +134,13 @@ where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Monad.Except
|
||||
import Data.Aeson (ToJSON (..))
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isPrint, isSpace)
|
||||
import Data.Kind
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
@@ -250,7 +256,7 @@ type EntityId = ByteString
|
||||
-- | Parameterized type for SMP protocol commands from all clients.
|
||||
data Command (p :: Party) where
|
||||
-- SMP recipient commands
|
||||
NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient
|
||||
NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> Command Recipient
|
||||
SUB :: Command Recipient
|
||||
KEY :: SndPublicVerifyKey -> Command Recipient
|
||||
NKEY :: NtfPublicVerifyKey -> RcvNtfPublicDhKey -> Command Recipient
|
||||
@@ -566,6 +572,8 @@ pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash
|
||||
|
||||
{-# COMPLETE SMPServer #-}
|
||||
|
||||
type SMPServerWithAuth = ProtoServerWithAuth 'PSMP
|
||||
|
||||
type NtfServer = ProtocolServer 'PNTF
|
||||
|
||||
pattern NtfServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
|
||||
@@ -573,6 +581,10 @@ pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
|
||||
|
||||
{-# COMPLETE NtfServer #-}
|
||||
|
||||
sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
|
||||
sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
|
||||
{-# INLINE sameSrvAddr' #-}
|
||||
|
||||
sameSrvAddr :: ProtocolServer p -> ProtocolServer p -> Bool
|
||||
sameSrvAddr ProtocolServer {host, port} ProtocolServer {host = h', port = p'} = host == h' && port == p'
|
||||
{-# INLINE sameSrvAddr #-}
|
||||
@@ -667,20 +679,57 @@ instance ProtocolTypeI p => Encoding (ProtocolServer p) where
|
||||
|
||||
instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
|
||||
strEncode ProtocolServer {scheme, host, port, keyHash} =
|
||||
strEncodeServer scheme (strEncode host) port keyHash
|
||||
strP = do
|
||||
scheme <- strP <* "://"
|
||||
keyHash <- strP <* A.char '@'
|
||||
TransportHosts host <- strP
|
||||
port <- portP <|> pure ""
|
||||
pure ProtocolServer {scheme, host, port, keyHash}
|
||||
where
|
||||
portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
|
||||
strEncodeServer scheme (strEncode host) port keyHash Nothing
|
||||
strP =
|
||||
serverStrP >>= \case
|
||||
(srv, Nothing) -> pure srv
|
||||
_ -> fail "ProtocolServer with basic auth not allowed"
|
||||
|
||||
instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
newtype BasicAuth = BasicAuth {unBasicAuth :: ByteString}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance IsString BasicAuth where fromString = BasicAuth . B.pack
|
||||
|
||||
instance Encoding BasicAuth where
|
||||
smpEncode (BasicAuth s) = smpEncode s
|
||||
smpP = basicAuth <$?> smpP
|
||||
|
||||
instance StrEncoding BasicAuth where
|
||||
strEncode (BasicAuth s) = s
|
||||
strP = basicAuth <$?> A.takeWhile1 (/= '@')
|
||||
|
||||
basicAuth :: ByteString -> Either String BasicAuth
|
||||
basicAuth s
|
||||
| B.all valid s = Right $ BasicAuth s
|
||||
| otherwise = Left "invalid character in BasicAuth"
|
||||
where
|
||||
valid c = isPrint c && not (isSpace c) && c /= '@' && c /= ':' && c /= '/'
|
||||
|
||||
data ProtoServerWithAuth p = ProtoServerWithAuth (ProtocolServer p) (Maybe BasicAuth)
|
||||
deriving (Show)
|
||||
|
||||
instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where
|
||||
fromString = parseString strDecode
|
||||
|
||||
instance ProtocolTypeI p => StrEncoding (ProtoServerWithAuth p) where
|
||||
strEncode (ProtoServerWithAuth ProtocolServer {scheme, host, port, keyHash} auth_) =
|
||||
strEncodeServer scheme (strEncode host) port keyHash auth_
|
||||
strP = uncurry ProtoServerWithAuth <$> serverStrP
|
||||
|
||||
instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
instance ProtocolTypeI p => FromJSON (ProtoServerWithAuth p) where
|
||||
parseJSON = strParseJSON "ProtoServerWithAuth"
|
||||
|
||||
noAuthSrv :: ProtocolServer p -> ProtoServerWithAuth p
|
||||
noAuthSrv srv = ProtoServerWithAuth srv Nothing
|
||||
|
||||
legacyEncodeServer :: ProtocolServer p -> ByteString
|
||||
legacyEncodeServer ProtocolServer {host, port, keyHash} =
|
||||
smpEncode (L.head host, port, keyHash)
|
||||
@@ -692,14 +741,25 @@ legacyServerP = do
|
||||
|
||||
legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
|
||||
legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
|
||||
strEncodeServer scheme (strEncode $ L.head host) port keyHash
|
||||
strEncodeServer scheme (strEncode $ L.head host) port keyHash Nothing
|
||||
|
||||
strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> ByteString
|
||||
strEncodeServer scheme host port keyHash =
|
||||
strEncode scheme <> "://" <> strEncode keyHash <> "@" <> host <> portStr
|
||||
strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> Maybe BasicAuth -> ByteString
|
||||
strEncodeServer scheme host port keyHash auth_ =
|
||||
strEncode scheme <> "://" <> strEncode keyHash <> maybe "" ((":" <>) . strEncode) auth_ <> "@" <> host <> portStr
|
||||
where
|
||||
portStr = B.pack $ if null port then "" else ':' : port
|
||||
|
||||
serverStrP :: ProtocolTypeI p => Parser (ProtocolServer p, Maybe BasicAuth)
|
||||
serverStrP = do
|
||||
scheme <- strP <* "://"
|
||||
keyHash <- strP
|
||||
auth_ <- optional $ A.char ':' *> strP
|
||||
TransportHosts host <- A.char '@' *> strP
|
||||
port <- portP <|> pure ""
|
||||
pure (ProtocolServer {scheme, host, port, keyHash}, auth_)
|
||||
where
|
||||
portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
|
||||
|
||||
data SrvLoc = SrvLoc HostName ServiceName
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
@@ -870,7 +930,13 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
|
||||
instance PartyI p => ProtocolEncoding (Command p) where
|
||||
type Tag (Command p) = CommandTag p
|
||||
encodeProtocol v = \case
|
||||
NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)
|
||||
NEW rKey dhKey auth_ -> case auth_ of
|
||||
Just auth
|
||||
| v >= 5 -> new <> e ('A', auth)
|
||||
| otherwise -> new
|
||||
_ -> new
|
||||
where
|
||||
new = e (NEW_, ' ', rKey, dhKey)
|
||||
SUB -> e SUB_
|
||||
KEY k -> e (KEY_, ' ', k)
|
||||
NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
|
||||
@@ -918,7 +984,11 @@ instance ProtocolEncoding Cmd where
|
||||
protocolP v = \case
|
||||
CT SRecipient tag ->
|
||||
Cmd SRecipient <$> case tag of
|
||||
NEW_ -> NEW <$> _smpP <*> smpP
|
||||
NEW_
|
||||
| v >= 5 -> new <*> optional (A.char 'A' *> smpP)
|
||||
| otherwise -> new <*> pure Nothing
|
||||
where
|
||||
new = NEW <$> _smpP <*> smpP
|
||||
SUB_ -> pure SUB
|
||||
KEY_ -> KEY <$> _smpP
|
||||
NKEY_ -> NKEY <$> _smpP <*> smpP
|
||||
|
||||
@@ -280,7 +280,7 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
|
||||
verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult
|
||||
verifyTransmission sig_ signed queueId cmd = do
|
||||
case cmd of
|
||||
Cmd SRecipient (NEW k _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
|
||||
Cmd SRecipient (NEW k _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
|
||||
Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
|
||||
Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
|
||||
Cmd SSender PING -> pure $ VRVerified Nothing
|
||||
@@ -323,7 +323,7 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448
|
||||
dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
|
||||
|
||||
client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
|
||||
client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
|
||||
client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
|
||||
forever $
|
||||
atomically (readTBQueue rcvQ)
|
||||
>>= mapM processCommand
|
||||
@@ -340,11 +340,15 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
|
||||
Cmd SNotifier NSUB -> subscribeNotifications
|
||||
Cmd SRecipient command ->
|
||||
case command of
|
||||
NEW rKey dhKey ->
|
||||
NEW rKey dhKey auth ->
|
||||
ifM
|
||||
(asks $ allowNewQueues . config)
|
||||
allowNew
|
||||
(createQueue st rKey dhKey)
|
||||
(pure (corrId, queueId, ERR AUTH))
|
||||
where
|
||||
allowNew = do
|
||||
ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
|
||||
pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth
|
||||
SUB -> withQueue (`subscribeQueue` queueId)
|
||||
GET -> withQueue getMessage
|
||||
ACK msgId -> withQueue (`acknowledgeMsg` msgId)
|
||||
|
||||
+160
-218
@@ -13,214 +13,137 @@ import Control.Monad
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Either (fromRight)
|
||||
import Data.Ini (Ini, lookupValue, readIniFile)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Ini (Ini, lookupValue)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
import Network.Socket (HostName, ServiceName)
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
|
||||
import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
|
||||
import Simplex.Messaging.Transport.Server (loadFingerprint)
|
||||
import Simplex.Messaging.Transport.WebSockets (WS)
|
||||
import Simplex.Messaging.Util (whenM)
|
||||
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
|
||||
import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
|
||||
import System.Exit (exitFailure)
|
||||
import System.FilePath (combine)
|
||||
import System.IO (BufferMode (..), IOMode (..), hFlush, hGetLine, hSetBuffering, stderr, stdout, withFile)
|
||||
import System.IO (IOMode (..), hFlush, hGetLine, stdout, withFile)
|
||||
import System.Process (readCreateProcess, shell)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
data ServerCLIConfig cfg = ServerCLIConfig
|
||||
{ cfgDir :: FilePath,
|
||||
logDir :: FilePath,
|
||||
iniFile :: FilePath,
|
||||
storeLogFile :: FilePath,
|
||||
caKeyFile :: FilePath,
|
||||
caCrtFile :: FilePath,
|
||||
serverKeyFile :: FilePath,
|
||||
serverCrtFile :: FilePath,
|
||||
fingerprintFile :: FilePath,
|
||||
defaultServerPort :: ServiceName,
|
||||
executableName :: String,
|
||||
serverVersion :: String,
|
||||
mkIniFile :: Bool -> ServiceName -> String,
|
||||
mkServerConfig :: Maybe FilePath -> [(ServiceName, ATransport)] -> Ini -> cfg
|
||||
}
|
||||
|
||||
protocolServerCLI :: ServerCLIConfig cfg -> (cfg -> IO ()) -> IO ()
|
||||
protocolServerCLI cliCfg@ServerCLIConfig {iniFile, executableName} server =
|
||||
getCliCommand cliCfg >>= \case
|
||||
Init opts ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
|
||||
_ -> initializeServer cliCfg opts
|
||||
Start ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> readIniFile iniFile >>= either exitError (runServer cliCfg server)
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
Delete -> do
|
||||
confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
||||
cleanup cliCfg
|
||||
putStrLn "Deleted configuration and log files"
|
||||
|
||||
exitError :: String -> IO ()
|
||||
exitError msg = putStrLn msg >> exitFailure
|
||||
|
||||
confirmOrExit :: String -> IO ()
|
||||
confirmOrExit s = do
|
||||
putStrLn s
|
||||
putStr "Continue (Y/n): "
|
||||
hFlush stdout
|
||||
ok <- getLine
|
||||
when (ok /= "Y") exitFailure
|
||||
|
||||
data CliCommand
|
||||
= Init InitOptions
|
||||
| Start
|
||||
| Delete
|
||||
|
||||
data InitOptions = InitOptions
|
||||
{ enableStoreLog :: Bool,
|
||||
signAlgorithm :: SignAlgorithm,
|
||||
ip :: HostName,
|
||||
fqdn :: Maybe HostName
|
||||
}
|
||||
deriving (Show)
|
||||
confirmOrExit s =
|
||||
withPrompt (s <> "\nContinue (Y/n): ") $ do
|
||||
ok <- getLine
|
||||
when (ok /= "Y") $ putStrLn "Server NOT deleted" >> exitFailure
|
||||
|
||||
data SignAlgorithm = ED448 | ED25519
|
||||
deriving (Read, Show)
|
||||
|
||||
getCliCommand :: ServerCLIConfig cfg -> IO CliCommand
|
||||
getCliCommand cliCfg =
|
||||
data X509Config = X509Config
|
||||
{ commonName :: HostName,
|
||||
signAlgorithm :: SignAlgorithm,
|
||||
caKeyFile :: FilePath,
|
||||
caCrtFile :: FilePath,
|
||||
serverKeyFile :: FilePath,
|
||||
serverCrtFile :: FilePath,
|
||||
fingerprintFile :: FilePath,
|
||||
opensslCaConfFile :: FilePath,
|
||||
opensslServerConfFile :: FilePath,
|
||||
serverCsrFile :: FilePath
|
||||
}
|
||||
|
||||
defaultX509Config :: X509Config
|
||||
defaultX509Config =
|
||||
X509Config
|
||||
{ commonName = "127.0.0.1",
|
||||
signAlgorithm = ED448,
|
||||
caKeyFile = "ca.key",
|
||||
caCrtFile = "ca.crt",
|
||||
serverKeyFile = "server.key",
|
||||
serverCrtFile = "server.crt",
|
||||
fingerprintFile = "fingerprint",
|
||||
opensslCaConfFile = "openssl_ca.conf",
|
||||
opensslServerConfFile = "openssl_server.conf",
|
||||
serverCsrFile = "server.csr"
|
||||
}
|
||||
|
||||
getCliCommand' :: Parser cmd -> String -> IO cmd
|
||||
getCliCommand' cmdP version =
|
||||
customExecParser
|
||||
(prefs showHelpOnEmpty)
|
||||
( info
|
||||
(helper <*> versionOption <*> cliCommandP cliCfg)
|
||||
(helper <*> versionOption <*> cmdP)
|
||||
(header version <> fullDesc)
|
||||
)
|
||||
where
|
||||
versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
|
||||
version = serverVersion cliCfg
|
||||
|
||||
cliCommandP :: ServerCLIConfig cfg -> Parser CliCommand
|
||||
cliCommandP ServerCLIConfig {cfgDir, logDir, iniFile} =
|
||||
hsubparser
|
||||
( command "init" (info initP (progDesc $ "Initialize server - creates " <> cfgDir <> " and " <> logDir <> " directories and configuration files"))
|
||||
<> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
|
||||
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
|
||||
)
|
||||
createServerX509 :: FilePath -> X509Config -> IO ByteString
|
||||
createServerX509 cfgPath x509cfg = do
|
||||
createOpensslCaConf
|
||||
createOpensslServerConf
|
||||
let alg = show $ signAlgorithm (x509cfg :: X509Config)
|
||||
-- CA certificate (identity/offline)
|
||||
run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c caKeyFile
|
||||
run $ "openssl req -new -x509 -days 999999 -config " <> c opensslCaConfFile <> " -extensions v3 -key " <> c caKeyFile <> " -out " <> c caCrtFile
|
||||
-- server certificate (online)
|
||||
run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c serverKeyFile
|
||||
run $ "openssl req -new -config " <> c opensslServerConfFile <> " -reqexts v3 -key " <> c serverKeyFile <> " -out " <> c serverCsrFile
|
||||
run $ "openssl x509 -req -days 999999 -extfile " <> c opensslServerConfFile <> " -extensions v3 -in " <> c serverCsrFile <> " -CA " <> c caCrtFile <> " -CAkey " <> c caKeyFile <> " -CAcreateserial -out " <> c serverCrtFile
|
||||
saveFingerprint
|
||||
where
|
||||
initP :: Parser CliCommand
|
||||
initP =
|
||||
Init
|
||||
<$> ( InitOptions
|
||||
<$> switch
|
||||
( long "store-log"
|
||||
<> short 'l'
|
||||
<> help "Enable store log for persistence"
|
||||
)
|
||||
<*> option
|
||||
(maybeReader readMaybe)
|
||||
( long "sign-algorithm"
|
||||
<> short 'a'
|
||||
<> help "Signature algorithm used for TLS certificates: ED25519, ED448"
|
||||
<> value ED448
|
||||
<> showDefault
|
||||
<> metavar "ALG"
|
||||
)
|
||||
<*> strOption
|
||||
( long "ip"
|
||||
<> help
|
||||
"Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
|
||||
<> value "127.0.0.1"
|
||||
<> showDefault
|
||||
<> metavar "IP"
|
||||
)
|
||||
<*> (optional . strOption)
|
||||
( long "fqdn"
|
||||
<> short 'n'
|
||||
<> help "Server FQDN used as Common Name for TLS online certificate"
|
||||
<> showDefault
|
||||
<> metavar "FQDN"
|
||||
)
|
||||
)
|
||||
|
||||
initializeServer :: ServerCLIConfig cfg -> InitOptions -> IO ()
|
||||
initializeServer cliCfg InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do
|
||||
clearDirs cliCfg
|
||||
createDirectoryIfMissing True cfgDir
|
||||
createDirectoryIfMissing True logDir
|
||||
createX509
|
||||
fp <- saveFingerprint
|
||||
writeFile iniFile $ mkIniFile enableStoreLog defaultServerPort
|
||||
putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
|
||||
printServiceInfo cliCfg fp
|
||||
warnCAPrivateKeyFile
|
||||
where
|
||||
ServerCLIConfig {cfgDir, logDir, iniFile, executableName, caKeyFile, caCrtFile, serverKeyFile, serverCrtFile, fingerprintFile, defaultServerPort, mkIniFile} = cliCfg
|
||||
createX509 = do
|
||||
createOpensslCaConf
|
||||
createOpensslServerConf
|
||||
-- CA certificate (identity/offline)
|
||||
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile
|
||||
run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile
|
||||
-- server certificate (online)
|
||||
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile
|
||||
run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile
|
||||
run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile
|
||||
where
|
||||
run cmd = void $ readCreateProcess (shell cmd) ""
|
||||
opensslCaConfFile = combine cfgDir "openssl_ca.conf"
|
||||
opensslServerConfFile = combine cfgDir "openssl_server.conf"
|
||||
serverCsrFile = combine cfgDir "server.csr"
|
||||
createOpensslCaConf =
|
||||
writeFile
|
||||
opensslCaConfFile
|
||||
"[req]\n\
|
||||
\distinguished_name = req_distinguished_name\n\
|
||||
\prompt = no\n\n\
|
||||
\[req_distinguished_name]\n\
|
||||
\CN = SMP server CA\n\
|
||||
\O = SimpleX\n\n\
|
||||
\[v3]\n\
|
||||
\subjectKeyIdentifier = hash\n\
|
||||
\authorityKeyIdentifier = keyid:always\n\
|
||||
\basicConstraints = critical,CA:true\n"
|
||||
-- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
|
||||
-- IP and FQDN can't both be used as server address interchangeably even if IP is added
|
||||
-- as Subject Alternative Name, unless the following validation hook is disabled:
|
||||
-- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
|
||||
createOpensslServerConf =
|
||||
writeFile
|
||||
opensslServerConfFile
|
||||
( "[req]\n\
|
||||
\distinguished_name = req_distinguished_name\n\
|
||||
\prompt = no\n\n\
|
||||
\[req_distinguished_name]\n"
|
||||
<> ("CN = " <> cn <> "\n\n")
|
||||
<> "[v3]\n\
|
||||
\basicConstraints = CA:FALSE\n\
|
||||
\keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
|
||||
\extendedKeyUsage = serverAuth\n"
|
||||
)
|
||||
where
|
||||
cn = fromMaybe ip fqdn
|
||||
run cmd = void $ readCreateProcess (shell cmd) ""
|
||||
c = combine cfgPath . ($ x509cfg)
|
||||
createOpensslCaConf =
|
||||
writeFile
|
||||
(c opensslCaConfFile)
|
||||
"[req]\n\
|
||||
\distinguished_name = req_distinguished_name\n\
|
||||
\prompt = no\n\n\
|
||||
\[req_distinguished_name]\n\
|
||||
\CN = SMP server CA\n\
|
||||
\O = SimpleX\n\n\
|
||||
\[v3]\n\
|
||||
\subjectKeyIdentifier = hash\n\
|
||||
\authorityKeyIdentifier = keyid:always\n\
|
||||
\basicConstraints = critical,CA:true\n"
|
||||
-- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
|
||||
-- IP and FQDN can't both be used as server address interchangeably even if IP is added
|
||||
-- as Subject Alternative Name, unless the following validation hook is disabled:
|
||||
-- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
|
||||
createOpensslServerConf =
|
||||
writeFile
|
||||
(c opensslServerConfFile)
|
||||
( "[req]\n\
|
||||
\distinguished_name = req_distinguished_name\n\
|
||||
\prompt = no\n\n\
|
||||
\[req_distinguished_name]\n"
|
||||
<> ("CN = " <> commonName x509cfg <> "\n\n")
|
||||
<> "[v3]\n\
|
||||
\basicConstraints = CA:FALSE\n\
|
||||
\keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
|
||||
\extendedKeyUsage = serverAuth\n"
|
||||
)
|
||||
|
||||
saveFingerprint = do
|
||||
Fingerprint fp <- loadFingerprint caCrtFile
|
||||
withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
|
||||
Fingerprint fp <- loadFingerprint $ c caCrtFile
|
||||
withFile (c fingerprintFile) WriteMode (`B.hPutStrLn` strEncode fp)
|
||||
pure fp
|
||||
|
||||
warnCAPrivateKeyFile =
|
||||
putStrLn $
|
||||
"----------\n\
|
||||
\You should store CA private key securely and delete it from the server.\n\
|
||||
\If server TLS credential is compromised this key can be used to sign a new one, \
|
||||
\keeping the same server identity and established connections.\n\
|
||||
\CA private key location:\n"
|
||||
<> caKeyFile
|
||||
<> "\n----------"
|
||||
warnCAPrivateKeyFile :: FilePath -> X509Config -> IO ()
|
||||
warnCAPrivateKeyFile cfgPath X509Config {caKeyFile} =
|
||||
putStrLn $
|
||||
"----------\n\
|
||||
\You should store CA private key securely and delete it from the server.\n\
|
||||
\If server TLS credential is compromised this key can be used to sign a new one, \
|
||||
\keeping the same server identity and established connections.\n\
|
||||
\CA private key location:\n"
|
||||
<> combine cfgPath caKeyFile
|
||||
<> "\n----------"
|
||||
|
||||
data IniOptions = IniOptions
|
||||
{ enableStoreLog :: Bool,
|
||||
@@ -236,57 +159,76 @@ mkIniOptions ini =
|
||||
enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
|
||||
}
|
||||
|
||||
strictIni :: String -> String -> Ini -> T.Text
|
||||
strictIni :: Text -> Text -> Ini -> Text
|
||||
strictIni section key ini =
|
||||
fromRight (error ("no key " <> key <> " in section " <> section)) $
|
||||
lookupValue (T.pack section) (T.pack key) ini
|
||||
fromRight (error . T.unpack $ "no key " <> key <> " in section " <> section) $
|
||||
lookupValue section key ini
|
||||
|
||||
readStrictIni :: Read a => String -> String -> Ini -> a
|
||||
readStrictIni :: Read a => Text -> Text -> Ini -> a
|
||||
readStrictIni section key = read . T.unpack . strictIni section key
|
||||
|
||||
runServer :: ServerCLIConfig cfg -> (cfg -> IO ()) -> Ini -> IO ()
|
||||
runServer cliCfg server ini = do
|
||||
hSetBuffering stdout LineBuffering
|
||||
hSetBuffering stderr LineBuffering
|
||||
fp <- checkSavedFingerprint
|
||||
printServiceInfo cliCfg fp
|
||||
let IniOptions {enableStoreLog, port, enableWebsockets} = mkIniOptions ini
|
||||
transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
|
||||
logFile = if enableStoreLog then Just storeLogFile else Nothing
|
||||
cfg = mkServerConfig logFile transports ini
|
||||
printServerConfig logFile transports
|
||||
server cfg
|
||||
iniOnOff :: Text -> Text -> Ini -> Maybe Bool
|
||||
iniOnOff section name ini = case lookupValue section name ini of
|
||||
Right "on" -> Just True
|
||||
Right "off" -> Just False
|
||||
Right s -> error . T.unpack $ "invalid INI setting " <> name <> ": " <> s
|
||||
_ -> Nothing
|
||||
|
||||
withPrompt :: String -> IO a -> IO a
|
||||
withPrompt s a = putStr s >> hFlush stdout >> a
|
||||
|
||||
onOffPrompt :: String -> Bool -> IO Bool
|
||||
onOffPrompt prompt def =
|
||||
withPrompt (prompt <> if def then " (Yn): " else " (yN): ") $
|
||||
getLine >>= \case
|
||||
"" -> pure def
|
||||
"y" -> pure True
|
||||
"Y" -> pure True
|
||||
"n" -> pure False
|
||||
"N" -> pure False
|
||||
_ -> putStrLn "Invalid input, please enter 'y' or 'n'" >> onOffPrompt prompt def
|
||||
|
||||
onOff :: Bool -> String
|
||||
onOff True = "on"
|
||||
onOff _ = "off"
|
||||
|
||||
settingIsOn :: Text -> Text -> Ini -> Maybe ()
|
||||
settingIsOn section name ini
|
||||
| iniOnOff section name ini == Just True = Just ()
|
||||
| otherwise = Nothing
|
||||
|
||||
checkSavedFingerprint :: FilePath -> X509Config -> IO ByteString
|
||||
checkSavedFingerprint cfgPath x509cfg = do
|
||||
savedFingerprint <- withFile (c fingerprintFile) ReadMode hGetLine
|
||||
Fingerprint fp <- loadFingerprint (c caCrtFile)
|
||||
when (B.pack savedFingerprint /= strEncode fp) $
|
||||
exitError "Stored fingerprint is invalid."
|
||||
pure fp
|
||||
where
|
||||
ServerCLIConfig {storeLogFile, caCrtFile, fingerprintFile, mkServerConfig} = cliCfg
|
||||
checkSavedFingerprint = do
|
||||
savedFingerprint <- withFile fingerprintFile ReadMode hGetLine
|
||||
Fingerprint fp <- loadFingerprint caCrtFile
|
||||
when (B.pack savedFingerprint /= strEncode fp) $
|
||||
exitError "Stored fingerprint is invalid."
|
||||
pure fp
|
||||
c = combine cfgPath . ($ x509cfg)
|
||||
|
||||
printServerConfig logFile transports = do
|
||||
putStrLn $ case logFile of
|
||||
Just f -> "Store log: " <> f
|
||||
_ -> "Store log disabled."
|
||||
forM_ transports $ \(p, ATransport t) ->
|
||||
putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
|
||||
iniTransports :: Ini -> [(String, ATransport)]
|
||||
iniTransports ini =
|
||||
let port = T.unpack $ strictIni "TRANSPORT" "port" ini
|
||||
enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
|
||||
in (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
|
||||
|
||||
cleanup :: ServerCLIConfig cfg -> IO ()
|
||||
cleanup ServerCLIConfig {cfgDir, logDir} = do
|
||||
deleteDirIfExists cfgDir
|
||||
deleteDirIfExists logDir
|
||||
where
|
||||
deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
|
||||
printServerConfig :: [(ServiceName, ATransport)] -> Maybe FilePath -> IO ()
|
||||
printServerConfig transports logFile = do
|
||||
putStrLn $ case logFile of
|
||||
Just f -> "Store log: " <> f
|
||||
_ -> "Store log disabled."
|
||||
forM_ transports $ \(p, ATransport t) ->
|
||||
putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
|
||||
|
||||
clearDirs :: ServerCLIConfig cfg -> IO ()
|
||||
clearDirs ServerCLIConfig {cfgDir, logDir} = do
|
||||
clearDirIfExists cfgDir
|
||||
clearDirIfExists logDir
|
||||
where
|
||||
clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= mapM_ (removePathForcibly . combine path)
|
||||
deleteDirIfExists :: FilePath -> IO ()
|
||||
deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
|
||||
|
||||
printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO ()
|
||||
printServiceInfo ServerCLIConfig {serverVersion} fpStr = do
|
||||
printServiceInfo :: ProtocolTypeI p => String -> ProtoServerWithAuth p -> IO ()
|
||||
printServiceInfo serverVersion srv@(ProtoServerWithAuth ProtocolServer {keyHash} _) = do
|
||||
putStrLn serverVersion
|
||||
B.putStrLn $ "Fingerprint: " <> strEncode fpStr
|
||||
B.putStrLn $ "Fingerprint: " <> strEncode keyHash
|
||||
B.putStrLn $ "Server address: " <> strEncode srv
|
||||
|
||||
clearDirIfExists :: FilePath -> IO ()
|
||||
clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= mapM_ (removePathForcibly . combine path)
|
||||
|
||||
@@ -46,6 +46,8 @@ data ServerConfig = ServerConfig
|
||||
storeMsgsFile :: Maybe FilePath,
|
||||
-- | set to False to prohibit creating new queues
|
||||
allowNewQueues :: Bool,
|
||||
-- | simple password that the clients need to pass in handshake to be able to create new queues
|
||||
newQueueBasicAuth :: Maybe BasicAuth,
|
||||
-- | time after which the messages can be removed from the queues and check interval, seconds
|
||||
messageExpiration :: Maybe ExpirationConfig,
|
||||
-- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),
|
||||
|
||||
@@ -0,0 +1,283 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Simplex.Messaging.Server.Main where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Crypto.Random (getRandomBytes)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor (($>))
|
||||
import Data.Ini (lookupValue, readIniFile)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Network.Socket (HostName)
|
||||
import Options.Applicative
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
|
||||
import Simplex.Messaging.Server (runSMPServer)
|
||||
import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
||||
import System.FilePath (combine)
|
||||
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
smpServerCLI :: FilePath -> FilePath -> IO ()
|
||||
smpServerCLI cfgPath logPath =
|
||||
getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
|
||||
Init opts ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
|
||||
_ -> initializeServer opts
|
||||
Start ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> readIniFile iniFile >>= either exitError runServer
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
Delete -> do
|
||||
confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
||||
deleteDirIfExists cfgPath
|
||||
deleteDirIfExists logPath
|
||||
putStrLn "Deleted configuration and log files"
|
||||
where
|
||||
iniFile = combine cfgPath "smp-server.ini"
|
||||
serverVersion = "SMP server v" <> simplexMQVersion
|
||||
defaultServerPort = "5223"
|
||||
executableName = "smp-server"
|
||||
storeLogFilePath = combine logPath "smp-server-store.log"
|
||||
initializeServer opts
|
||||
| scripted opts = initialize opts
|
||||
| otherwise = do
|
||||
putStrLn "Use `smp-server init -h` for available options."
|
||||
void $ withPrompt "SMP server will be initialized (press Enter)" getLine
|
||||
enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True
|
||||
logStats <- onOffPrompt "Enable logging daily statistics" False
|
||||
putStrLn "Require a password to create new messaging queues?"
|
||||
password <- withPrompt "'r' for random (default), 'n' - no password, or enter password: " serverPassword
|
||||
let host = fromMaybe (ip opts) (fqdn opts)
|
||||
host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine
|
||||
initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn opts else Just host', password}
|
||||
where
|
||||
serverPassword =
|
||||
getLine >>= \case
|
||||
"" -> pure $ Just SPRandom
|
||||
"r" -> pure $ Just SPRandom
|
||||
"n" -> pure Nothing
|
||||
s ->
|
||||
case strDecode $ encodeUtf8 $ T.pack s of
|
||||
Right auth -> pure . Just $ ServerPassword auth
|
||||
_ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword
|
||||
initialize InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password} = do
|
||||
clearDirIfExists cfgPath
|
||||
clearDirIfExists logPath
|
||||
createDirectoryIfMissing True cfgPath
|
||||
createDirectoryIfMissing True logPath
|
||||
let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
|
||||
fp <- createServerX509 cfgPath x509cfg
|
||||
basicAuth <- mapM createServerPassword password
|
||||
let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
|
||||
srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth
|
||||
writeFile iniFile $ iniFileContent host basicAuth
|
||||
putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
|
||||
warnCAPrivateKeyFile cfgPath x509cfg
|
||||
printServiceInfo serverVersion srv
|
||||
where
|
||||
createServerPassword = \case
|
||||
ServerPassword s -> pure s
|
||||
SPRandom -> BasicAuth . strEncode <$> (getRandomBytes 32 :: IO B.ByteString)
|
||||
iniFileContent host basicAuth =
|
||||
"[STORE_LOG]\n\
|
||||
\# The server uses STM memory for persistence,\n\
|
||||
\# that will be lost on restart (e.g., as with redis).\n\
|
||||
\# This option enables saving memory to append only log,\n\
|
||||
\# and restoring it when the server is started.\n\
|
||||
\# Log is compacted on start (deleted objects are removed).\n"
|
||||
<> ("enable: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
|
||||
\# they are preserved in the .bak file until the next restart.\n"
|
||||
<> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "# Log daily server statistics to CSV file\n"
|
||||
<> ("log_stats: " <> onOff logStats <> "\n\n")
|
||||
<> "[AUTH]\n"
|
||||
<> "# Set new_queues option to off to completely prohibit creating new messaging queues.\n"
|
||||
<> "# This can be useful when you want to decommission the server, but not all connections are switched yet.\n"
|
||||
<> "new_queues: on\n\n"
|
||||
<> "# Use create_password option to enable basic auth to create new messaging queues.\n"
|
||||
<> "# The password should be used as part of server address in client configuration:\n"
|
||||
<> "# smp://fingerprint:password@host1,host2\n"
|
||||
<> "# The password will not be shared with the connecting contacts, you must share it only\n"
|
||||
<> "# with the users who you want to allow creating messaging queues on your server.\n"
|
||||
<> ( case basicAuth of
|
||||
Just auth -> "create_password: " <> T.unpack (safeDecodeUtf8 $ strEncode auth)
|
||||
_ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
|
||||
)
|
||||
<> "\n\n"
|
||||
<> "[TRANSPORT]\n"
|
||||
<> "# host is only used to print server address on start\n"
|
||||
<> ("host: " <> host <> "\n")
|
||||
<> ("port: " <> defaultServerPort <> "\n")
|
||||
<> "websockets: off\n\n"
|
||||
<> "[INACTIVE_CLIENTS]\n\
|
||||
\# TTL and interval to check inactive clients\n\
|
||||
\disconnect: off\n"
|
||||
<> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
|
||||
<> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n")
|
||||
runServer ini = do
|
||||
hSetBuffering stdout LineBuffering
|
||||
hSetBuffering stderr LineBuffering
|
||||
fp <- checkSavedFingerprint cfgPath defaultX509Config
|
||||
let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
|
||||
port = T.unpack $ strictIni "TRANSPORT" "port" ini
|
||||
cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, inactiveClientExpiration} = serverConfig
|
||||
srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
|
||||
printServiceInfo serverVersion srv
|
||||
printServerConfig transports storeLogFile
|
||||
putStrLn $ case inactiveClientExpiration of
|
||||
Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
|
||||
_ -> "not expiring inactive clients"
|
||||
putStrLn $
|
||||
"creating new queues "
|
||||
<> if allowNewQueues cfg
|
||||
then maybe "allowed" (const "requires password") newQueueBasicAuth
|
||||
else "NOT allowed"
|
||||
runSMPServer cfg
|
||||
where
|
||||
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
|
||||
logStats = settingIsOn "STORE_LOG" "log_stats" ini
|
||||
c = combine cfgPath . ($ defaultX509Config)
|
||||
serverConfig =
|
||||
ServerConfig
|
||||
{ transports = iniTransports ini,
|
||||
tbqSize = 16,
|
||||
serverTbqSize = 64,
|
||||
msgQueueQuota = 128,
|
||||
queueIdBytes = 24,
|
||||
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
|
||||
caCertificateFile = c caCrtFile,
|
||||
privateKeyFile = c serverKeyFile,
|
||||
certificateFile = c serverCrtFile,
|
||||
storeLogFile = enableStoreLog $> storeLogFilePath,
|
||||
storeMsgsFile =
|
||||
let messagesPath = combine logPath "smp-server-messages.log"
|
||||
in case iniOnOff "STORE_LOG" "restore_messages" ini of
|
||||
Just True -> Just messagesPath
|
||||
Just False -> Nothing
|
||||
-- if the setting is not set, it is enabled when store log is enabled
|
||||
_ -> enableStoreLog $> messagesPath,
|
||||
-- allow creating new queues by default
|
||||
allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
|
||||
newQueueBasicAuth = case lookupValue "AUTH" "create_password" ini of
|
||||
Right auth -> either error Just . strDecode $ encodeUtf8 auth
|
||||
_ -> Nothing,
|
||||
messageExpiration = Just defaultMessageExpiration,
|
||||
inactiveClientExpiration =
|
||||
settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
|
||||
$> ExpirationConfig
|
||||
{ ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
|
||||
checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
|
||||
},
|
||||
logStatsInterval = logStats $> 86400, -- seconds
|
||||
logStatsStartTime = 0, -- seconds from 00:00 UTC
|
||||
serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
|
||||
serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
|
||||
smpServerVRange = supportedSMPServerVRange
|
||||
}
|
||||
|
||||
data CliCommand
|
||||
= Init InitOptions
|
||||
| Start
|
||||
| Delete
|
||||
|
||||
data InitOptions = InitOptions
|
||||
{ enableStoreLog :: Bool,
|
||||
logStats :: Bool,
|
||||
signAlgorithm :: SignAlgorithm,
|
||||
ip :: HostName,
|
||||
fqdn :: Maybe HostName,
|
||||
password :: Maybe ServerPassword,
|
||||
scripted :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ServerPassword = ServerPassword BasicAuth | SPRandom
|
||||
deriving (Show)
|
||||
|
||||
cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
|
||||
cliCommandP cfgPath logPath iniFile =
|
||||
hsubparser
|
||||
( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
|
||||
<> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
|
||||
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
|
||||
)
|
||||
where
|
||||
initP :: Parser InitOptions
|
||||
initP = do
|
||||
enableStoreLog <-
|
||||
switch
|
||||
( long "store-log"
|
||||
<> short 'l'
|
||||
<> help "Enable store log for persistence"
|
||||
)
|
||||
logStats <-
|
||||
switch
|
||||
( long "daily-stats"
|
||||
<> short 's'
|
||||
<> help "Enable logging daily server statistics"
|
||||
)
|
||||
signAlgorithm <-
|
||||
option
|
||||
(maybeReader readMaybe)
|
||||
( long "sign-algorithm"
|
||||
<> short 'a'
|
||||
<> help "Signature algorithm used for TLS certificates: ED25519, ED448"
|
||||
<> value ED448
|
||||
<> showDefault
|
||||
<> metavar "ALG"
|
||||
)
|
||||
ip <-
|
||||
strOption
|
||||
( long "ip"
|
||||
<> help
|
||||
"Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
|
||||
<> value "127.0.0.1"
|
||||
<> showDefault
|
||||
<> metavar "IP"
|
||||
)
|
||||
fqdn <-
|
||||
(optional . strOption)
|
||||
( long "fqdn"
|
||||
<> short 'n'
|
||||
<> help "Server FQDN used as Common Name for TLS online certificate"
|
||||
<> showDefault
|
||||
<> metavar "FQDN"
|
||||
)
|
||||
password <-
|
||||
flag' Nothing (long "no-password" <> help "Allow creating new queues without password")
|
||||
<|> Just
|
||||
<$> option
|
||||
parseBasicAuth
|
||||
( long "password"
|
||||
<> metavar "PASSWORD"
|
||||
<> help "Set password to create new messaging queues"
|
||||
<> value SPRandom
|
||||
)
|
||||
scripted <-
|
||||
switch
|
||||
( long "yes"
|
||||
<> short 'y'
|
||||
<> help "Non-interactive initialization using command-line options"
|
||||
)
|
||||
pure InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password, scripted}
|
||||
parseBasicAuth :: ReadM ServerPassword
|
||||
parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
|
||||
@@ -96,10 +96,10 @@ smpBlockSize :: Int
|
||||
smpBlockSize = 16384
|
||||
|
||||
supportedSMPServerVRange :: VersionRange
|
||||
supportedSMPServerVRange = mkVersionRange 1 4
|
||||
supportedSMPServerVRange = mkVersionRange 1 5
|
||||
|
||||
simplexMQVersion :: String
|
||||
simplexMQVersion = "3.4.0"
|
||||
simplexMQVersion = "4.0.0"
|
||||
|
||||
-- * Transport connection class
|
||||
|
||||
|
||||
@@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
@@ -23,24 +24,27 @@ where
|
||||
|
||||
import Control.Concurrent (killThread, threadDelay)
|
||||
import Control.Monad
|
||||
import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT)
|
||||
import Control.Monad.IO.Unlift
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (isNothing)
|
||||
import qualified Data.Set as S
|
||||
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
||||
import SMPAgentClient
|
||||
import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
|
||||
import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers)
|
||||
import Simplex.Messaging.Agent.Client (SMPTestFailure (..), SMPTestStep (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..))
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Client (ProtocolClientConfig (..))
|
||||
import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
|
||||
import Simplex.Messaging.Client (ProtocolClientConfig (..), defaultClientConfig)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..))
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (ATransport (..))
|
||||
import Simplex.Messaging.Util (tryError)
|
||||
import Simplex.Messaging.Version
|
||||
import Test.Hspec
|
||||
import UnliftIO
|
||||
@@ -127,6 +131,57 @@ functionalAPITests t = do
|
||||
testServerMatrix2 t testSwitchAsync
|
||||
describe "should delete connection during rotation" $
|
||||
testServerMatrix2 t testSwitchDelete
|
||||
describe "SMP basic auth" $ do
|
||||
describe "with server auth" $ do
|
||||
-- allow NEW | server auth, v | clnt1 auth, v | clnt2 auth, v | 2 - success, 1 - JOIN fail, 0 - NEW fail
|
||||
it "success " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 2
|
||||
it "disabled " $ testBasicAuth t False (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 0
|
||||
it "NEW fail, no auth " $ testBasicAuth t True (Just "abcd", 5) (Nothing, 5) (Just "abcd", 5) `shouldReturn` 0
|
||||
it "NEW fail, bad auth " $ testBasicAuth t True (Just "abcd", 5) (Just "wrong", 5) (Just "abcd", 5) `shouldReturn` 0
|
||||
it "NEW fail, version " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 4) (Just "abcd", 5) `shouldReturn` 0
|
||||
it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 1
|
||||
it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "wrong", 5) `shouldReturn` 1
|
||||
it "JOIN fail, version " $ testBasicAuth t True (Just "abcd", 5) (Just "abcd", 5) (Just "abcd", 4) `shouldReturn` 1
|
||||
describe "no server auth" $ do
|
||||
it "success " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Nothing, 5) `shouldReturn` 2
|
||||
it "srv disabled" $ testBasicAuth t False (Nothing, 5) (Nothing, 5) (Nothing, 5) `shouldReturn` 0
|
||||
it "version srv " $ testBasicAuth t True (Nothing, 4) (Nothing, 5) (Nothing, 5) `shouldReturn` 2
|
||||
it "version fst " $ testBasicAuth t True (Nothing, 5) (Nothing, 4) (Nothing, 5) `shouldReturn` 2
|
||||
it "version snd " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Nothing, 4) `shouldReturn` 2
|
||||
it "version both" $ testBasicAuth t True (Nothing, 5) (Nothing, 4) (Nothing, 4) `shouldReturn` 2
|
||||
it "version all " $ testBasicAuth t True (Nothing, 4) (Nothing, 4) (Nothing, 4) `shouldReturn` 2
|
||||
it "auth fst " $ testBasicAuth t True (Nothing, 5) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 2
|
||||
it "auth fst 2 " $ testBasicAuth t True (Nothing, 4) (Just "abcd", 5) (Nothing, 5) `shouldReturn` 2
|
||||
it "auth snd " $ testBasicAuth t True (Nothing, 5) (Nothing, 5) (Just "abcd", 5) `shouldReturn` 2
|
||||
it "auth both " $ testBasicAuth t True (Nothing, 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 2
|
||||
it "auth, disabled" $ testBasicAuth t False (Nothing, 5) (Just "abcd", 5) (Just "abcd", 5) `shouldReturn` 0
|
||||
describe "SMP server test via agent API" $ do
|
||||
it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing
|
||||
it "should fail with incorrect fingerprint" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2 {keyHash = "123"}) `shouldReturn` Just (SMPTestFailure TSConnect $ BROKER NETWORK)
|
||||
describe "server with password" $ do
|
||||
let auth = Just "abcd"
|
||||
srv = ProtoServerWithAuth testSMPServer2
|
||||
authErr = Just (SMPTestFailure TSCreateQueue $ SMP AUTH)
|
||||
it "should pass with correct password" $ testSMPServerConnectionTest t auth (srv $ Just "abcd") `shouldReturn` Nothing
|
||||
it "should fail without password" $ testSMPServerConnectionTest t auth (srv Nothing) `shouldReturn` authErr
|
||||
it "should fail with incorrect password" $ testSMPServerConnectionTest t auth (srv $ Just "wrong") `shouldReturn` authErr
|
||||
|
||||
testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
|
||||
testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do
|
||||
let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = mkVersionRange 4 srvVersion}
|
||||
canCreate1 = canCreateQueue allowNewQueues srv clnt1
|
||||
canCreate2 = canCreateQueue allowNewQueues srv clnt2
|
||||
expected
|
||||
| canCreate1 && canCreate2 = 2
|
||||
| canCreate1 = 1
|
||||
| otherwise = 0
|
||||
created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth clnt1 clnt2
|
||||
created `shouldBe` expected
|
||||
pure created
|
||||
|
||||
canCreateQueue :: Bool -> (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> Bool
|
||||
canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) =
|
||||
allowNew && (isNothing srvAuth || (srvVersion == 5 && clntVersion == 5 && srvAuth == clntAuth))
|
||||
|
||||
testMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
|
||||
testMatrix2 t runTest = do
|
||||
@@ -741,6 +796,40 @@ testSwitchDelete servers = do
|
||||
liftIO $ bId `shouldBe` bId'
|
||||
pure ()
|
||||
|
||||
testCreateQueueAuth :: (Maybe BasicAuth, Version) -> (Maybe BasicAuth, Version) -> IO Int
|
||||
testCreateQueueAuth clnt1 clnt2 = do
|
||||
a <- getClient clnt1
|
||||
b <- getClient clnt2
|
||||
Right created <- runExceptT $ do
|
||||
tryError (createConnection a True SCMInvitation Nothing) >>= \case
|
||||
Left (SMP AUTH) -> pure 0
|
||||
Left e -> throwError e
|
||||
Right (bId, qInfo) ->
|
||||
tryError (joinConnection b True qInfo "bob's connInfo") >>= \case
|
||||
Left (SMP AUTH) -> pure 1
|
||||
Left e -> throwError e
|
||||
Right aId -> do
|
||||
("", _, CONF confId _ "bob's connInfo") <- get a
|
||||
allowConnection a bId confId "alice's connInfo"
|
||||
get a ##> ("", bId, CON)
|
||||
get b ##> ("", aId, INFO "alice's connInfo")
|
||||
get b ##> ("", aId, CON)
|
||||
exchangeGreetings a bId b aId
|
||||
pure 2
|
||||
pure created
|
||||
where
|
||||
getClient (clntAuth, clntVersion) =
|
||||
let servers = initAgentServers {smp = [ProtoServerWithAuth testSMPServer clntAuth]}
|
||||
smpCfg = (defaultClientConfig :: ProtocolClientConfig) {smpServerVRange = mkVersionRange 4 clntVersion}
|
||||
in getSMPAgentClient agentCfg {smpCfg} servers
|
||||
|
||||
testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe SMPTestFailure)
|
||||
testSMPServerConnectionTest t newQueueBasicAuth srv =
|
||||
withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do
|
||||
a <- getSMPAgentClient agentCfg initAgentServers -- initially passed server is not running
|
||||
Right r <- runExceptT $ testSMPServerConnection a srv
|
||||
pure r
|
||||
|
||||
exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
||||
exchangeGreetings = exchangeGreetingsMsgId 4
|
||||
|
||||
|
||||
@@ -0,0 +1,79 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module CLITests where
|
||||
|
||||
import Data.Ini (lookupValue, readIniFile)
|
||||
import Data.List (isPrefixOf)
|
||||
import Simplex.Messaging.Notifications.Server.Main
|
||||
import Simplex.Messaging.Server.Main
|
||||
import Simplex.Messaging.Util (catchAll_)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.Environment (withArgs)
|
||||
import System.IO.Silently (capture_)
|
||||
import System.Timeout (timeout)
|
||||
import Test.Hspec
|
||||
import Test.Main (withStdin)
|
||||
|
||||
cfgPath :: FilePath
|
||||
cfgPath = "tests/tmp/cli/etc/opt/simplex"
|
||||
|
||||
logPath :: FilePath
|
||||
logPath = "tests/tmp/cli/etc/var/simplex"
|
||||
|
||||
ntfCfgPath :: FilePath
|
||||
ntfCfgPath = "tests/tmp/cli/etc/opt/simplex-notifications"
|
||||
|
||||
ntfLogPath :: FilePath
|
||||
ntfLogPath = "tests/tmp/cli/etc/var/simplex-notifications"
|
||||
|
||||
cliTests :: Spec
|
||||
cliTests = do
|
||||
describe "SMP server CLI" $ do
|
||||
describe "initialize, start and delete the server" $ do
|
||||
it "no store log, random password (default)" $ smpServerTest False True
|
||||
it "with store log, random password (default)" $ smpServerTest True True
|
||||
it "no store log, no password" $ smpServerTest False False
|
||||
it "with store log, no password" $ smpServerTest True False
|
||||
describe "Ntf server CLI" $ do
|
||||
it "should initialize, start and delete the server (no store log)" $ ntfServerTest False
|
||||
it "should initialize, start and delete the server (with store log)" $ ntfServerTest True
|
||||
|
||||
smpServerTest :: Bool -> Bool -> IO ()
|
||||
smpServerTest storeLog basicAuth = do
|
||||
capture_ (withArgs (["init", "-y"] <> ["-l" | storeLog] <> ["--no-password" | not basicAuth]) $ smpServerCLI cfgPath logPath)
|
||||
>>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> cfgPath <> "/smp-server.ini") `isPrefixOf`))
|
||||
Right ini <- readIniFile $ cfgPath <> "/smp-server.ini"
|
||||
lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
|
||||
lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
|
||||
lookupValue "TRANSPORT" "port" ini `shouldBe` Right "5223"
|
||||
lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
|
||||
lookupValue "AUTH" "new_queues" ini `shouldBe` Right "on"
|
||||
lookupValue "INACTIVE_CLIENTS" "disconnect" ini `shouldBe` Right "off"
|
||||
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True
|
||||
r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
|
||||
r `shouldContain` ["SMP server v4.0.0"]
|
||||
r `shouldContain` (if storeLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."])
|
||||
r `shouldContain` ["Listening on port 5223 (TLS)..."]
|
||||
r `shouldContain` ["not expiring inactive clients"]
|
||||
r `shouldContain` (if basicAuth then ["creating new queues requires password"] else ["creating new queues allowed"])
|
||||
capture_ (withStdin "Y" . withArgs ["delete"] $ smpServerCLI cfgPath logPath)
|
||||
>>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
|
||||
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
|
||||
|
||||
ntfServerTest :: Bool -> IO ()
|
||||
ntfServerTest storeLog = do
|
||||
capture_ (withArgs (["init"] <> ["-l" | storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath)
|
||||
>>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> ntfCfgPath <> "/ntf-server.ini") `isPrefixOf`))
|
||||
Right ini <- readIniFile $ ntfCfgPath <> "/ntf-server.ini"
|
||||
lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
|
||||
lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
|
||||
lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443"
|
||||
lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
|
||||
doesFileExist (ntfCfgPath <> "/ca.key") `shouldReturn` True
|
||||
r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ()))
|
||||
r `shouldContain` ["SMP notifications server v1.2.0"]
|
||||
r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."])
|
||||
r `shouldContain` ["Listening on port 443 (TLS)..."]
|
||||
capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath)
|
||||
>>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
|
||||
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
|
||||
@@ -174,13 +174,13 @@ testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5
|
||||
initAgentServers :: InitialAgentServers
|
||||
initAgentServers =
|
||||
InitialAgentServers
|
||||
{ smp = L.fromList [testSMPServer],
|
||||
{ smp = L.fromList [noAuthSrv testSMPServer],
|
||||
ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"],
|
||||
netCfg = defaultNetworkConfig {tcpTimeout = 500_000}
|
||||
}
|
||||
|
||||
initAgentServers2 :: InitialAgentServers
|
||||
initAgentServers2 = initAgentServers {smp = L.fromList [testSMPServer, testSMPServer2]}
|
||||
initAgentServers2 = initAgentServers {smp = L.fromList [noAuthSrv testSMPServer, noAuthSrv testSMPServer2]}
|
||||
|
||||
agentCfg :: AgentConfig
|
||||
agentCfg =
|
||||
@@ -210,7 +210,7 @@ agentCfg =
|
||||
withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> m () -> (ThreadId -> m a) -> m a
|
||||
withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
|
||||
let cfg' = agentCfg {tcpPort = port', database = db'}
|
||||
initServers' = initAgentServers {smp = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
|
||||
initServers' = initAgentServers {smp = L.fromList [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]}
|
||||
in serverBracket
|
||||
(\started -> runSMPAgentBlocking t started cfg' initServers')
|
||||
afterProcess
|
||||
|
||||
@@ -78,6 +78,7 @@ cfg =
|
||||
storeLogFile = Nothing,
|
||||
storeMsgsFile = Nothing,
|
||||
allowNewQueues = True,
|
||||
newQueueBasicAuth = Nothing,
|
||||
messageExpiration = Just defaultMessageExpiration,
|
||||
inactiveClientExpiration = Just defaultInactiveClientExpiration,
|
||||
logStatsInterval = Nothing,
|
||||
|
||||
+10
-10
@@ -114,7 +114,7 @@ testCreateSecureV2 _ =
|
||||
withSmpServerConfigOn (transport @c) cfgV2 testPort $ \_ -> testSMPClient @c $ \h -> do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing)
|
||||
let dec = decryptMsgV2 $ C.dh' srvDh dhPriv
|
||||
(rId1, "") #== "creates queue"
|
||||
|
||||
@@ -178,7 +178,7 @@ testCreateSecure (ATransport t) =
|
||||
smpTest t $ \h -> do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing)
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
||||
(rId1, "") #== "creates queue"
|
||||
|
||||
@@ -242,7 +242,7 @@ testCreateDelete (ATransport t) =
|
||||
smpTest2 t $ \rh sh -> do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub)
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing)
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
||||
(rId1, "") #== "creates queue"
|
||||
|
||||
@@ -313,7 +313,7 @@ stressTest (ATransport t) =
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||
(dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||
rIds <- forM ([1 .. 50] :: [Int]) . const $ do
|
||||
Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub)
|
||||
Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing)
|
||||
pure rId
|
||||
let subscribeQueues h = forM_ rIds $ \rId -> do
|
||||
Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB)
|
||||
@@ -330,7 +330,7 @@ testAllowNewQueues t =
|
||||
testSMPClient @c $ \h -> do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
||||
(dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||
Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
|
||||
Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing)
|
||||
pure ()
|
||||
|
||||
testDuplex :: ATransport -> Spec
|
||||
@@ -339,7 +339,7 @@ testDuplex (ATransport t) =
|
||||
smpTest2 t $ \alice bob -> do
|
||||
(arPub, arKey) <- C.generateSignatureKeyPair C.SEd448
|
||||
(aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||
Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub)
|
||||
Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing)
|
||||
let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv
|
||||
-- aSnd ID is passed to Bob out-of-band
|
||||
|
||||
@@ -355,7 +355,7 @@ testDuplex (ATransport t) =
|
||||
|
||||
(brPub, brKey) <- C.generateSignatureKeyPair C.SEd448
|
||||
(bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||
Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub)
|
||||
Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing)
|
||||
let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv
|
||||
Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd)
|
||||
-- "reply_id ..." is ad-hoc, not a part of SMP protocol
|
||||
@@ -393,7 +393,7 @@ testSwitchSub (ATransport t) =
|
||||
smpTest3 t $ \rh1 rh2 sh -> do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||
Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub)
|
||||
Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing)
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
||||
Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1")
|
||||
(ok1, OK) #== "sent test message 1"
|
||||
@@ -716,7 +716,7 @@ createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (Se
|
||||
createAndSecureQueue h sPub = do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
|
||||
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing)
|
||||
let dhShared = C.dh' srvDh dhPriv
|
||||
Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub)
|
||||
(rId', rId) #== "same queue ID"
|
||||
@@ -741,7 +741,7 @@ testTiming (ATransport t) =
|
||||
testSameTiming rh sh (goodKeySize, badKeySize, n) = do
|
||||
(rPub, rKey) <- generateKeys goodKeySize
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub)
|
||||
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing)
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
||||
Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB)
|
||||
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
|
||||
import AgentTests (agentTests)
|
||||
-- import Control.Logger.Simple
|
||||
import CLITests
|
||||
import CoreTests.CryptoTests
|
||||
import CoreTests.EncodingTests
|
||||
import CoreTests.ProtocolErrorTests
|
||||
@@ -34,4 +35,5 @@ main = do
|
||||
describe "SMP server via WebSockets" $ serverTests (transport @WS)
|
||||
describe "Notifications server" $ ntfServerTests (transport @TLS)
|
||||
describe "SMP client agent" $ agentTests (transport @TLS)
|
||||
describe "Server CLIs" cliTests
|
||||
removeDirectoryRecursive "tests/tmp"
|
||||
|
||||
Reference in New Issue
Block a user