Compare commits

...
11 Commits
Author SHA1 Message Date
Evgeny Poberezkin dc920d90d9 v4.0.0 (#573)
* v4.0.0

* update
2022-11-28 19:59:04 +00:00
Evgeny Poberezkin f53c1f5559 server: clear folders during initialization instead of deleting them (#572) 2022-11-28 07:40:59 +00:00
sh 0942bf9f1e readme: correction (#571) 2022-11-26 20:10:46 +00:00
shandEvgeny Poberezkin 57fc190a91 readme: fix install steps (#570)
* readme: fix install steps

* correction

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2022-11-26 14:29:59 +00:00
Evgeny PoberezkinandJRoberts 43fb513ef7 initialize SMP server interactively, CLI options (#566)
* initialize SMP server interactively, CLI options

* correction

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>

* corrections

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
2022-11-18 19:07:41 +00:00
Evgeny Poberezkin fbccca9947 refactor server CLIs (#565)
* refactor server CLIs

* refactor
2022-11-18 08:37:03 +00:00
Evgeny Poberezkin 40000047af server: refactor CLIs, tests (#564)
* server: refactor CLIs, tests

* add files, test

* rename Executable -> Main
2022-11-17 19:43:01 +00:00
Evgeny Poberezkin c2342cba05 FromJSON instance for ProtoServerWithAuth 2022-11-15 22:42:01 +00:00
Evgeny Poberezkin f3b6ed4db0 agent API for SMP server test (#563)
* agent API for SMP server test

* add JSON encoding
2022-11-15 07:50:46 +00:00
Evgeny Poberezkin 95db734b2d export BasicAuth constructor 2022-11-13 08:29:54 +00:00
Evgeny PoberezkinandJRoberts e281efdcb8 server: SMP basic auth (#561)
* server: SMP basic auth

* update ini default

* rfc, types

* tests

* update INI file

* typo

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>

* refactor

* update INI options, log new queue creation mode on start (on/off/requires auth)

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
2022-11-12 22:29:36 +00:00
32 changed files with 1132 additions and 530 deletions
+15
View File
@@ -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:
+84 -15
View File
@@ -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
View File
@@ -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
View File
@@ -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
-1
View File
File diff suppressed because one or more lines are too long

Before

Width:  |  Height:  |  Size: 8.1 KiB

+3 -1
View File
@@ -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:
+27
View File
@@ -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).
-25
View File
@@ -1,25 +0,0 @@
# smp-server docker container
0. Install `docker` to your host.
1. Build your `smp-server` image:
- **Option 1** - Compile `smp-server` from source (stable branch):
```sh
DOCKER_BUILDKIT=1 docker build -t smp-server -f smp-server-build.Dockerfile .
```
- **Option 2** - Download latest `smp-server` from [latest Github release](https://github.com/simplex-chat/simplexmq/releases/latest):
```sh
DOCKER_BUILDKIT=1 docker build -t smp-server -f smp-server-download.Dockerfile .
```
2. Run new docker container:
```sh
docker run -d \
--name smp-server \
-e addr="your_ip_or_domain" \
-p 5223:5223 \
-v ${PWD}/config:/etc/opt/simplex \
-v ${PWD}/logs:/var/opt/simplex \
smp-server
```
Configuration files and logs will be written to [`config`](./config) and [`logs`](./logs) folders respectively.
-1
View File
@@ -1 +0,0 @@
smp-server configuration, certificate and fingerprint will be stored here
+2 -2
View File
@@ -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
View File
@@ -1 +0,0 @@
smp-server general logs, stored messages and statistics (if enabled) will be stored here
+6 -1
View File
@@ -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.*
+23 -28
View File
@@ -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
+53 -21
View File
@@ -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
+1 -1
View File
@@ -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
}
+6
View File
@@ -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
+3 -2
View File
@@ -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"
)
+87 -17
View File
@@ -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
+8 -4
View File
@@ -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
View File
@@ -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)
+2
View File
@@ -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),
+283
View File
@@ -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
+2 -2
View File
@@ -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
+93 -4
View File
@@ -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
+79
View File
@@ -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
+3 -3
View File
@@ -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
+1
View File
@@ -78,6 +78,7 @@ cfg =
storeLogFile = Nothing,
storeMsgsFile = Nothing,
allowNewQueues = True,
newQueueBasicAuth = Nothing,
messageExpiration = Just defaultMessageExpiration,
inactiveClientExpiration = Just defaultInactiveClientExpiration,
logStatsInterval = Nothing,
+10 -10
View File
@@ -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
View File
@@ -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"