Compare commits

...
Author SHA1 Message Date
Evgeny Poberezkin 099ff67885 update 2024-07-20 21:06:19 +01:00
Evgeny Poberezkin c311a41b5e Merge branch 'master' into ab/bench-target 2024-07-18 23:55:45 +01:00
spaced4ndy 7565ddd91c agent: initialize ratchet on processing confirmation to support decryption of messages received before allowConnection; return SndQueueSecured from joinConnection, acceptContact (#1233) 2024-07-18 19:54:14 +04:00
Evgeny Poberezkin 0de596dbcf 6.0.0.3 2024-07-18 11:05:53 +01:00
Evgeny Poberezkin e59a098e66 smp server: remove subscriptions from the clients when queues are deleted (#1234)
* smp server: remove subscriptions from the clients when queues are deleted

* remove ntf subscriptions, update stats

* add GET stats
2024-07-18 10:59:48 +01:00
Evgeny Poberezkin 8d56b0ba85 agent: allow starting only XFTP sending workers (#1232)
* agent: allow starting only XFTP sending workers

* use Bool param

* flip bool

* update
2024-07-17 13:01:17 +01:00
Evgeny Poberezkin b40d55c358 6.0.0.2 2024-07-15 20:30:39 +01:00
Evgeny Poberezkin 784d36d691 socks mode encoding (#1231)
* socks mode encoding

* test delays

* test delay

* unused import
2024-07-15 20:28:24 +01:00
Evgeny Poberezkin 1bdfc8ae00 6.0.0.1 2024-07-14 23:21:14 +01:00
Evgeny Poberezkin 291039159f ntf server: use SOCKS proxy to connect to onion-only SMP servers (#1229)
* ntf server: use SOCKS proxy to connect to onion-only SMP servers

* fix test
2024-07-14 23:19:02 +01:00
Evgeny Poberezkin d4fa0af350 ntf: additional tests for token registration when server and device are restarted (#1230)
* ntf: additional tests for token registration when server and device are restarted

* test response timeouts
2024-07-14 17:57:34 +01:00
Evgeny Poberezkin 492d2f86bc smp server: additional control port commands to monitor server state (#1228)
* smp server: additional control port commands to monitor server state

* fix

* space
2024-07-13 22:34:10 +01:00
Evgeny Poberezkin 8dd54ced0e agent: retry proxied command on NO_SESSION error, to prevent failure of proxied interactive commands (like joining connection) (#1227) 2024-07-13 10:06:48 +01:00
Evgeny Poberezkin e56bd0b47b agent: add known servers (#1225)
* agent: add known servers

* test delays

* ServerCfg

* json encoding

* enabledServerCfg

* checkUserServers
2024-07-12 12:41:55 +01:00
spaced4ndy ff2b00a029 agent: change ProxyClientError json encoding (#1226) 2024-07-11 19:27:04 +04:00
Evgeny Poberezkin 017469b2de 6.0.0.0 2024-07-09 13:56:02 +01:00
Evgeny Poberezkin 26979ff6b5 smp server: simplify client subscriptions (#1223) 2024-07-09 08:36:03 +01:00
Evgeny Poberezkin 21abc5cabe smp server: reduce the number of threads by delivering message to subscription when it is sent (#1222)
* smp server: reduce the number of threads by delivering message to subscription when it is sent

* test delay

* test delay
2024-07-08 23:12:01 +01:00
Evgeny Poberezkin 6e76221e07 agent: fix possible dead lock between sending and receiving messages, stress test for message delivery (#1224)
* agent: fix possible dead lock between sending and receiving messages, stress test for message delivery

* deliver events after the lock is released

* delayed delivery in command processing too

* tests: increase message expiration time
2024-07-08 21:47:42 +01:00
Evgeny Poberezkin 743676421d ntf server: simplify and optimize subscriptions in server agent (#1219)
* increase queue size

* simplify

* refactor to optimize memory usage and performance

* comment

* refactor

* test delays
2024-07-07 21:17:12 +01:00
Evgeny Poberezkin 9d0774a58e agent: add queue information (#1217)
* agent: add queue information to "debug delivery" response

* fix test

* rename

* encodings
2024-07-03 19:32:27 +01:00
Evgeny Poberezkin ce732c0efb agent: enable fast handshake (revert #1215) (#1216)
* Revert "agent: disable fast handshake (#1215)"

This reverts commit aa1d8d6c8b.

* remove import

* test delays
2024-07-03 18:05:27 +01:00
spaced4ndyandEvgeny Poberezkin ae8e1c5e9a agent: servers stats improvements, fixes (#1208)
* agent: reset stats startedAt time in memory

* getAgentSubsSummary

* change sub counting

* ack statistics

* add import

* instance

* Revert "instance"

This reverts commit 1f63740d56.

* Revert "add import"

This reverts commit ef72df8014.

* modify sub counting

* modify conn creation counting

* use int64

* file size stats

* remove import

* ack err counting

* conn del stats

* format

* new data

* add data

* toKB

* restore connCompleted

* use Int for counts

* use rq from scope

* remove getAgentSubsSummary

* fix connCompleted

* fix

* revert disabling stats

* use srv from scope

* combine ack stats

* modify

* comment

* count subs

* refactor

---------

Co-authored-by: Evgeny Poberezkin <[email protected]>
2024-07-03 12:36:15 +01:00
Evgeny Poberezkin f392ce0a93 5.8.2.0 2024-07-02 13:55:28 +01:00
Evgeny Poberezkin aa1d8d6c8b agent: disable fast handshake (#1215) 2024-07-02 13:40:37 +01:00
Evgeny Poberezkin ae4325d0e7 Merge pull request #1209 from simplex-chat/fast-connection
fast handshake protocol
2024-07-02 08:13:37 +01:00
Evgeny Poberezkin da5f669133 remove diagram 2024-07-01 23:34:31 +01:00
Evgeny Poberezkin 5c839b40c9 Merge branch 'master' into fast-connection 2024-07-01 21:14:32 +01:00
spaced4ndy a50e2e74a5 agent: disable saving stats (#1214)
* agent: disable stat saving

* disable migration

* schema

* disable restore
2024-07-01 21:06:38 +01:00
Evgeny Poberezkin 26cfad5e88 do not use sndSecure when rotating queue (#1213) 2024-07-01 13:42:46 +01:00
Evgeny Poberezkin a99ce6122c secure queue by sender via proxy (proxy SKEY command) (#1210)
* client: secure queue by sender via proxy (proxy SKEY command)

* agent and server: proxy SKEY command
2024-06-30 16:20:54 +01:00
Evgeny Poberezkin a6b542b301 Merge branch 'master' into fast-connection 2024-06-30 15:00:28 +01:00
Evgeny Poberezkin 6a54a58a0d agent: remove legacy statistics (#1211)
* agent: remove legacy statistics

* delays after disposeAgent

* delays

* enable all tests

* more delays
2024-06-30 12:50:42 +01:00
Evgeny Poberezkin 9ee684b0f4 rfc: faster handshake protocol (#1203)
* rfc: faster handshake protocol

* update

* 1 message

* SKEY

* use SKEY for both parties

* test

* update doc

* NEW command parameter

* add k=s param to queue URI

* fix

* add sndSecure field to queues

* make sender key non-optional in SndQueue (WIP, tests fail)

* fast handshake sometimes works (many tests fail)

* correctly handle SKEY retries, avoiding to re-generate the keys

* handle SKEY retries during async connection

* fix most tests (1 test fails)

* remove do

* fix contact requests encoding/tests

* export

* fix: ignore duplicate confirmations, fixes testBatchedPendingMessages

* do not store sndSecure in store log if it is false to allow server downgrade

* add connection invitation encoding tests
2024-06-30 08:36:24 +01:00
spaced4ndyandEvgeny Poberezkin c788692687 agent: servers summary types, api (#1202)
* agent: servers summary types, api [wip]

* encoding

* export

* Revert "export"

This reverts commit cd9f315fe8.

* comment

* rename

* simplify types

* uncomment

* comment

* rework

* comment, exports

* save, restore stats wip

* remove

* rename

* save stats periodically

* sigint, sigterm experiments

* corrections

* remove some proxy stats

* increase stat

* proposed stats

* fields

* Revert "sigint, sigterm experiments"

This reverts commit f876fbd418.

* wip

* retries -> attempts

* errs

* fix

* other errs

* more stat tracking

* sub stats

* remove xftp successes stats

* xftp stats tracking

* revert

* revert

* refactor

* remove imports

* comment

* Revert "refactor"

This reverts commit 26c368d82a.

* Revert "revert"

This reverts commit 4c9e3753b5.

* Revert "revert"

This reverts commit 6f65644053.

* todos

* persistence

* rename, fix

* config

* comment

* add started at to summary

* delete stats on user deletion

* reset api

* move

* getAgentServersSummary collect state logic

* corrections

* corrections

* remove

* rework

* decrease contention

* update

* more stats

* count sentProxied

* count subs

* remove unused

* comment

* remove comment

* comment

* export

* refactor

* cleanup

* intervals

* refactor

* refactor2

* refactor3

* refactor4

---------

Co-authored-by: Evgeny Poberezkin <[email protected]>
2024-06-25 09:42:59 +04:00
Alexander BondarenkoandEvgeny Poberezkin 9e7e0d102d smp-server: conserve resources (#1194)
* transport: force auth params, remove async wrapper

* stricter new messages

* bang more thunks

* style

* don't produce msgQuota unless requested

* strict

* refactor

* remove bangs

---------

Co-authored-by: Evgeny Poberezkin <[email protected]>
2024-06-24 13:15:08 +01:00
d47c099ac9 docs: update protocol specifications (#1204)
* docs: update protocol specifications

* update SMP protocol (WIP)

* add proxy protocol commands and responses, amend envelope sizes in SMP protocol

* docs: update XFTP protocol (#1205)

* docs: update XFTP protocol

* commands

* fix table of contents, move sections

* add about ids

* download encryption

* qualities

* diagram

* crypto

* sending file diagram

* fix svg

* receiving file diagram

* update commands

* update handshake

* Add updated XRCP (#1207)

* add XRCP protocol

* add ToC

* update

* update

---------

Co-authored-by: Evgeny Poberezkin <[email protected]>

* add XFTP handshake description

* update agent protocol

* fast duplex connection in agent protocol

* update agent protocol

* update overview

* typos

* queue rotation, agent API, updates

* push notifications specification

* add XRCP threat model

* XFTP threat model

* update PQDR

* agent protocol end-to-end encryption

* versions

* remove TOC details

* update

---------

Co-authored-by: spaced4ndy <[email protected]>
Co-authored-by: Alexander Bondarenko <[email protected]>
2024-06-23 22:53:45 +01:00
sh 8a3b72458f readme: update compiling from source instructions (#1190) 2024-06-16 07:43:22 -07:00
Evgeny Poberezkin f616cb7b3e 5.8.1.0 2024-06-16 07:36:38 -07:00
spaced4ndyandEvgeny Poberezkin 4bbadffa37 agent: api to reconnect single server (#1198)
* agent: api to reconnect single server

* refactor

---------

Co-authored-by: Evgeny Poberezkin <[email protected]>
2024-06-16 06:27:25 -07:00
Evgeny PoberezkinandAlexander Bondarenko 388d77b61a ntf stats on SMP server (#1197)
* log undelivered notifications

* type

* add counters and encoding

* rename

* diff

* style

* style2

---------

Co-authored-by: Alexander Bondarenko <[email protected]>
2024-06-15 20:05:45 -07:00
Alexander Bondarenko 6597f6f0ed tests: add proxy connection refused test (#1200) 2024-06-15 19:27:58 -07:00
M. Sarmad QadeerandEvgeny Poberezkin 7008b08031 smp-server: fix layout (#1196)
* smp-server: fix layout

* ws

---------

Co-authored-by: Evgeny Poberezkin <[email protected]>
2024-06-15 12:52:41 -07:00
Alexander Bondarenko 44634366be Merge remote-tracking branch 'origin/master' into ab/bench-target 2024-06-04 16:58:51 +03:00
Alexander Bondarenko f843752404 pin base64 dep 2024-04-11 20:17:49 +03:00
Alexander Bondarenko f3865f7d1f Merge remote-tracking branch 'origin/master' into ab/bench-target 2024-04-11 19:58:49 +03:00
Alexander Bondarenko 8ba036b594 add parser bench 2024-04-03 13:19:02 +03:00
Alexander Bondarenko 0dbbf718ea add base64 case 2024-04-03 12:36:07 +03:00
Alexander Bondarenko 70b5c2985c Merge remote-tracking branch 'origin/master' into ab/bench-target 2024-04-01 12:24:02 +03:00
Alexander Bondarenko 50040231c7 add bs concat 2024-03-27 14:24:37 +02:00
Alexander Bondarenko 6cd0eff6fa Merge remote-tracking branch 'origin/master' into ab/bench-target 2024-03-27 13:45:31 +02:00
Alexander Bondarenko ac8f271a36 Merge remote-tracking branch 'origin/master' into ab/bench-target 2024-03-22 13:41:51 +02:00
Alexander Bondarenko 1208df2344 bench: add compression 2024-03-15 19:41:47 +02:00
Alexander Bondarenko 0e58811525 Merge remote-tracking branch 'origin/master' into ab/bench-target 2024-03-15 18:18:13 +02:00
Alexander Bondarenko e727090020 add sntrup761 benchmark 2024-02-29 16:23:10 +02:00
Alexander Bondarenko 5baffbb370 package: add benchmark target 2024-02-29 13:43:05 +02:00
102 changed files with 6993 additions and 2231 deletions
+21
View File
@@ -1,3 +1,24 @@
# 5.8.2
Agent:
- fast handshake support (disabled).
- new statistics api.
SMP server:
- fast handshake support (SKEY command).
- minor changes to reduce memory usage.
# 5.8.1
Agent:
- API to reconnect one server.
- Better error handling of file errors and remote control connection errors.
- Only start uploading file once all chunks were registered on the servers.
SMP server:
- additional stats for sent message notifications.
- fix server page layout.
# 5.8.0
Version 5.8.0.10
+22 -9
View File
@@ -208,14 +208,17 @@ On Linux, you can build smp server using Docker.
#### Using your distribution
1. Install [Haskell GHCup](https://www.haskell.org/ghcup/), GHC 8.10.7 and cabal:
1. Install dependencies and build tools (`GHC`, `cabal` and dev libs):
```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
# On Ubuntu. Depending on your distribution, use your package manager to determine package names.
sudo apt-get update && apt-get install -y build-essential curl libffi-dev libffi7 libgmp3-dev libgmp10 libncurses-dev libncurses5 libtinfo5 pkg-config zlib1g-dev libnuma-dev libssl-dev
export BOOTSTRAP_HASKELL_GHC_VERSION=9.6.3
export BOOTSTRAP_HASKELL_CABAL_VERSION=3.10.3.0
curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 sh
ghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
ghcup set cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
source ~/.ghcup/env
```
2. Build the project:
@@ -224,10 +227,20 @@ On Linux, you can build smp server using Docker.
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
cabal build exe:smp-server exe:xftp-server
```
3. List compiled binaries:
`smp-server`
```sh
cabal list-bin exe:smp-server
```
`xftp-server`
```sh
cabal list-bin exe:xftp-server
```
- 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.
+17
View File
@@ -15,6 +15,12 @@
<link rel="stylesheet" href="/media/style.css">
<style>
body,
html {
width: 100%;
overflow-x: hidden;
}
table#config {
border-collapse: collapse;
margin-bottom: 4px;
@@ -42,6 +48,17 @@
}
}
@media screen and (max-width: 440px) {
table {
width: 100%;
table-layout: fixed;
}
tr td:not(:last-child) {
width: 40%;
}
}
.dark tr td:not(:last-child) {
color: #fff;
}
+4
View File
@@ -50,6 +50,10 @@ img {
/* For Internet Explorer and Edge */
}
a{
word-wrap: break-word;
}
/* NEW SITE */
.container,
.container-fluid,
+26
View File
@@ -0,0 +1,26 @@
{- Benchmark harness
Run with: cabal bench -O2 simplexmq-bench
List cases: cabal bench -O2 simplexmq-bench --benchmark-options "-l"
Pick one or group: cabal bench -O2 simplexmq-bench --benchmark-options "-p TRcvQueues.getDelSessQueues"
-}
module Main where
import Bench.Base64
import Bench.BsConcat
import Bench.Compression
import Bench.SNTRUP761
import Bench.TRcvQueues
import Test.Tasty.Bench
main :: IO ()
main =
defaultMain
[ bgroup "TRcvQueues" benchTRcvQueues,
bgroup "SNTRUP761" benchSNTRUP761,
bgroup "Compression" benchCompression,
bgroup "BsConcat" benchBsConcat,
bgroup "Base64" benchBase64
]
+71
View File
@@ -0,0 +1,71 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeApplications #-}
module Bench.Base64 where
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlphaNum)
import Test.Tasty.Bench
import qualified "base64" Data.Base64.Types as New
import qualified "base64" Data.ByteString.Base64 as New
import qualified "base64" Data.ByteString.Base64.URL as NewUrl
import qualified "base64-bytestring" Data.ByteString.Base64 as Old
import qualified "base64-bytestring" Data.ByteString.Base64.URL as OldUrl
benchBase64 :: [Benchmark]
benchBase64 =
[ bgroup
"encode"
[ bench "e-old" $ nf Old.encode decoded,
bcompare "e-old" . bench "e-new" $ nf New.encodeBase64' decoded
],
bgroup
"decode"
[ bench "d-old" $ nf Old.decode encoded,
bcompare "d-old" . bench "d-new" $ nf New.decodeBase64Untyped encoded,
bcompare "d-old" . bench "d-typed" $ nf (New.decodeBase64 . New.assertBase64 @New.StdPadded) encoded
],
bgroup
"encode url"
[ bench "eu-old" $ nf OldUrl.encode decoded,
bcompare "eu-old" . bench "eu-new" $ nf NewUrl.encodeBase64' decoded
],
bgroup
"decode url"
[ bench "du-old" $ nf OldUrl.decode encodedUrl,
bcompare "du-old" . bench "du-new" $ nf NewUrl.decodeBase64Untyped encodedUrl,
bcompare "du-old" . bench "du-typed" $ nf (NewUrl.decodeBase64 . New.assertBase64 @New.UrlPadded) encodedUrl
],
bgroup
"parsing"
[ bench "predicates" $ nf parsePredicates encoded,
bcompare "predicates" . bench "alphabet" $ nf parseAlphabet encoded
]
]
parsePredicates :: ByteString -> Either String ByteString
parsePredicates = A.parseOnly $ do
str <- A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
pad <- A.takeWhile (== '=')
either fail pure $ Old.decode (str <> pad)
parseAlphabet :: ByteString -> Either String ByteString
parseAlphabet = A.parseOnly $ do
str <- A.takeWhile1 (`B.elem` base64Alphabet)
pad <- A.takeWhile (== '=')
either fail pure $ Old.decode (str <> pad)
where
base64Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
encoded :: ByteString
encoded = "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA=="
encodedUrl :: ByteString
encodedUrl = "e8JK-8V3fq6kOLqco_SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON-qbvQ9ecJAA=="
decoded :: ByteString
decoded = "{\194J\251\197w~\174\164\&8\186\156\163\244\154*ZMi\SO\226\214\a\206\173z*zA%\227k\184\152_\SOH\130\237xO\152\244\215\207B\EM\197!$|6G\NUL\140\188\227~\169\187\208\245\231\t\NUL"
+23
View File
@@ -0,0 +1,23 @@
{-# LANGUAGE OverloadedStrings #-}
module Bench.BsConcat where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Test.Tasty.Bench
benchBsConcat :: [Benchmark]
benchBsConcat =
[ bgroup "3 elements"
[ bench "(3-tuple baseline)" $ nf (\(a, s, b) -> a `seq` s `seq` b `seq` "" :: ByteString) ("aaa" :: ByteString, " " :: ByteString, "bbb" :: ByteString),
bench "a <> s <> b" $ nf (\(a, s, b) -> a <> s <> b :: ByteString) ("aaa", " ", "bbb"),
bench "concat [a, s, b]" $ nf (\(a, s, b) -> B.concat [a, s, b] :: ByteString) ("aaa", " ", "bbb"),
bench "unwords [a, b]" $ nf (\(a, b) -> B.unwords [a, b] :: ByteString) ("aaa", "bbb")
],
bgroup "5 elements"
[ bench "a <> s <> b <> s <> c" $ nf (\(a, s1, b, s2, c) -> a <> s1 <> b <> s2 <> c :: ByteString) ("aaa", " ", "bbb", " ", "ccc"),
bench "(a <> s <> b) <> (s <> c)" $ nf (\(a, s1, b, s2, c) -> (a <> s1 <> b) <> (s2 <> c) :: ByteString) ("aaa", " ", "bbb", " ", "ccc"),
bench "concat [a, s, b, s c]" $ nf (\(a, s1, b, s2, c) -> B.concat [a, s1, b, s2, c] :: ByteString) ("aaa", " ", "bbb", " ", "ccc"),
bench "unwords [a, b, c]" $ nf (\(a, b, c) -> B.unwords [a, b, c] :: ByteString) ("aaa", "bbb", "ccc")
]
]
+30
View File
@@ -0,0 +1,30 @@
{-# LANGUAGE OverloadedStrings #-}
module Bench.Compression where
import qualified Codec.Compression.Zstd as Z
import Data.Aeson
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Simplex.Messaging.Compression
import Test.Tasty.Bench
benchCompression :: [Benchmark]
benchCompression =
[ bgroup
"stateless"
[ bench "1" $ nf (Z.compress 1) testJson,
bench "3" $ nf (Z.compress 3) testJson,
bench "5" $ nf (Z.compress 5) testJson,
bench "9" $ nf (Z.compress 9) testJson,
bench "15" $ nf (Z.compress 19) testJson
]
]
shortJson :: B.ByteString
shortJson = B.take maxLengthPassthrough testJson
testJson :: B.ByteString
testJson = LB.toStrict . encode $ object ["some stuff" .= [obj, obj, obj, obj]]
where
obj = object ["test" .= [True, False, True], "arr" .= [0 :: Int .. 50], "loooooooooong key" .= String "is loooooooooooooooooooooooong-ish"]
+15
View File
@@ -0,0 +1,15 @@
module Bench.SNTRUP761 where
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
import Test.Tasty.Bench
import Test.Tasty (withResource)
benchSNTRUP761 :: [Benchmark]
benchSNTRUP761 =
[ bgroup
"sntrup761Keypair"
[ withResource C.newRandom (\_ -> pure ()) $ bench "current" . whnfAppIO (>>= sntrup761Keypair)
]
]
+138
View File
@@ -0,0 +1,138 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Bench.TRcvQueues where
import Control.Monad (replicateM, unless)
import Crypto.Random
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import Data.Hashable (hash)
import Simplex.Messaging.Agent.Protocol (ConnId, QueueStatus (..), UserId)
import Simplex.Messaging.Agent.Store (DBQueueId (..), RcvQueue, StoredRcvQueue (..))
import qualified Simplex.Messaging.Agent.TRcvQueues as Current
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (ProtocolServer (..), SMPServer, SProtocolType (..), currentSMPClientVersion)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Test.Tasty.Bench
import qualified Data.Map.Strict as M
import UnliftIO
-- For quick equivalence tests
-- import GHC.IO (unsafePerformIO)
-- import Test.Hspec
-- import Test.Tasty.Hspec (testSpec)
benchTRcvQueues :: [Benchmark]
benchTRcvQueues =
[ bgroup
"addQueue"
[ bench "aq-current" $ nfIO prepareCurrent,
bcompare "aq-current" . bench "aq-batch" $ nfIO prepareCurrentBatch
],
bgroup "getDelSessQueues" benchGDS,
bgroup "resubscribe" benchResubscribe
]
benchGDS :: [Benchmark]
benchGDS =
[ env prepareCurrent $ bench "gds-current" . nfAppIO (fmap (bimap length length) . benchGDSCurrent)
-- unsafePerformIO $ testSpec "gds-equiv" testGDSequivalent
]
where
benchGDSCurrent (tSess, qs) = atomically $ Current.getDelSessQueues tSess qs
-- testGDSequivalent = it "same" $ do
-- m@(mKey, _) <- prepareMaster
-- c@(cKey, _) <- prepareCurrent
-- mKey `shouldBe` cKey
-- qsMaster <- benchGDSMaster m
-- (qsCurrent, _connIds) <- benchGDSCurrent c
-- length qsMaster `shouldNotBe` 0
-- length qsMaster `shouldBe` length qsCurrent
-- qsMaster `shouldBe` qsCurrent
benchResubscribe :: [Benchmark]
benchResubscribe =
[ env (prepareCurrent >>= pickActiveCurrent 1.0) $ bench "resub-current-full" . nfAppIO benchResubCurrent,
env (prepareCurrent >>= pickActiveCurrent 0.5) $ bench "resub-current-half" . nfAppIO benchResubCurrent,
env (prepareCurrent >>= pickActiveCurrent 0.0) $ bench "resub-current-none" . nfAppIO benchResubCurrent
]
where
pickActiveCurrent rOk (_tsess, activeSubs) = do
ok <- readTVarIO $ Current.getConnections activeSubs
let num = fromIntegral (M.size ok) * rOk :: Float
let ok' = take (round num) $ M.keys ok
pure (ok', activeSubs)
benchResubCurrent (okConns, activeSubs) = do
cs <- readTVarIO $ Current.getConnections activeSubs
let conns = filter (`M.notMember` cs) okConns
unless (null conns) $ pure ()
type TSessKey = (UserId, SMPServer, Maybe ConnId)
prepareCurrent :: IO (TSessKey, Current.TRcvQueues)
prepareCurrent = prepareWith Current.empty Current.addQueue
prepareCurrentBatch :: IO (TSessKey, Current.TRcvQueues)
prepareCurrentBatch = prepareQueues Current.empty Current.batchAddQueues
prepareWith :: STM qs -> (RcvQueue -> qs -> STM ()) -> IO (TSessKey, qs)
prepareWith initQS addQueue = prepareQueues initQS (\trqs qs -> mapM_ (`addQueue` trqs) qs)
prepareQueues :: STM qs -> (qs -> [RcvQueue] -> STM ()) -> IO (TSessKey, qs)
prepareQueues initQS addQueues = do
let (servers, gen1) = genServers gen0 nServers
let (qs, _gen2) = genQueues gen1 servers nUsers nQueues
atomically $ do
trqs <- initQS
addQueues trqs qs
pure (fmap (const Nothing) . Current.qKey $ head qs, trqs)
where
nUsers = 4
nServers = 10
nQueues = 10000
genServers :: ChaChaDRG -> Int -> ([SMPServer], ChaChaDRG)
genServers random nServers =
withDRG random . replicateM nServers $ do
host <- THOnionHost <$> getRandomBytes 32
keyHash <- C.KeyHash <$> getRandomBytes 64
pure ProtocolServer {scheme = SPSMP, host = pure host, port = "12345", keyHash}
genQueues :: ChaChaDRG -> [SMPServer] -> Int -> Int -> ([RcvQueue], ChaChaDRG)
genQueues random servers nUsers nQueues =
withDRG random . replicateM nQueues $ do
userRandom <- hash @ByteString <$> getRandomBytes 8
let userId = fromIntegral $ userRandom `mod` nUsers
connId <- getRandomBytes 10
serverRandom <- hash @ByteString <$> getRandomBytes 8
let server = servers !! (serverRandom `mod` nServers)
pure
RcvQueue
{ userId,
connId,
server,
rcvId = "",
rcvPrivateKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe",
rcvDhSecret = "01234567890123456789012345678901",
e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk",
e2eDhSecret = Nothing,
sndId = "",
sndSecure = False,
status = New,
dbQueueId = DBQueueId 0,
primary = True,
dbReplaceQueueId = Nothing,
rcvSwchStatus = Nothing,
smpClientVersion = currentSMPClientVersion,
clientNtfCreds = Nothing,
deleteErrors = 0
}
where
nServers = length servers
gen0 :: ChaChaDRG
gen0 = drgNewSeed (seedFromInteger 100500)
+5
View File
@@ -28,3 +28,8 @@ source-repository-package
type: git
location: https://github.com/simplex-chat/sqlcipher-simple.git
tag: a46bd361a19376c5211f1058908fc0ae6bf42446
source-repository-package
type: git
location: https://github.com/emilypi/base64.git
tag: e67505b35084040c91c833bae6a9e6592863fd04
+27 -2
View File
@@ -1,5 +1,5 @@
name: simplexmq
version: 5.8.0.10
version: 6.0.0.3
synopsis: SimpleXMQ message broker
description: |
This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -44,6 +44,7 @@ dependencies:
- crypton-x509-validation == 1.6.*
- cryptostore == 0.3.*
- data-default == 0.7.*
- deepseq == 1.4.*
- direct-sqlcipher == 2.3.*
- directory == 1.3.*
- filepath == 1.4.*
@@ -162,7 +163,6 @@ tests:
main: Test.hs
dependencies:
- simplexmq
- deepseq == 1.4.*
- generic-random == 1.5.*
- hspec == 2.11.*
- hspec-core == 2.11.*
@@ -177,6 +177,31 @@ tests:
- -with-rtsopts=-A64M
- -with-rtsopts=-N1
benchmarks:
simplexmq-bench:
source-dirs: benchmarks
main: Bench.hs
dependencies:
- base64 >= 1.0
- base64-bytestring
- containers
- hashable == 1.4.*
- hspec
- simplexmq
- tasty
- tasty-bench
- tasty-hspec
- unliftio
- unordered-containers
- zstd
ghc-options:
- -fproc-alignment=64
- -rtsopts
- -threaded
- -with-rtsopts=-A64m
- -with-rtsopts=-N1
- -with-rtsopts=-T
ghc-options:
# - -haddock
- -Weverything
+341 -284
View File
@@ -1,3 +1,5 @@
Version 5, 2024-06-22
# SMP agent protocol - duplex communication over SMP protocol
## Table of contents
@@ -5,69 +7,61 @@
- [Abstract](#abstract)
- [SMP agent](#smp-agent)
- [SMP servers management](#smp-servers-management)
- [SMP agent protocol components](#smp-agent-protocol-components)
- [SMP agent protocol scope](#smp-agent-protocol-scope)
- [Duplex connection procedure](#duplex-connection-procedure)
- [Contact addresses](#contact-addresses)
- [Communication between SMP agents](#communication-between-smp-agents)
- [Message syntax](#messages-between-smp-agents)
- [HELLO message](#hello-message)
- [REPLY message](#reply-message)
- [MSG message](#msg-message)
- [INV message](#inv-message)
- [ACK message](#ack-message)
- [NEW message](#new-message)
- [DEL message](#del-message)
- [SMP agent commands](#smp-agent-commands)
- [Client commands and server responses](#client-commands-and-server-responses)
- [NEW command and INV response](#new-command-and-inv-response)
- [JOIN command](#join-command)
- [CONF notification and LET command](#conf-notification-and-let-command)
- [REQ notification and ACPT command](#req-notification-and-acpt-command)
- [INFO and CON notifications](#info-and-con-notifications)
- [SUB command](#sub-command)
- [SEND command and MID, SENT and MERR responses](#send-command-and-mid-sent-and-merr-responses)
- [MSG notification](#msg-notification)
- [END notification](#end-notification)
- [OFF command](#off-command)
- [DEL command](#del-command)
- [Connection request](#connection-request)
- [A_MSG message](#a_msg-message)
- [A_RCVD message](#a_rcvd-message)
- [EREADY message](#eready-message)
- [A_QCONT message](#a_qcont-message)
- [Rotating messaging queue](#rotating-messaging-queue)
- [End-to-end encryption](#end-to-end-encryption)
- [Connection link: 1-time invitation and contact address](#connection-link-1-time-invitation-and-contact-address)
- [Appendix A: SMP agent API](#smp-agent-api)
- [API functions](#api-functions)
- [API events](#api-events)
## Abstract
The purpose of SMP agent protocol is to define the syntax and the semantics of communications between the client and the agent that connects to [SMP](./simplex-messaging.md) servers.
It provides:
- protocol to create and manage bi-directional (duplex) connections between the users of SMP agents consisting of two (or more) separate unidirectional (simplex) SMP queues, abstracting away multiple steps required to establish bi-directional connections and any information about the servers location from the users of the agent protocol.
- API to create and manage bi-directional (duplex) connections between the users of SMP agents consisting of two (or more) separate unidirectional (simplex) SMP queues, abstracting away multiple steps required to establish bi-directional connections and any information about the servers location from the users of the agent protocol.
- management of E2E encryption between SMP agents, generating ephemeral asymmetric keys for each connection.
- SMP command authentication on SMP servers, generating ephemeral keys for each SMP queue.
- TCP/TLS transport handshake with SMP servers.
- validation of message integrity.
SMP agent protocol provides no encryption or security on the client side - it is assumed that the agent is executed in the trusted and secure environment, in one of three ways:
- via TCP network using secure connection.
- via local port (when the agent runs on the same device as a separate process).
- via agent library, when the agent logic is included directly into the client application - [SimpleX Chat for terminal](https://github.com/simplex-chat/simplex-chat) uses this approach.
SMP agent API provides no security between the agent and the client - it is assumed that the agent is executed in the trusted and secure environment, via the agent library, when the agent logic is included directly into the client application - [SimpleX Chat for terminal](https://github.com/simplex-chat/simplex-chat) uses this approach.
## SMP agent
SMP agents communicate with each other via SMP servers using [simplex messaging protocol (SMP)](./simplex-messaging.md) according to the commands received from its users. This protocol is a middle layer in SimpleX protocols (above SMP protocol but below any application level protocol) - it is intended to be used by client-side applications that need secure asynchronous bi-directional communication channels ("connections").
SMP agents communicate with each other via SMP servers using [simplex messaging protocol (SMP)](./simplex-messaging.md) according to the API calls used by the client applications. This protocol is a middle layer in SimpleX protocols (above SMP protocol but below any application level protocol) - it is intended to be used by client-side applications that need secure asynchronous bi-directional communication channels ("connections").
The agent must have a persistent storage to manage the states of known connections and of the client-side information of SMP queues that each connection consists of, and also the buffer of the most recent sent and received messages. The number of the messages that should be stored is implementation specific, depending on the error management approach that the agent implements; at the very least the agent must store the hashes and IDs of the last received and sent messages.
## SMP servers management
SMP agent protocol commands do not contain the addresses of the SMP servers that the agent will use to create and use the connections (excluding the server address in queue URIs used in JOIN command). The list of the servers is a part of the agent configuration and can be dynamically changed by the agent implementation:
SMP agent API does not use the addresses of the SMP servers that the agent will use to create and use the connections (excluding the server address in queue URIs used in JOIN command). The list of the servers is a part of the agent configuration and can be dynamically changed by the agent implementation:
- by the client applications via any API that is outside of scope of this protocol.
- by the agents themselves based on availability and latency of the configured servers.
## SMP agent protocol components
## SMP agent protocol scope
SMP agent protocol has 3 main parts:
SMP agent protocol has 2 main parts:
- the syntax and semantics of the messages that SMP agents exchange with each other in order to:
- the messages that SMP agents exchange with each other in order to:
- negotiate establishing unidirectional (simplex) encrypted queues on SMP servers.
- exchange client messages and delivery notifications, providing sequential message IDs and message integrity (by including the hash of the previous message).
- the syntax and semantics of the commands that are sent by the agent clients to the agents. This protocol allows to create and manage multiple connections, each consisting of two or more SMP queues.
- the syntax and semantics of the message that the clients of SMP agents should send out-of-band (as pre-shared "invitation" including queue URIs) to protect [E2E encryption][1] from active attacks ([MITM attacks][2]).
- re-negotiate messaging queues to use and connection e2e encryption.
- the messages that the clients of SMP agents should send out-of-band (as pre-shared "invitation" including queue URIs) to protect [E2E encryption][1] from active attacks ([MITM attacks][2]).
[Appendix A](#appendix-a-smp-agent-api) of this document describes:
- the functional API used by the client application with the agent. This API allows to create and manage multiple connections, each consisting of two or more SMP queues.
- events that the agent passes to the clients.
## Duplex connection procedure
@@ -75,54 +69,126 @@ SMP agent protocol has 3 main parts:
The procedure of establishing a duplex connection is explained on the example of Alice and Bob creating a bi-directional connection consisting of two unidirectional (simplex) queues, using SMP agents (A and B) to facilitate it, and two different SMP servers (which could be the same server). It is shown on the diagram above and has these steps:
1. Alice requests the new connection from the SMP agent A using SMP NEW command.
2. Agent A creates an SMP connection on the server (using [SMP protocol](./simplex-messaging.md)) and responds to Alice with the invitation that contains queue information and the encryption key Bob's agent B should use. The invitation format is described in [Connection request](#connection-request).
3. Alice sends the [connection request](#connection-request) to Bob via any secure channel (out-of-band message).
4. Bob sends `JOIN` command with the connection request as a parameter to agent B to accept the connection.
5. Establishing Alice's SMP queue (with SMP protocol commands):
- Agent B sends an "SMP confirmation" with SMP SEND command to the SMP queue specified in the connection request - SMP confirmation is an unauthenticated message with an ephemeral key that will be used to authenticate Bob's commands to the queue, as described in SMP protocol, and Bob's info (profile, public key for E2E encryption, etc.). This message is encrypted using key passed in the connection request (or with the derived key, in which case public key for key derivation should be sent in clear text).
- Agent A receives the SMP confirmation containing Bob's key and info as SMP MSG.
- Agent A notifies Alice sending REQ notification with Bob's info.
- Alice accepts connection request with ACPT command.
- Agent A secures the queue with SMP KEY command.
- Agent B tries sending authenticated SMP SEND command with agent `HELLO` message until it succeeds. Once it succeeds, Bob's agent "knows" the queue is secured.
6. Agent B creates a new SMP queue on the server.
7. Establish Bob's SMP queue:
- Agent B sends `REPLY` message (SMP SEND command) with the connection request to this 2nd queue to Alice's agent (via the 1st queue) - this connection request SHOULD use "simplex" URI scheme.
- Agent A, having received `REPLY` message, sends unauthenticated message (SMP SEND) to SMP queue with Alice agent's ephemeral key that will be used to authenticate Alice's commands to the queue, as described in SMP protocol, and Alice's info.
- Bob's agent receives the key and Alice's information and secures the queue (SMP KEY).
- Bob's agent sends the notification `INFO` with Alice's information to Bob.
- Alice's agent keeps sending `HELLO` message until it succeeds.
8. Agents A and B notify Alice and Bob that connection is established.
- Once sending `HELLO` succeeds, Alice's agent sends to Alice `CON` notification that confirms that now both parties can communicate.
- Once Bob's agent receives `HELLO` from Alice's agent, it sends to Bob `CON` notification as well.
1. Alice requests the new connection from the SMP agent A using agent `createConnection` api function.
2. Agent A creates an SMP queue on the server (using [SMP protocol](./simplex-messaging.md) `NEW` command) and responds to Alice with the invitation that contains queue information and the encryption keys Bob's agent B should use. The invitation format is described in [Connection link](connection-link-1-time-invitation-and-contact-address).
3. Alice sends the [connection link](#connection-link-1-time-invitation-and-contact-address) to Bob via any secure channel (out-of-band message) - as a link or as a QR code.
4. Bob uses agent `joinConnection` api function with the connection link as a parameter to agent B to accept the connection.
5. Agent B creates Bob's SMP reply queue with SMP server `NEW` command.
6. Agent B confirms the connection: sends an "SMP confirmation" with SMP server `SEND` command to the SMP queue specified in the connection link - SMP confirmation is an unauthenticated message with an ephemeral key that will be used to authenticate Bob's commands to the queue, as described in SMP protocol, and Bob's info (profile, public key for E2E encryption, and the connection link to this 2nd queue to Agent A - this connection link SHOULD use "simplex" URI scheme). This message is encrypted using key passed in the connection link (or with the derived shared secret, in which case public key for key derivation should be sent in clear text).
6. Alice confirms and continues the connection:
- Agent A receives the SMP confirmation containing Bob's key, reply queue and info as SMP server `MSG`.
- Agent A notifies Alice sending `CONF` notification with Bob's info.
- Alice allows connection to continue with agent `allowConnection` api function.
- Agent A secures the queue with SMP server `KEY` command.
- Agent A sends SMP confirmation with ephemeral sender key, ephemeral public encryption key and profile (but without reply queue).
7. Agent B confirms the connection:
- receives the confirmation.
- sends the notification `INFO` with Alice's information to Bob.
- secures SMP queue that it sent to Alice in the first confirmation with SMP `KEY` command .
- sends `HELLO` message via SMP `SEND` command. This confirms that the reply queue is secured and also validates that Agent A secured the first SMP queue
8. Agent A notifies Alice.
- receives `HELLO` message from Agent B.
- sends `HELLO` message to Agent B via SMP `SEND` command.
- sends `CON` notification to Alice, confirming that the connection is established.
9. Agent B notifies Bob.
- Once Agent B receives `HELLO` from Agent A, it sends to Bob `CON` notification as well.
At this point the duplex connection between Alice and Bob is established, they can use `SEND` command to send messages. The diagram also shows how the connection status changes for both parties, where the first part is the status of the SMP queue to receive messages, and the second part - the status of the queue to send messages.
The most communication happens between the agents and servers, from the point of view of Alice and Bob there are 4 steps (not including notifications):
1. Alice requests a new connection with `NEW` command and receives the invitation.
2. Alice passes connection request out-of-band to Bob.
3. Bob accepts the connection with `JOIN` command with the connection request to his agent.
4. Alice accepts the connection with `ACPT` command.
1. Alice requests a new connection with `createConnection` agent API function and receives the connection link.
2. Alice passes connection link out-of-band to Bob.
3. Bob accepts the connection with `joinConnection` agent API function with the connection link to his agent.
4. Alice accepts the connection with `ACPT` agent API function.
5. Both parties receive `CON` notification once duplex connection is established.
Clients SHOULD support establishing duplex connection asynchronously (when parties are intermittently offline) by persisting intermediate states and resuming SMP queue subscriptions.
## Fast duplex connection procedure
Previously described duplex connection procedure requires sending 4 messages creating a bad UX for the users - it requires waiting until each party in online before the messages can be sent.
It allows users validating connecting party profile before proceeding with the connection, but it turned out to be unnecessary UX step and is not used in the client applications.
It also protects against an attacker who compromised TLS and uses the sender queue ID sent to the recipient to secure the queue before the sender can. This attack is very hard, and this accepting its risk is better than worse UX. Future protocol versions could mitigate this attack by encrypting entity IDs.
Faster duplex connection process is possible with the `SKEY` command added in v9 of SMP protocol.
![Fast duplex connection procedure](./diagrams/duplex-messaging/duplex-creating-fast.svg)
1. Alice requests the new connection from the SMP agent A using agent `createConnection` api function
2. Agent A creates an SMP queue on the server (using [SMP protocol](./simplex-messaging.md) `NEW` command with the flag allowing the sender to secure the queue) and responds to Alice with the invitation that contains queue information and the encryption keys Bob's agent B should use. The invitation format is described in [Connection link](connection-link-1-time-invitation-and-contact-address).
3. Alice sends the [connection link](connection-link-1-time-invitation-and-contact-address) to Bob via any secure channel (out-of-band message) - as a link or as a QR code. This link contains the flag that the queue can be secured by the sender.
4. Bob uses agent `joinConnection` api function with the connection link as a parameter to agent B to accept the connection.
5. Agent B secures Alice's queue with SMP command `SKEY` - this command can be proxied.
6. Agent B creates Bob's SMP reply queue with SMP server `NEW` command (with the flag allowing the sender to secure the queue).
7. Agent B confirms the connection: sends an "SMP confirmation" with SMP server `SEND` command to the SMP queue specified in the connection link - SMP confirmation is an unauthenticated message with an ephemeral key that will be used to authenticate Bob's commands to the queue, as described in SMP protocol, and Bob's info (profile, public key for E2E encryption, and the connection link to this 2nd queue to Agent A - this connection link SHOULD use "simplex" URI scheme). This message is encrypted using key passed in the connection link (or with the derived shared secret, in which case public key for key derivation should be sent in clear text).
8. Alice confirms the connection:
- Agent A receives the SMP confirmation containing Bob's key, reply queue and info as SMP server `MSG`.
- Agent A notifies Alice sending `CONF` notification with Bob's info (that indicates that Agent B already secured the queue).
- Alice allows connection to continue with agent `allowConnection` api function.
- Agent A secures Bob's queue with SMP command `SKEY`.
- Agent A sends SMP confirmation with ephemeral public encryption key and profile (but without reply queue, and without sender key).
9. Agent A notifies Alice with `CON` notification.
10. Agent B notifies Bob about connection success:
- receives confirmation message from Alice.
- sends the notification `INFO` with Alice's information to Bob.
- sends `CON` notification to Bob.
## Contact addresses
SMP agents support creating a special type of connection - a contact address - that allows to connect to multiple network users who can send connection requests by sending 1-time connection links to the message queue.
This connection address uses a messaging queue on SMP server to receive invitations to connect - see `agentInvitation` message below. Once connection request is accepted, a new connection is created and the address itself is no longer used to send the messages - deleting this address does not disrupt the connections that were created via it.
## Communication between SMP agents
To establish duplex connections and to send messages on behalf of their clients, SMP agents communicate via SMP servers.
Agents use SMP message client body (the part of the SMP message after header - see [SMP protocol](./simplex-messaging.md)) to transmit agent client messages and exchange messages between each other.
Each SMP message client body, once decrypted, contains 3 parts (one of them may include binary message body), as defined by `decryptedSmpMessageBody` syntax:
These messages are encrypted with per-queue shared secret using NaCL crypto_box and can be of 4 types, as defined by `decryptedSMPClientMessage`:
- `agentConfirmation` - used when confirming SMP queues, contains connection information encrypted with double ratchet. This envelope can only contain `agentConnInfo` or `agentConnInfoReply` encrypted with double ratchet.
- `agentMsgEnvelope` - contains different agent messages encrypted with double ratchet, as defined in `agentMessage`.
- `agentInvitation` - sent to SMP queue that is used as contact address, does not use double ratchet.
- `agentRatchetKey` - used to re-negotiate double ratchet encryption - can contain additional information in `agentRatchetKey`.
```abnf
decryptedSMPClientMessage = agentConfirmation / agentMsgEnvelope / agentInvitation / agentRatchetKey
agentConfirmation = agentVersion %s"C" ("0" / "1" sndE2EEncryptionParams) encConnInfo
agentVersion = 2*2 OCTET
sndE2EEncryptionParams = TODO
encConnInfo = doubleRatchetEncryptedMessage
agentMsgEnvelope = agentVersion %s"M" encAgentMessage
encAgentMessage = doubleRatchetEncryptedMessage
agentInvitation = agentVersion %s"I" connReqLength connReq connInfo
connReqLength = 2*2 OCTET ; Word16
agentRatchetKey = agentVersion %s"R" rcvE2EEncryptionParams agentRatchetInfo
rcvE2EEncryptionParams = TODO
doubleRatchetEncryptedMessage = TODO
```
This syntax of decrypted SMP client message body is defined by `decryptedAgentMessage` below.
Decrypted SMP message client body can be one of 4 types:
- `agentConnInfo` - used by the initiating party when confirming reply queue - sent in `agentConfirmation` envelope.
- `agentConnInfoReply` - used by accepting party, includes reply queue(s) in the initial confirmation - sent in `agentConfirmation` envelope.
- `agentRatchetInfo` - used to pass additional information when renegotiating double ratchet encryption - sent in `agentRatchetKey` envelope.
- `agentMessage` - all other agent messages.
`agentMessage` contains these parts:
- `agentMsgHeader` - agent message header that contains sequential agent message ID for a particular SMP queue, agent timestamp (ISO8601) and the hash of the previous message.
- `agentMessage` - a command/message to the other SMP agent:
- to establish the connection with two SMP queues (`helloMsg`, `replyQueueMsg`)
- to send and to acknowledge user messages (`clientMsg`, `acknowledgeMsg`)
- to manage SMP queue rotation (`newQueueMessage`, `deleteQueueMsg`)
- to manage encryption key rotation (TODO)
- `aMessage` - a command/message to the other SMP agent:
- to confirm the connection (`HELLO`).
- to send and to confirm reception of user messages (`A_MSG`, `A_RCVD`).
- to confirm that the new double ratchet encryption is agreed (`EREADY`).
- to notify another party that it can continue sending messages after queue capacity was exceeded (`A_QCONT`).
- to manage SMP queue rotation (`QADD`, `QKEY`, `QUSE`, `QTEST`).
- `msgPadding` - an optional message padding to make all SMP messages have constant size, to prevent servers from observing the actual message size. The only case the message padding can be absent is when the message has exactly the maximum size, in all other cases the message MUST be padded to a fixed size.
### Messages between SMP agents
@@ -130,269 +196,160 @@ Each SMP message client body, once decrypted, contains 3 parts (one of them may
Message syntax below uses [ABNF][3] with [case-sensitive strings extension][4].
```abnf
decryptedSmpMessageBody = agentMsgHeader CRLF agentMessage CRLF msgPadding
agentMsgHeader = agentMsgId SP previousMsgHash ; here `agentMsgId` is sequential ID set by the sending agent
agentMsgId = 1*DIGIT
previousMsgHash = encoded
encoded = <base64 encoded>
decryptedAgentMessage = agentConnInfo / agentConnInfoReply / agentRatchetInfo / agentMessage
agentConnInfo = %s"I" connInfo
connInfo = *OCTET
agentConnInfoReply = %s"D" smpQueues connInfo
agentRatchetInfo = %s"R" ratchetInfo
agentMessage = helloMsg / replyQueueMsg /
clientMsg / invitationMsg /
newQueueMessage / deleteQueueMsg
agentMessage = %s"M" agentMsgHeader aMessage msgPadding
agentMsgHeader = agentMsgId prevMsgHash
agentMsgId = 8*8 OCTET ; Int64
prevMsgHash = shortString
msgPadding = *OCTET ; optional random bytes to get messages to the same size (as defined in SMP message size)
aMessage = HELLO / A_MSG / A_RCVD / EREADY / A_QCONT /
QADD / QKEY / QUSE / QTEST
helloMsg = %s"H"
HELLO = %s"H"
replyQueueMsg = %s"R" connectionRequest ; `connectionRequest` is defined below
; this message can only be sent by the second connection party
A_MSG = %s"M" userMsgBody
userMsgBody = *OCTET
clientMsg = %s"M" clientMsgBody
clientMsgBody = *OCTET
A_RCVD = %s"V" msgReceipt
msgReceipt = agentMsgId msgHash rcptLength rcptInfo
; TODO remove and move to "public" header
invitationMsg = %s"INV" SP connReqInvitation SP connInfo
; `connReqInvitation` and `connInfo` are defined below
EREADY = %s"E" agentMsgId
newQueueMsg = %s"N" queueURI
; this message can be sent by any party to add SMP queue to the connection.
; NOT SUPPORTED in the current implementation
A_QCONT = %s"QC" sndQueueAddr
deleteQueueMsg = %s"D" queueURI
; notification that the queue with passed URI will be deleted
; no need to notify the other party about suspending queue separately, as suspended and deleted queues are indistinguishable to the sender
; NOT SUPPORTED in the current implementation
QADD = %s"QA" sndQueues
sndQueues = length 1*(newQueueUri replacedSndQueue)
newQueueUri = clientVRange smpServer senderId dhPublicKey [sndSecure]
dhPublicKey = length x509encoded
sndSecure = "T"
replacedSndQueue = "0" / "1" sndQueueAddr
QKEY = %s"QK" sndQueueKeys
sndQueueKeys = length 1*(newQueueInfo senderKey)
newQueueInfo = version smpServer senderId dhPublicKey [sndSecure]
senderKey = length x509encoded
QUSE = %s"QU" sndQueuesReady
sndQueuesReady = length 1*(sndQueueAddr primary)
primary = %s"T" / %s"F"
QTEST = %s"QT" sndQueueAddrs
sndQueueAddrs = length 1*sndQueueAddr
sndQueueAddr = smpServer senderId
smpServer = hosts port keyHash
hosts = length 1*host
host = shortString
port = shortString
keyHash = shortString
senderId = shortString
clientVRange = version version
version = 2*2 OCTET
msgPadding = *OCTET
rcptLength = 2*2 OCTET
shortString = length *OCTET
length = 1*1 OCTET
```
#### HELLO message
This is the first message that both agents send after the respective SMP queue is secured by the receiving agent (see diagram). It MAY contain the public key that the recipient would use to verify messages signed by the sender.
This is the first message that both agents send after the respective SMP queue is secured by the receiving agent (see diagram).
Sending agent might need to retry sending HELLO message, as it would not have any other confirmation that the queue is secured other than the success of sending this message with the signed SMP SEND command.
This message is not used with [fast duplex connection](#fast-duplex-connection-procedure).
#### REPLY message
#### A_MSG message
This is the message that is sent by the agent that received an out-of-band connection request to pass the connection request for the reply SMP queues to the agent that originated the connection (see diagram).
This is the agent envelope used to send client messages once the connection is established. This is different from the MSG sent by SMP server to the agent and MSG event from SMP agent to the client that are sent in different contexts.
#### MSG message
#### A_RCVD message
This is the agent envelope used to send client messages once the connection is established. Do not confuse it with the MSG response from SMP server to the agent and MSG response from SMP agent to the client that are sent in different contexts.
This message is sent to confirm the client message reception. It includes received message number and message hash.
#### INV message
#### EREADY message
This message is sent to the SMP queue(s) in `connReqContact`, to establish a new connection via existing unsecured queue, that acts as a permanent connection link of a user.
This message is sent after re-negotiating a new double ratchet encryption with `agentRatchetKey`.
#### ACK message
#### A_QCONT message
This message is sent to confirm the client message reception. It includes received message number, message hash and the reception status.
This message is sent to notify the sender client that it can continue sending the messages after queue capacity was exhausted.
#### NEW message
### Rotating messaging queue
This message is sent to add an additional SMP queue to the connection. Unlike REPLY message it can be sent at any time.
SMP agents SHOULD support 4 messages to rotate message reception to another messaging server:
`QADD`: add the new queue address(es) to the connection - sent by the client that initiates rotation.
`QKEY`: pass sender's key via existing connection (SMP confirmation message will not be used, to avoid the same "race" of the initial key exchange that would create the risk of intercepting the queue for the attacker) - sent by the client accepting the rotation
`QUSE`: instruct the sender to use the new queue with sender's queue ID as parameter. From this point some messages can be sent to both the new queue and the old queue.
`QTEST`: send test message to the new connection. Any other message can be sent if available to continue rotation, the absence of this message is not an error. Once this message is successfully sent the sender will stop using the old queue. Once this message (or any other message in the new queue) is received, the recipient will stop using the old queue and delete it.
#### DEL message
**Queue rotation procedure**
This message is sent to notify that the queue with passed URI will be deleted - having received this message, the receiving agent should no longer send messages to this queue. In case it was the last remaining send queue in the duplex connection, the agent MAY also delete the reply queue(s) in the connection.
![Queue rotation procedure](./diagrams/duplex-messaging/queue-rotation.svg)
## SMP agent commands
`SKEY` command added in v9 of SMP protocol allows for faster queue rotation procedure.
This part describes the transmissions between users and client-side SMP agents: commands that the users send to create and operate duplex connections and SMP agent responses and messages they deliver.
**Fast queue rotation procedure**
Commands syntax below is provided using [ABNF][3] with [case-sensitive strings extension][4].
![Fast queue rotation procedure](./diagrams/duplex-messaging/queue-rotation-fast.svg)
Each transmission between the user and SMP agent must have this format/syntax:
## End-to-end encryption
```abnf
agentTransmission = [corrId] CRLF [connId] CRLF agentCommand
Messages between SMP agents have two layers of e2e encryption:
- simple encryption agreed in SMP protocol with a fixed key agreed when the messaging queue is agreed by parties.
- post-quantum resistant augmented double ratchet algorithm (PQDR) specified in [this document](./pqdr.md).
corrId = 1*(%x21-7F) ; any characters other than control/whitespace
The protocol supports adding and removing post-quantum KEM primitive to the key agreement in double ratchet:
- to support migration of pre-existing connections to PQDR.
- to be able to disable PQ key agreement.
- to be able to use invitation links and contact addresses without large PQ keys.
connId = encoded
Possible scenarios below show the possible states of PQ key agreement, assuming that both clients support it.
agentCommand = (userCmd / agentMsg) CRLF
userCmd = newCmd / joinCmd / letCmd / acceptCmd / subscribeCmd / sendCmd / acknowledgeCmd / suspendCmd / deleteCmd
agentMsg = invitation / confMsg / connReqMsg / connInfo / connected / unsubscribed / connDown / connUp / messageId / sent / messageError / message / received / ok / error
Possible options for each stage are:
- no KEM encapsulation key was sent (No PQ key),
- only KEM encapsulation key was sent, but not ciphertext yet (PQ key sent),
- both KEM encapsulation key from one KEM agreement and ciphertext from the previous agreement were sent (PQ key + PQ ct sent).
newCmd = %s"NEW" SP connectionMode [SP %s"NO_ACK"] ; response is `invitation` or `error`
; NO_ACK parameter currently not supported
`+` in the table means that this scenario is possible, and `-` - that it is not possible.
connectionMode = %s"INV" / %s"CON"
| Connection stage | No PQ key | PQ key sent | PQ key + PQ ct sent |
|:------------------------------------------------------:|:----------------:|:----------------:|:-------------------:|
| invitation | + | + | - |
| confirmation, in reply to: <br>no-pq inv <br>pq inv | &nbsp;<br>+<br>+ | &nbsp;<br>+<br>- | &nbsp;<br>-<br>+ |
| 1st msg, in reply to: <br>no-pq conf <br>pq/pq+ct conf | &nbsp;<br>+<br>+ | &nbsp;<br>+<br>- | &nbsp;<br>-<br>+ |
| Nth msg, in reply to: <br>no-pq msg <br>pq/pq+ct msg | &nbsp;<br>+<br>+ | &nbsp;<br>+<br>- | &nbsp;<br>-<br>+ |
invitation = %s"INV" SP connectionRequest ; `connectionRequest` is defined below
These scenarios can be reduced to:
1. initial invitation optionally has PQ key, but must not have ciphertext.
2. all subsequent messages should be allowed without PQ key/ciphertext, but:
- if the previous message had PQ key or PQ key with ciphertext, they must either have no PQ key, or have PQ key with ciphertext (PQ key without ciphertext is an error).
- if the previous message had no PQ key, they must either have no PQ key, or have PQ key without ciphertext (PQ key with ciphertext is an error).
confMsg = %s"CONF" SP confirmationId SP msgBody
; msgBody here is any binary information identifying connection request
The rules for calculating the shared secret for received/sent messages are (assuming received message is valid according to the above rules):
letCmd = %s"LET" SP confirmationId SP msgBody
; msgBody here is any binary information identifying connecting party
| sent msg > <br>V received msg | no-pq | pq | pq+ct |
|:------------------------------:|:-----------:|:-------:|:---------------:|
| no-pq | DH / DH | DH / DH | err |
| pq (sent msg was NOT pq) | DH / DH | err | DH / DH+KEM |
| pq+ct (sent msg was NOT no-pq) | DH+KEM / DH | err | DH+KEM / DH+KEM |
confirmationId = 1*DIGIT
To summarize, the upgrade to DH+KEM secret happens in a sent message that has PQ key with ciphertext sent in reply to message with PQ key only (without ciphertext), and the downgrade to DH secret happens in the message that has no PQ key.
connReqMsg = %s"REQ" SP invitationId SP msgBody
; msgBody here is any binary information identifying connection request
## Connection link: 1-time invitation and contact address
acceptCmd = %s"ACPT" SP invitationId SP msgBody
; msgBody here is any binary information identifying connecting party
Connection links are generated by SMP agent in response to `createConnection` api call, used by another party user with `joinConnection` api, and then another connection link is sent by the agent in `agentConnInfoReply` and used by the first party agent to connect to the reply queue (the second part of the process is invisible to the users).
invitationId = 1*DIGIT
connInfo = %s"INFO" SP msgBody
; msgBody here is any binary information identifying connecting party
connected = %s"CON"
subscribeCmd = %s"SUB" ; response is `ok` or `error`
unsubscribed = %s"END"
; when another agent (or another client of the same agent)
; subscribes to the same SMP queue on the server
connDown = %s"DOWN"
; lost connection (e.g. because of Internet connectivity or server is down)
connUp = %s"UP"
; restored connection
joinCmd = %s"JOIN" SP connectionRequest SP connInfo [SP %s"NO_REPLY"] [SP %s"NO_ACK"]
; `connectionRequest` and `connInfo` are defined below
; response is `connected` or `error`
; parameters NO_REPLY and NO_ACK are currently not supported
suspendCmd = %s"OFF" ; can be sent by either party, response `ok` or `error`
deleteCmd = %s"DEL" ; can be sent by either party, response `ok` or `error`
sendCmd = %s"SEND" SP msgBody
; send syntax is similar to that of SMP protocol, but it is wrapped in SMP message
msgBody = stringMsg | binaryMsg
stringMsg = ":" string ; until CRLF in the transmission
string = *(%x01-09 / %x0B-0C / %x0E-FF %) ; any characters other than NUL, CR and LF
binaryMsg = size CRLF msgBody CRLF ; the last CRLF is in addition to CRLF in the transmission
size = 1*DIGIT ; size in bytes
msgBody = *OCTET ; any content of specified size - safe for binary
messageId = %s"MID" SP agentMsgId
sent = %s"SENT" SP agentMsgId
messageError = %s"MERR" SP agentMsgId SP <errorType>
message = %s"MSG" SP msgIntegrity SP recipientMeta SP brokerMeta SP senderMeta SP binaryMsg
recipientMeta = %s"R=" agentMsgId "," agentTimestamp ; receiving agent message metadata
brokerMeta = %s"B=" brokerMsgId "," brokerTimestamp ; broker (server) message metadata
senderMeta = %s"S=" agentMsgId ; sending agent message ID
brokerMsgId = encoded
brokerTimestamp = <date-time>
msgIntegrity = ok / msgIntegrityError
msgIntegrityError = %s"ERR" SP msgIntegrityErrorType
msgIntegrityErrorType = skippedMsgErr / badMsgIdErr / badHashErr
skippedMsgErr = %s"NO_ID" SP missingFromMsgId SP missingToMsgId
badMsgIdErr = %s"ID" SP previousMsgId ; ID is lower than the previous
badHashErr = %s"HASH"
missingFromMsgId = agentMsgId
missingToMsgId = agentMsgId
previousMsgId = agentMsgId
acknowledgeCmd = %s"ACK" SP agentMsgId ; ID assigned by receiving agent (in MSG "R")
received = %s"RCVD" SP agentMsgId SP msgIntegrity
; ID assigned by sending agent (in SENT response)
; currently not implemented
msgStatus = ok | error
ok = %s"OK"
error = %s"ERR" SP <errorType>
```
### Client commands and server responses
#### NEW command and INV response
`NEW` command is used to create a connection and a connection request to be sent out-of-band to another protocol user (the joining party). It should be used by the client of the agent that initiates creating a duplex connection (the initiating party).
`INV` response is sent by the agent to the client of the initiating party.
`NEW` command has `connectionMode` parameter to define the connection mode - to be used to communicate with a single contact (invitation mode, `connectionMode` is `INV`) or to accept connection requests from anybody (contact mode, `connectionMode` is `CON`). The type of connection request is determined by `connectionMode` parameter.
#### JOIN command
It is used to create a connection and accept the connection request received out-of-band. It should be used by the client of the agent that accepts the connection (the joining party).
#### CONF notification and LET command
When the joining party uses `JOIN` command to accept connection invitation created with `NEW INV` command, the initiating party will receive `CONF` notification with some numeric identifier and an additional binary information, that can be used to identify the joining party or for any other purpose.
To continue with the connection the initiating party should use `LET` command.
#### REQ notification and ACPT command
When the joining party uses `JOIN` command to connect to the contact created with `NEW CON` command, the initiating party will receive `REQ` notification with some numeric identifier and an additional binary information, that can be used to identify the joining party or for any other purpose.
To continue with the connection the party that created the contact should use `ACPT` command.
#### INFO and CON notifications
After the initiating party proceeds with the connection using `ACPT` command, the joining party will receive `INFO` notification that can be used to identify the initiating party or for any other purpose.
Once the connection is established and ready to accept client messages, both agents will send `CON` notification to their clients.
#### SUB command
This command can be used by the client to resume receiving messages from the connection that was created in another TCP/client session. Agent response to this command can be `OK` or `ERR` in case connection does not exist (or can only be used to send connections - e.g. when the reply queue was not created).
#### SEND command and MID, SENT, RCVD and MERR responses
`SEND` command is used by the client to send messages.
`MID` response with the message ID (the sequential message number that includes both sent and received messages in the connection) is sent to the client to confirm that the message is accepted by the agent, before it is sent to the SMP server.
`SENT` notification is sent by the agent to confirm that the message was delivered to at least one of SMP servers. This notification contains the same message ID as `MID` notification. `SENT` notification, depending on network availability, can be sent at any time later, potentially in the next client session.
`RCVD` notification is sent by the agent when it receives `ACK` message from the receiving agent. This notification contains reception status, only one successful notification will be sent, and multiple error notifications will be sent in case `ACK` had error status.
In case of the failure to send the message for any other reason than network connection or message queue quota - e.g. authentication error (`ERR AUTH`) or syntax error (`ERR CMD error`), the agent will send to the client `MERR` notification with the message ID, and this message delivery will no longer be attempted to this SMP queue.
#### MSG notification
It is sent by the agent to the client when agent receives the message from the SMP server. It has message ID and timestamp from both the receiving and sending agents and from SMP server:
- recipient agent ID is intended to be used to refer to the message in the future.
- sender agent ID is intended to be used to identify any missed / skipped message(s)
- broker ID should be used to detect duplicate deliveries (it would happen if TCP connection is lost before the message is acknowledged by the agent - see [SMP protocol](./simplex-messaging.md))
#### END notification
It is sent by the agent to the client when agent receives SMP protocol `END` notification from SMP server. It indicates that another agent has subscribed to the same SMP queue on the server and the server terminated the subscription of the current agent.
#### DOWN and UP notifications
These notifications are sent when server or network connection is, respectively, `DOWN` or back `UP`.
All the subscriptions made in the current client session will be automatically resumed when `UP` notification is received.
#### OFF command
It is used to suspend the receiving SMP queue - sender will no longer be able to send the messages to the connection, but the recipient can retrieve the remaining messages. Agent response to this command can be `OK` or `ERR`. This command is irreversible.
#### DEL command
It is used to delete the connection and all messages in it, as well as the receiving SMP queue and all messages in it that were remaining on the server. Agent response to this command can be `OK` or `ERR`. This command is irreversible.
## Connection request
Connection request `connectionRequest` is generated by SMP agent in response to `newCmd` command (`"NEW"`), used by another party user with `joinCmd` command (`"JOIN"`), and then another connection request is sent by the agent in `replyQueueMsg` and used by the first party agent to connect to the reply queue (the second part of the process is invisible to the users).
Connection request syntax:
Connection link syntax:
```
connectionRequest = connectionScheme "/" connReqType "#/?smp=" smpQueues "&e2e=" e2eEncryption
connReqType = %s"invitation" / %s"contact"
; this parameter has the same meaning as connectionMode in agent commands
; `NEW INV` creates `invitation` connection request, `NEW CON` - `contact`
connectionLink = connectionScheme "/" connLinkType "#/?smp=" smpQueues "&e2e=" e2eEncryption
connLinkType = %s"invitation" / %s"contact"
connectionScheme = (%s"https://" clientAppServer) | %s"simplex:"
clientAppServer = hostname [ ":" port ]
; client app server, e.g. simplex.chat
@@ -407,12 +364,112 @@ smpQueue = <URL-encoded queueURI defined in SMP protocol>
All parameters are passed via URI hash to avoid sending them to the server (in case "https" scheme is used) - they can be used by the client-side code and processed by the client application. Parameters `smp` and `e2e` can be present in any order, any unknown additional parameters SHOULD be ignored.
`clientAppServer` is not an SMP server - it is a server that shows the instruction on how to download the client app that will connect using this connection request. This server can also host a mobile or desktop app manifest so that this link is opened directly in the app if it is installed on the device.
`clientAppServer` is not an SMP server - it is a server that shows the instruction on how to download the client app that will connect using this connection link. This server can also host a mobile or desktop app manifest so that this link is opened directly in the app if it is installed on the device.
"simplex" URI scheme in `connectionProtocol` can be used instead of client app server, to connect without creating any web traffic. Client apps MUST support this URI scheme.
See SMP protocol [out-of-band messages](./simplex-messaging.md#out-of-band-messages) for syntax of `queueURI`.
## Appendix A: SMP agent API
The exact specification of agent library API and of the events that the agent sends to the client application is out of scope of the protocol specification.
The list of some of the API functions and events below is supported by the reference implementation, and they are likely to be required by the client applications.
### API functions
The list of APIs below is not exhaustive and provided for information only. Please consult the source code for more information.
#### Create conection
`createConnection` api is used to create a connection - it returns the connection link that should be sent out-of-band to another protocol user (the joining party). It should be used by the client of the agent that initiates creating a duplex connection (the initiating party).
This api is also used to create a contact address - a special connection that can be used by multiple people to connect to the user.
Some communication scenarios may require fault-tolerant mechanism of creating connections that retries on network failures and continue retrying after the client is restarted. Such asynchronous API would return its result via `INV` event once it succeeds.
#### Join connection
`joinConnection` is used to create a connection record and accept the connection invitation received out-of-band. It should be used by the client of the agent that accepts the connection (the joining party).
This api can also be required as asynchronous, in which case `OK` event will be dispatched to the client to indicate the success or `ERR` in case it permanently failed (e.g., in case connection was deleted by another party).
#### Allow connection
Once the client receives `CONF` event, it should use synchronous `allowConnection` api to proceed with the connection (both for the [standard](#duplex-connection-procedure) and for the [fast duplex procedure](#fast-duplex-connection-procedure)).
In case this API is used as asynchronous it will return its result via `OK` or `ERR` event.
#### Accept and reject connection requests
Connection requests are delivered to the client application via `REQ` event.
Client can `acceptContact` and `rejectContact`, with `OK` and `ERR` events in case of asynchronous calls.
#### Send message
`sendMessage` api is always asynchronous. The api call returns message ID, `SENT` event once the message is sent to the server, `MWARN` event in case of temporary delivery failure that can be resolved by the user (e.g., by connecting via Tor or by upgrading the client) and `MERR` in case of permanent delivery failure.
#### Acknowledge received message
Messages are delivered to the client application via `MSG` event.
Client application must always `ackMessage` to receive the next one - failure to call it in reference implementation will prevent the delivery of subsequent messages until the client reconnects to the server.
This api is also used to acknowledge message delivery to the sending party - that party client application will receive `RCVD` event.
#### Subscribe connection
`subscribeConnection` api is used by the client to resume receiving messages from the connection that was created in another TCP/client session.
#### Get notification message
`getNotificationMessage` is used by push notification subsystem of the client application to receive the message from a specific messaging queue mentioned in the notification. The client application would receive `MSG` and any other events from the agent, and then `MSGNTF` event once the message related to this notification is received.
#### Rotate message queue to another server
`switchConnection` api is used to rotate connection queues to another messaging server.
#### Renegotiate e2e encryption
`synchronizeRatchet` api is used to re-negotiate double ratchet encryption for the connection.
#### Delete connection
`deleteConnection` api is used to delete connection. In case of asynchronous call, the connection deletion will be confirmed with `DEL_RCVQ` and `DEL_CONN` events.
#### Suspend connection
`suspendConnection` api is used to prevent any further messages delivered to the connection without deleting it.
### API events
Agent API uses these events dispatch to notify client application about events related to the connections:
- `INV` - connection invitation or connection address URI after connection is created.
- `CONF` - confirmation that connection is accepted by another party. When the accepting party uses `joinConnection` api to accept connection invitation, the initiating party will receive `CONF` notification with some identifier and additional information from the accepting party (e.g., profile). To continue the connection the initiating party client should use `allowConnection` api.
- `REQ` - connection request is sent when another party uses `joinConnection` api with contact address. The client application can use `acceptContact` or `rejectContact` api.
- `INFO` - information from the party that initiated the connection with `createConnection` sent to the party accepting the connection with `joinConnection`.
- `CON` - notification that connection is established sent to both parties of the connection.
- `END` - notification that connection subscription is terminated when another client subscribed to the same messaging queue.
- `DOWN` - notification that connection server is temporarily unavailable.
- `UP` - notification that the subscriptions made in the current client session are resumed after the server became available.
- `SWITCH` - notification about queue rotation process.
- `RSYNC` - notification about e2e encryption re-negotiation process.
- `SENT` - notification to confirm that the message was delivered to at least one of SMP servers. This notification contains the same message ID as returned to `sendMessage` api. `SENT` notification, depending on network availability, can be sent at any time later, potentially in the next client session.
- `MWARN` - temporary delivery failure that can be resolved by the user (e.g., by connecting via Tor or by upgrading the client).
- `MERR` - notification about permanent message delivery failure.
- `MERRS` - notification about permanent message delivery failure for multiple messages (e.g., when multiple messages expire).
- `MSG` - sent when agent receives the message from the SMP server.
- `MSGNTF` - sent after agent received and processed the message referenced in the push notification.
- `RCVD` - notification confirming message receipt by another party.
- `QCONT` - notification that the agent continued sending messages after queue capacity was exceeded and recipient received all messages.
- `DEL_RCVQ` - confirmation that message queue was deleted.
- `DEL_CONN` - confirmation that connection was deleted.
- `OK` - confirmation that asynchronous api call was successful.
- `ERR` - error of asynchronous api call or some other error event.
This list of events is not exhaustive and provided for information only. Please consult the source code for more information.
[1]: https://en.wikipedia.org/wiki/End-to-end_encryption
[2]: https://en.wikipedia.org/wiki/Man-in-the-middle_attack
[3]: https://tools.ietf.org/html/rfc5234
@@ -0,0 +1,65 @@
sequenceDiagram
participant A as Alice
participant AA as Alice's<br>agent
participant AS as Alice's<br>server
participant BS as Bob's<br>server
participant BA as Bob's<br>agent
participant B as Bob
note over AA, BA: status (receive/send): NONE/NONE
note over A, AA: 1. request connection<br>from agent
A ->> AA: createConnection
note over AA, AS: 2. create Alice's SMP queue
AA ->> AS: NEW: create SMP queue<br>allow sender to secure
AS ->> AA: IDS: SMP queue IDs
note over AA: status: NEW/NONE
AA ->> A: INV: invitation<br>to connect
note over A, B: 3. out-of-band invitation
A ->> B: OOB: invitation to connect
note over BA, B: 4. accept connection
B ->> BA: joinConnection:<br>via invitation info
note over BA: status: NONE/NEW
note over BA, AS: 5. secure Alice's SMP queue
BA ->> AS: SKEY: secure queue (this command needs to be proxied)
note over BA: status: NONE/SECURED
note over BA, BS: 6. create Bob's SMP queue
BA ->> BS: NEW: create SMP queue<br>allow sender to secure
BS ->> BA: IDS: SMP queue IDs
note over BA: status: NEW/SECURED
note over BA, AA: 7. confirm Alice's SMP queue
BA ->> AS: SEND: Bob's info without sender's key (SMP confirmation with reply queues)
note over BA: status: NEW/CONFIRMED
AS ->> AA: MSG: Bob's info without<br>sender server key
note over AA: status: CONFIRMED/NEW
AA ->> AS: ACK: confirm message
AA ->> A: CONF: connection request ID<br>and Bob's info
A -> AA: allowConnection: accept connection request,<br>send Alice's info
note over AA, BS: 8. secure Bob's SMP queue
AA ->> BS: SKEY: secure queue (this command needs to be proxied)
note over BA: status: CONFIRMED/SECURED
AA ->> BS: SEND: Alice's info without sender's server key (SMP confirmation without reply queues)
note over AA: status: CONFIRMED/CONFIRMED
note over AA, A: 9. notify Alice<br>about connection success<br>(no HELLO needed in v6)
AA ->> A: CON: connected
note over AA: status: ACTIVE/ACTIVE
note over BA, B: 10. notify Bob<br>about connection success
BS ->> BA: MSG: Alice's info without<br>sender's server key
note over BA: status: CONFIRMED/CONFIRMED
BA ->> B: INFO: Alice's info
BA ->> BS: ACK: confirm message
BA ->> B: CON: connected
note over BA: status: ACTIVE/ACTIVE
File diff suppressed because one or more lines are too long

After

Width:  |  Height:  |  Size: 40 KiB

@@ -1,71 +0,0 @@
sequenceDiagram
participant A as Alice
participant AA as Alice's<br>agent
participant AS as Alice's<br>server
participant BS as Bob's<br>server
participant BA as Bob's<br>agent
participant B as Bob
note over AA, BA: status (receive/send): NONE/NONE
note over A, AA: 1. request connection<br>from agent
A ->> AA: NEW: create<br>duplex connection
note over AA, AS: 2. create Alice's SMP queue
AA ->> AS: NEW: create SMP queue
AS ->> AA: IDS: SMP queue IDs
note over AA: status: NEW/NONE
AA ->> A: INV: invitation<br>to connect
note over A, B: 3. out-of-band invitation
A ->> B: OOB: invitation to connect
note over BA, B: 4. accept connection
B ->> BA: JOIN:<br>via invitation info
note over BA: status: NONE/NEW
note over BA, BS: 5. create Bob's SMP queue
BA ->> BS: NEW: create SMP queue
BS ->> BA: IDS: SMP queue IDs
note over BA: status: NEW/NEW
note over BA, AA: 6. establish Alice's SMP queue
BA ->> AS: SEND: Bob's info and sender server key (SMP confirmation with reply queues)
note over BA: status: NEW/CONFIRMED
AS ->> AA: MSG: Bob's info and<br>sender server key
note over AA: status: CONFIRMED/NONE
AA ->> AS: ACK: confirm message
AA ->> A: CONF: connection request ID<br>and Bob's info
A ->> AA: LET: accept connection request,<br>send Alice's info
AA ->> AS: KEY: secure queue
note over AA: status: SECURED/NONE
AA ->> BS: SEND: Alice's info and sender's server key (SMP confirmation without reply queues)
note over AA: status: SECURED/CONFIRMED
BS ->> BA: MSG: Alice's info and<br>sender's server key
note over BA: status: CONFIRMED/CONFIRMED
BA ->> B: INFO: Alice's info
BA ->> BS: ACK: confirm message
BA ->> BS: KEY: secure queue
note over BA: status: SECURED/CONFIRMED
BA ->> AS: SEND: HELLO: only needs to be sent once in v2
note over BA: status: SECURED/ACTIVE
note over BA, B: 7a. notify Bob<br>about connection success
BA ->> B: CON: connected
AS ->> AA: MSG: HELLO: Alice's agent<br>knows Bob can send
note over AA: status: SECURED/ACTIVE
AA ->> AS: ACK: confirm message
note over A, AA: 7a. notify Alice<br>about connection success
AA ->> A: CON: connected
AA ->> BS: SEND: HELLO: only needs to be sent once in v2
note over AA: status: ACTIVE/ACTIVE
BS ->> BA: MSG: HELLO: Bob's agent<br>knows Alice can send
note over BA: status: ACTIVE/ACTIVE
BA ->> BS: ACK: confirm message
@@ -8,8 +8,8 @@ sequenceDiagram
note over AA, BA: status (receive/send): NONE/NONE
note over A, AA: 1. request connection from agent
A ->> AA: NEW: create<br>duplex connection
note over A, AA: 1. request connection<br>from agent
A ->> AA: createConnection
note over AA, AS: 2. create Alice's SMP queue
AA ->> AS: NEW: create SMP queue
@@ -17,63 +17,58 @@ sequenceDiagram
note over AA: status: NEW/NONE
AA ->> A: INV: invitation<br>to connect
note over AA: status: PENDING/NONE
note over A, B: 3. out-of-band invitation
A ->> B: OOB: invitation to connect
note over BA, B: 4. accept connection
B ->> BA: JOIN:<br>via invitation info
B ->> BA: joinConnection:<br>via invitation info
note over BA: status: NONE/NEW
note over BA, AA: 5. establish Alice's SMP queue
BA ->> AS: SEND: Bob's info and sender server key (SMP confirmation)
note over BA: status: NONE/CONFIRMED
activate BA
note over BA, BS: 5. create Bob's SMP queue
BA ->> BS: NEW: create SMP queue
BS ->> BA: IDS: SMP queue IDs
note over BA: status: NEW/NEW
note over BA, AA: 6. confirm Alice's SMP queue
BA ->> AS: SEND: Bob's info and sender server key (SMP confirmation with reply queues)
note over BA: status: NEW/CONFIRMED
AS ->> AA: MSG: Bob's info and<br>sender server key
note over AA: status: CONFIRMED/NONE
AA ->> AS: ACK: confirm message
AA ->> A: CONF: connection request ID<br>and Bob's info
A ->> AA: LET: accept connection request,<br>send Alice's info
A ->> AA: allowConnection: accept connection request,<br>send Alice's info
AA ->> AS: KEY: secure queue
note over AA: status: SECURED/NONE
BA ->> AS: SEND: HELLO: try sending until successful
deactivate BA
note over BA: status: NONE/ACTIVE
AS ->> AA: MSG: HELLO: Alice's agent<br>knows Bob can send
note over AA: status: ACTIVE/NONE
AA ->> AS: ACK: confirm message
AA ->> BS: SEND: Alice's info and sender's server key (SMP confirmation without reply queues)
note over AA: status: SECURED/CONFIRMED
note over BA, BS: 6. create Bob's SMP queue
BA ->> BS: NEW: create SMP queue
BS ->> BA: IDS: SMP queue IDs
note over BA: status: NEW/ACTIVE
note over AA, BA: 7. establish Bob's SMP queue
BA ->> AS: SEND: REPLY: invitation to the connect
note over BA: status: PENDING/ACTIVE
AS ->> AA: MSG: REPLY: invitation<br>to connect
note over AA: status: ACTIVE/NEW
AA ->> AS: ACK: confirm message
AA ->> BS: SEND: Alice's info and sender's server key
note over AA: status: ACTIVE/CONFIRMED
activate AA
note over BA, AA: 7. confirm Bob's SMP queue
BS ->> BA: MSG: Alice's info and<br>sender's server key
note over BA: status: CONFIRMED/ACTIVE
note over BA: status: CONFIRMED/CONFIRMED
BA ->> B: INFO: Alice's info
BA ->> BS: ACK: confirm message
BA ->> BS: KEY: secure queue
note over BA: status: SECURED/CONFIRMED
BA ->> AS: SEND: HELLO message
note over BA: status: SECURED/ACTIVE
AA ->> BS: SEND: HELLO: try sending until successful
deactivate AA
AS ->> AA: MSG: HELLO: Alice's agent<br>knows Bob can send
note over AA: status: SECURED/ACTIVE
AA ->> AS: ACK: confirm message
AA ->> BS: SEND: HELLO
note over A, AA: 8. notify Alice<br>about connection success
AA ->> A: CON: connected
note over AA: status: ACTIVE/ACTIVE
BS ->> BA: MSG: HELLO: Bob's agent<br>knows Alice can send
note over BA: status: ACTIVE/ACTIVE
BA ->> BS: ACK: confirm message
note over A, B: 8. notify users about connection success
AA ->> A: CON: connected
note over BA, B: 9. notify Bob<br>about connection success
BA ->> B: CON: connected
File diff suppressed because one or more lines are too long

Before

Width:  |  Height:  |  Size: 35 KiB

After

Width:  |  Height:  |  Size: 40 KiB

@@ -0,0 +1,17 @@
sequenceDiagram
participant A as Alice
participant R as Current server<br>that has A's<br>receive queue
participant R' as New server<br>that has the new A's<br>receive queue
participant S as Server<br>that has A's send queue<br>(B's receive queue)
participant B as Bob
A ->> R': NEW: create new queue<br>(allow SKEY)
A ->> S: SEND: QADD (R'): send address<br>of the new queue(s)
S ->> B: MSG: QADD (R')
B ->> R': SKEY: secure new queue
B ->> R': SEND: QTEST
R' ->> A: MSG: QTEST
A ->> R: DEL: delete the old queue
B ->> R': SEND: send messages to the new queue
R' ->> A: MSG: receive messages from the new queue
File diff suppressed because one or more lines are too long

After

Width:  |  Height:  |  Size: 27 KiB

@@ -0,0 +1,21 @@
sequenceDiagram
participant A as Alice
participant R as Current server<br>that has A's<br>receive queue
participant R' as New server<br>that has the new A's<br>receive queue
participant S as Server<br>that has A's send queue<br>(B's receive queue)
participant B as Bob
A ->> R': NEW: create new queue
A ->> S: SEND: QADD (R'): send address<br>of the new queue(s)
S ->> B: MSG: QADD (R')
B ->> R: SEND: QKEY (R'): sender's key<br>for the new queue(s)
R ->> A: MSG: QKEY(R')
A ->> R': KEY: secure new queue
A ->> S: SEND: QUSE (R'): instruction to use new queue(s)
S ->> B: MSG: QUSE (R')
B ->> R': SEND: QTEST
R' ->> A: MSG: QTEST
A ->> R: DEL: delete the old queue
B ->> R': SEND: send messages to the new queue
R' ->> A: MSG: receive messages from the new queue
File diff suppressed because one or more lines are too long

After

Width:  |  Height:  |  Size: 28 KiB

@@ -0,0 +1,30 @@
sequenceDiagram
participant M as mobile app
participant C as chat core
participant A as agent
participant P as push server
participant APN as APN
note over M, APN: get device token
M ->> APN: registerForRemoteNotifications()
APN ->> M: device token
note over M, P: register device token with push server
M ->> C: /_ntf register <token>
C ->> A: registerNtfToken(<token>)
A ->> P: TNEW
P ->> A: ID (tokenId)
A ->> C: registered
C ->> M: registered
note over M, APN: verify device token
P ->> APN: E2E encrypted code<br>in background<br>notification
APN ->> M: deliver background notification with e2ee verification token
M ->> C: /_ntf verify <e2ee code>
C ->> A: verifyNtfToken(<e2ee code>)
A ->> P: TVFY code
P ->> A: OK / ERR
A ->> C: verified
C ->> M: verified
note over M, APN: now token ID can be used
@@ -1,30 +1,26 @@
sequenceDiagram
participant M as mobile app
participant C as chat core
participant C as client app
participant A as agent
participant P as push server
participant APN as APN
participant P as SimpleX<br>Notification<br>Server
participant APN as Apple<br>Push Notifications<br>Server
note over M, APN: get device token
M ->> APN: registerForRemoteNotifications()
APN ->> M: device token
note over C, APN: get device token
C ->> APN: registerForRemoteNotifications()
APN ->> C: device token
note over M, P: register device token with push server
M ->> C: /_ntf register <token>
C ->> A: registerNtfToken(<token>)
note over C, P: register device token with push server
C ->> A: registerToken
A ->> P: TNEW
P ->> A: ID (tokenId)
A ->> C: registered
C ->> M: registered
note over M, APN: verify device token
note over C, APN: verify device token
P ->> APN: E2E encrypted code<br>in background<br>notification
APN ->> M: deliver background notification with e2ee verification token
M ->> C: /_ntf verify <e2ee code>
C ->> A: verifyNtfToken(<e2ee code>)
APN ->> C: deliver background notification with e2ee verification token
C ->> A: verifyToken<br>(<e2ee code>)
A ->> P: TVFY code
P ->> A: OK / ERR
A ->> C: verified
C ->> M: verified
note over M, APN: now token ID can be used
note over C, APN: now token ID can be used
File diff suppressed because one or more lines are too long

After

Width:  |  Height:  |  Size: 28 KiB

@@ -0,0 +1,40 @@
sequenceDiagram
participant M as mobile app
participant C as chat core
participant A as agent
participant S as SMP server
participant N as NTF server
participant APN as APN
note over M, APN: register subscription
alt register existing
M -->> A: on /_ntf register, for subscribed queues
else create new connection
A -->> S: NEW / JOIN
note over A, S: ...<br>Connection handshake<br>...
S -->> A: CON
end
A ->> S: NKEY nKey
S ->> A: NID nId
A ->> N: SNEW tknId dhKey (smpServer, nId, nKey)
N ->> A: ID subId dhKey
N ->> S: NSUB nId
S ->> N: OK [/ NMSG]
note over M, APN: notify about message
S ->> N: NMSG
N ->> APN: APNSMutableContent<br>ntfQueue, nonce
APN ->> M: UNMutableNotificationContent
note over M, S: ...<br>Client awaken, message is received<br>...
S ->> M: message
note over M: mutate notification
note over M, APN: change APN token
APN ->> M: new device token
M -->> C: /_ntf_sub update tkn
C -->> A: updateNtfToken()
A -->> N: TUPD tknId newDeviceToken
note over M, N: ...<br>Verify token<br>...
@@ -1,17 +1,16 @@
sequenceDiagram
participant M as mobile app
participant C as chat core
participant C as client app
participant A as agent
participant S as SMP server
participant N as NTF server
participant APN as APN
note over M, APN: register subscription
note over C, APN: register subscription
alt register existing
M -->> A: on /_ntf register, for subscribed queues
C -->> A: registerToken
else create new connection
A -->> S: NEW / JOIN
A -->> S: create/joinConnection
note over A, S: ...<br>Connection handshake<br>...
S -->> A: CON
end
@@ -20,21 +19,20 @@ sequenceDiagram
A ->> N: SNEW tknId dhKey (smpServer, nId, nKey)
N ->> A: ID subId dhKey
N ->> S: NSUB nId
S ->> N: OK [/ NMSG]
S ->> N: OK / NMSG:<br>confirm subscription
note over M, APN: notify about message
note over C, APN: notify about message
S ->> N: NMSG
N ->> APN: APNSMutableContent<br>ntfQueue, nonce
APN ->> M: UNMutableNotificationContent
note over M, S: ...<br>Client awaken, message is received<br>...
S ->> M: message
note over M: mutate notification
APN ->> C: UNMutableNotificationContent
note over C, S: ...<br>Client awaken, message is received<br>...
S ->> C: message
note over C: show notification
note over M, APN: change APN token
note over C, APN: change APN token
APN ->> M: new device token
M -->> C: /_ntf_sub update tkn
C -->> A: updateNtfToken()
APN ->> C: new device token
C -->> A: updateToken()
A -->> N: TUPD tknId newDeviceToken
note over M, N: ...<br>Verify token<br>...
note over C, N: ...<br>Verify token<br>...
File diff suppressed because one or more lines are too long

After

Width:  |  Height:  |  Size: 31 KiB

@@ -0,0 +1,23 @@
sequenceDiagram
participant B as Bob (sender)
participant S as server (queue RID)
participant A as Alice (recipient)
note over A: creating queue<br>("public" key RK<br>for msg retrieval)
A ->> S: 1. create queue ("NEW")
S ->> A: respond with queue RID and SID ("IDS")
note over A: out-of-band msg<br>(sender's queue SID<br>and "public" key EK<br>to encrypt msgs)
A -->> B: 2. send out-of-band message
note over B: secure queue<br>(with "public" key SK for<br>sending messages)
B ->> S: 3. confirm queue ("SKEY" command authorized with SK)
note over B: confirm queue<br>(public key<br>for e2e encryption<br>and any optional<br>encrypted info.)
B ->> S: 4. confirm queue ("SEND" command authorized with SK)
S ->> A: 5. deliver Bob's message (MSG)
note over A: decrypt message<br>("private" key EK)
A ->> S: acknowledge message (ACK)
note over S: 6. simplex<br>queue RID<br>is ready to use!
File diff suppressed because one or more lines are too long

After

Width:  |  Height:  |  Size: 27 KiB

@@ -10,11 +10,13 @@ sequenceDiagram
note over A: out-of-band msg<br>(sender's queue SID<br>and "public" key EK<br>to encrypt msgs)
A -->> B: 2. send out-of-band message
note over B: confirm queue<br>("public" key SK for<br>sending messages<br>and any optional<br>info encrypted with<br>"public" key EK)
note over B: confirm queue<br>("public" key SK for<br>sending messages,<br>public key for<br>e2e encryption<br>and any optional<br>encrypted info)
B ->> S: 3. confirm queue ("SEND" command not signed)
S ->> A: 4. deliver Bob's message
S ->> A: 4. deliver Bob's message (MSG)
note over A: decrypt message<br>("private" key EK)
A ->> S: acknowledge message (ACK)
A ->> S: 5. secure queue ("KEY", RK-signed)
note over S: 6. simplex<br>queue RID<br>is ready to use!
File diff suppressed because one or more lines are too long

Before

Width:  |  Height:  |  Size: 13 KiB

After

Width:  |  Height:  |  Size: 26 KiB

@@ -0,0 +1,18 @@
sequenceDiagram
participant B as Bob (recipient)
participant S as XFTP server(s)
note over B: having received file description<br>from sender
loop for each chunk
B ->> S: 1a. download chunk ("FGET")
S ->> B: send chunk body ("FILE")
opt
B ->> S: 1b. acknowledge chunk reception ("FACK")
note over S: delete recipient ID
S ->> B: respond with ok ("OK")
end
end
note over B: 2. combine chunks into a file<br>3. decrypt file using key from file description<br>4. extract file name and unpad the file<br>5. validate file digest with the file description
File diff suppressed because one or more lines are too long

After

Width:  |  Height:  |  Size: 23 KiB

@@ -0,0 +1,23 @@
sequenceDiagram
participant A as Alice (sender)
participant S as XFTP server(s)
participant B as recipient(s)
note over A: 1. prepare file:<br>encrypt,<br>split into chunks,<br>generate recipient<br>keys, etc.
loop for each chunk
A ->> S: 2a. register chunk ("FNEW")
S ->> A: respond with sender's and recipients' chunk IDs ("SIDS")
opt
A ->> S: 2b. request additional recipient IDs ("FADD")
S ->> A: respond with added recipients' chunk IDs ("RIDS")
end
A ->> S: 2c. upload chunk to chosen server ("FPUT")
S ->> A: respond with ok ("OK")
end
note over A: 3. prepare file description(s)
A -->> B: 4. send file description(s) out-of-band
File diff suppressed because one or more lines are too long

After

Width:  |  Height:  |  Size: 25 KiB

+44
View File
@@ -0,0 +1,44 @@
sequenceDiagram
participant CI as Controller UI
participant CC as Controller Core
participant HC as Host Core
participant HI as Host UI
note over CI, HI: 1. Session invitation
CI->>CC: "Link a mobile"
CC-->>CI: Session invitation URI
note over CC: Listen for TCP connection
activate CC
HI->>HC: Session invitation URI
note over CI, HI: 2. Establishing TLS connection
HC-->>CC: TCP connect
note over CC, HC: TLS handshake
par
note over CC: validate client X509 credentials
CC->>CI: session code from tlsUnique
CI-->>CC: user confirmation
and
note over HC: validate server X509 credentials
HC->>HI: session code from tlsUnique
HI-->>HC: user confirmation
end
note over CI, HI: 3. Session verification and protocol negotiation
HC->>CC: host HELLO
note over CC: validate version, CA fingerprint
alt
CC-->>HC: controller ERROR
else
CC-->>HC: controller HELLO
note over CC, HC: update stored keys
end
deactivate CC
note over CI, HI: 4. Session operation
loop
CI->>CC: command
CC->>HC: XRCP command
HC-->>CC: XRCP response
CC-->>CI: response
end
File diff suppressed because one or more lines are too long

After

Width:  |  Height:  |  Size: 31 KiB

+127 -56
View File
@@ -1,4 +1,4 @@
Revision 1, 2022-01-01
Revision 2, 2024-06-22
Evgeny Poberezkin
@@ -13,19 +13,23 @@ Evgeny Poberezkin
- [Technical Details](#technical-details)
- [Trust in Servers](#trust-in-servers)
- [Client -> Server Communication](#client---server-communication)
- [2-hop Onion Message Routing](#2-hop-onion-message-routing)
- [SimpleX Messaging Protocol](#simplex-messaging-protocol)
- [SimpleX Agents](#simplex-agents)
- [Encryption Primitives Used](#encryption-primitives-used)
- [Threat model](#threat-model)
- [Acknowledgements](#acknowledgements)
## Introduction
#### What is SimpleX
SimpleX as a whole is a platform upon which applications can be built. [SimpleX Chat](https://github.com/simplex-chat/simplex-chat) is one such application that also serves as an example and reference application.
- [SimpleX Messaging Protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) (SMP) is a protocol to send messages in one direction to a recipient, relying on a server in-between. The messages are delivered via uni-directional queues created by recipients.
- [SimpleX Messaging Protocol](./simplex-messaging.md) (SMP) is a protocol to send messages in one direction to a recipient, relying on a server in-between. The messages are delivered via uni-directional queues created by recipients.
- SMP protocol allows to send message via a SMP server playing proxy role using 2-hop onion routing (referred to as "private routing" in messaging clients) to protect transport information of the sender (IP address and session) from the server chosen (and possibly controlled) by the recipient.
- SMP runs over a transport protocol (shown below as TLS) that provides integrity, server authentication, confidentiality, and transport channel binding.
@@ -35,7 +39,9 @@ SimpleX as a whole is a platform upon which applications can be built. [SimpleX
- SimpleX Client libraries speak SMP to SimpleX Servers and provide a low-level API not generally intended to be used by applications.
- SimpleX Agents interface with SimpleX Clients to provide a more high-level API intended to be used by applications. Typically they are embedded as libraries, but are designed so they can also be abstracted into local services.
- SimpleX Agents interface with SimpleX Clients to provide a more high-level API intended to be used by applications. Typically they are embedded as libraries, but can also be abstracted into local services.
- SimpleX Agents communicate with other agents inside e2e encrypted envelopes provided by SMP protocol - the syntax and semantics of the messages exchanged by the agent are defined by [SMP agent protocol](./agent-protocol.md)
*Diagram showing the SimpleX Chat app, with logical layers of the chat application interfacing with a SimpleX Agent library, which in turn interfaces with a SimpleX Client library. The Client library in turn speaks the Messaging Protocol to a SimpleX Server.*
@@ -72,10 +78,11 @@ SimpleX as a whole is a platform upon which applications can be built. [SimpleX
- Low latency: the delay introduced by the network should not be higher than 100ms-1s in addition to the underlying TCP network latency.
2. Provide better communication security and privacy than the alternative instant messaging solutions. In particular SimpleX provides better privacy of metadata (who talks to whom and when) and better security against active network attackers and malicious servers.
2. Provide better communication security and privacy than the alternative instant messaging solutions. In particular SimpleX provides better privacy of metadata (who talks to whom and when) and better security against active network attackers and malicious servers.
3. Balance user experience with privacy requirements, prioritizing experience of mobile device users.
#### In Comparison
SimpleX network has a design similar to P2P networks, but unlike most P2P networks it consists of clients and servers without depending on any centralized component.
@@ -91,53 +98,73 @@ In comparison to more traditional messaging applications (e.g. WhatsApp, Signal,
- users can change servers with minimal disruption - even after an in-use server disappears, simply by changing the configuration on which servers the new queues are created.
## Technical Details
#### Trust in Servers
Clients communicate directly with servers (but not with other clients) using SimpleX Messaging Protocol (SMP) running over some transport protocol that provides integrity, server authentication, confidentiality, and transport channel binding. By default, we assume this transport protocol is TLS.
Users use multiple servers, and choose where to receive their messages. Accordingly, they send messages to their communication partners' chosen servers.
Users use multiple servers, and choose where to receive their messages. Accordingly, they send messages to their communication partners' chosen servers either directly, if this is a known/trusted server, or via another SMP server providing proxy functionality to protect IP address and session of the sender.
Although end-to-end encryption is always present, users place a degree of trust in servers. This trust decision is very similar to a user's choice of email provider; however the trust placed in a SimpleX server is significantly less. Notably, there is no re-used identifier or credential between queues on the same (or different) servers. While a user *may* re-use a connection to fetch from multiple queues, or connect to a server from the same IP address, both are choices a user may opt into to break the promise of un-correlatable queues.
Although end-to-end encryption is always present, users place a degree of trust in servers they connect to. This trust decision is very similar to a user's choice of email provider; however the trust placed in a SimpleX server is significantly less. Notably, there is no re-used identifier or credential between queues on the same (or different) servers. While a user *may* re-use a transport connection to fetch messages from multiple queues, or connect to a server from the same IP address, both are choices a user may opt into to break the promise of un-correlatable queues.
Users may trust a server because:
- They deploy and control the servers themselves from the available open-source code. This has the trade-offs of strong trust in the server but limited metadata obfuscation to a passive network observer. Techniques such as noise traffic, traffic mixing (incurring latency), and using an onion routing transport protocol can mitigate that latter.
- They deploy and control the servers themselves from the available open-source code. This has the trade-offs of strong trust in the server but limited metadata obfuscation to a passive network observer. Techniques such as noise traffic, traffic mixing (incurring latency), and using an onion routing transport protocol can mitigate that.
- They use servers from a trusted commercial provider. The more clients the provider has, the less metadata about the communication times is leaked to the network observers.
- Users trust their contacts and the servers they chose.
By default, servers do not retain access logs, and permanently delete messages and queues when requested. Messages persist only in memory until they cross a threshold of time, typically on the order of days.[0] There is still a risk that a server maliciously records all queues and messages (even though encrypted) sent via the same transport connection to gain a partial knowledge of the user’s communications graph and other meta-data.
By default, servers do not retain access logs, and permanently delete messages and queues when requested. Messages persist only in memory until they cross a threshold of time, typically on the order of days.[0] There is still a risk that a server maliciously records all queues and messages (even though encrypted) sent via the same transport connection to gain a partial knowledge of the user’s communications graph and other meta-data.
SimpleX supports measures (managed transparently to the user at the agent level) to mitigate the trust placed in servers. These include rotating the queues in use between users, noise traffic, supporting overlay networks such as Tor, and isolating traffic to different queues to different transport connections (and Tor circuits, if Tor is used).
SimpleX supports measures (managed transparently to the user at the agent level) to mitigate the trust placed in servers. These include rotating the queues in use between users, noise traffic, and supporting overlay networks such as Tor.
[0] While configurable by servers, a minimum value is enforced by the default software. SimpleX Agents provide redundant routing over queues to mitigate against message loss.
[0] While configurable by servers, a minimum value is enforced by the default software. SimpleX Agents can provide redundant routing over queues to mitigate against message loss.
#### Client -> Server Communication
Utilizing TLS grants the SimpleX Messaging Protocol (SMP) server authentication and metadata protection to a passive network observer. But SMP does not rely on the transport protocol for message confidentiality or client authentication. The SMP protocol itself provides end-to-end confidentiality, authentication, and integrity of messages between communicating parties.
Servers have long-lived, self-signed, offline certificates whose hash is pre-shared with clients over secure channels - either provided with the client library or provided in the secure introduction between clients. The offline certificate signs an online certificate used in the transport protocol handshake. [0]
Servers have long-lived, self-signed, offline certificates whose hash is pre-shared with clients over secure channels - either provided with the client library or provided in the secure introduction between clients, as part of the server address. The offline certificate signs an online certificate used in the transport protocol handshake. [0]
If the transport protocol's confidentiality is broken, incoming and outgoing messages to the server cannot be correlated by message contents. Additionally, because of encryption at the SMP layer, impersonating the server is not sufficient to pass (and therefore correlate) a message from a sender to recipient - the only attack possible is to drop the messages. Only by additionally *compromising* the server can one pass and correlate messages.
It's important to note that the SMP protocol does not do server authentication. Instead we rely upon the fact that an attacker who tricks the transport protocol into authenticating the server incorrectly cannot do anything with the SMP messages except drop them.
After the connection is established, the client sends blocks of a fixed size 16Kb, and the server replies with the blocks of the same size to reduce metadata observable to a network adversary. The protocol has been designed to make traffic correlation attacks difficult, adapting ideas from Tor, remailers, and more general onion and mix networks. It does not try to replace Tor though - SimpleX servers can be deployed as onion services and SimpleX clients can communicate with servers over Tor to further improve participants privacy.
After the connection is established, the client sends blocks of a fixed size 16KB, and the server replies with the blocks of the same size to reduce metadata observable to a network adversary. The protocol has been designed to make traffic correlation attacks difficult, adapting ideas from Tor, remailers, and more general onion and mix networks. It does not try to replace Tor though - SimpleX servers can be deployed as onion services and SimpleX clients can communicate with servers over Tor to further improve participants privacy.
By using fixed-size blocks, oversized for the expected content, the vast majority of traffic is uniform in nature. When enough traffic is transiting a server simultaneously, the server acts as a (very) low-latency mix node. We can't rely on this behavior to make a security claim, but we have engineered to take advantage of it when we can. As mentioned, this holds true even if the transport connection is compromised.
By using fixed-size blocks, oversized for the expected content, the vast majority of traffic is uniform in nature. When enough traffic is transiting a server simultaneously, the server acts as a low-latency mix node. We can't rely on this behavior to make a security claim, but we have engineered to take advantage of it when we can. As mentioned, this holds true even if the transport connection is compromised.
The protocol does not protect against attacks targeted at particular users with known identities - e.g., if the attacker wants to prove that two known users are communicating, they can achieve it. At the same time, it substantially complicates large-scale traffic correlation, making determining the real user identities much less effective.
The protocol does not protect against attacks targeted at particular users with known identities - e.g., if the attacker wants to prove that two known users are communicating, they can achieve it by observing their local traffic. At the same time, it substantially complicates large-scale traffic correlation, making determining the real user identities much less effective.
[0] Future versions of SMP may add support for revocation lists of certificates, presently this risk is mitigated by the SMP protocol itself.
#### 2-hop Onion Message Routing
As SimpleX Messaging Protocol servers providing messaging queues are chosen by the recipients, in case senders connect to these servers directly the server owners (who potentially can be the recipients themselves) can learn senders' IP addresses (if Tor is not used) and which other queues on the same server are accessed by the user in the same transport connection (even if Tor is used).
While the clients support isolating the messages sent to different queues into different transport connections (and Tor circuits), this is not practical, as it consumes additional traffic and system resources.
To mitigate this problem SimpleX Messaging Protocol servers support 2-hop onion message routing when the SMP server chosen by the sender forwards the messages to the servers chosen by the recipients, thus protecting both the senders IP addresses and sessions, even if connection isolation and Tor are not used.
The design of 2-hop onion message routing prevents these potential attacks:
- MITM by proxy (SMP server that forwards the messages).
- Identification by the proxy which and how many queues the sender sends messages to (as messages are additionally e2e encrypted between the sender and the destination SMP server).
- Correlation of messages sent to different queues via the same user session (as random correlation IDs and keys are used for each message).
See more details about 2-hop onion message routing design in [SimpleX Messaging Protocol](./simplex-messaging.md#proxying-sender-commands)
Also see [Threat model](#threat-model)
#### SimpleX Messaging Protocol
SMP is initialized with an in-person or out-of-band introduction message, where Alice provides Bob with details of a server (including IP, port, and hash of the long-lived offline certificate), a queue ID, and Alice's public key for her receiving queue. These introductions are similar to the PANDA key-exchange, in that if observed, the adversary can race to establish the communication channel instead of the intended participant. [0]
SMP is initialized with an in-person or out-of-band introduction message, where Alice provides Bob with details of a server (including IP address or host name, port, and hash of the long-lived offline certificate), a queue ID, and Alice's public keys to agree e2e encryption. These introductions are similar to the PANDA key-exchange, in that if observed, the adversary can race to establish the communication channel instead of the intended participant. [0]
Because queues are uni-directional, Bob provides an identically-formatted introduction message to Alice over Alice's now-established receiving queue.
@@ -145,6 +172,7 @@ When setting up a queue, the server will create separate sender and recipient qu
[0] Users can additionally create public 'contact queues' that are only used to receive connection requests.
#### SimpleX Agents
SimpleX agents provide higher-level operations compared to SimpleX Clients, who are primarily concerned with creating queues and communicating with servers using SMP. Agent operations include:
@@ -157,9 +185,10 @@ SimpleX agents provide higher-level operations compared to SimpleX Clients, who
- Noise traffic
#### Encryption Primitives Used
- Ed448 to sign/verify commands to SMP servers (Ed25519 is also supported via client/server configuration).
- Ed25519 or Curve25519 to authorize/verify commands to SMP servers (authorization algorithm is set via client/server configuration).
- Curve25519 for DH exchange to agree:
- the shared secret between server and recipient (to encrypt message bodies - it avoids shared cipher-text in sender and recipient traffic)
- the shared secret between sender and recipient (to encrypt messages end-to-end in each queue - it avoids shared cipher-text in redundant queues).
@@ -170,42 +199,44 @@ SimpleX agents provide higher-level operations compared to SimpleX Clients, who
- AES-GCM AEAD cipher,
- SHA512-based HKDF for key derivation.
## Threat Model
#### Global Assumptions
- A user protects their local database and key material
- The user's application is authentic, and no local malware is running
- The cryptographic primitives in use are not broken
- A user protects their local database and key material.
- The user's application is authentic, and no local malware is running.
- The cryptographic primitives in use are not broken.
- A user's choice of servers is not directly tied to their identity or otherwise represents distinguishing information about the user.
- The user's client uses 2-hop onion message routing.
#### A passive adversary able to monitor the traffic of one user
*can:*
- identify that and when a user is using SimpleX
- identify that and when a user is using SimpleX.
- block SimpleX traffic
- determine which servers the user communicates with
- determine which servers the user receives the messages from.
- observe how much traffic is being sent, and make guesses as to its purpose.
*cannot:*
- see who sends messages to the user and who the user sends the messages to
- see who sends messages to the user and who the user sends the messages to.
- determine the servers used by users' contacts.
#### A passive adversary able to monitor a set of senders and recipients
*can:*
- identify who and when is using SimpleX
- identify who and when is using SimpleX.
- learn which SimpleX Messaging Protocol servers are used as receive queues for which users
- learn which SimpleX Messaging Protocol servers are used as receive queues for which users.
- learn when messages are sent and received
- learn when messages are sent and received.
- perform traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers
- perform traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers.
- observe how much traffic is being sent, and make guesses as to its purpose
@@ -217,43 +248,83 @@ SimpleX agents provide higher-level operations compared to SimpleX Clients, who
*can:*
- learn when a queue recipient or sender is online
- learn when a queue recipient is online
- know how many messages are sent via the queue (although some may be noise)
- know how many messages are sent via the queue (although some may be noise or not content messages).
- perform queue correlation (matching multiple queues to a single user) via either a re-used transport connection, user's IP Address, or connection timing regularities
- learn which messages would trigger notifications even if a user does not use [push notifications](./push-notifications.md).
- learn a user's IP address, track them through other IP addresses they use to access the same queue, and infer information (e.g. employer) based on the IP addresses, as long as Tor is not used.
- perform the correlation of the queue used to receive messages (matching multiple queues to a single user) via either a re-used transport connection, user's IP Address, or connection timing regularities.
- drop all future messages inserted into a queue, detectable only over other, redundant queues
- learn a recipient's IP address, track them through other IP addresses they use to access the same queue, and infer information (e.g. employer) based on the IP addresses, as long as Tor is not used.
- drop all future messages inserted into a queue, detectable only over other, redundant queues.
- lie about the state of a queue to the recipient and/or to the sender (e.g. suspended or deleted when it is not).
- spam a user with invalid messages
- spam a user with invalid messages.
*cannot:*
- undetectably add, duplicate, or corrupt individual messages
- undetectably add, duplicate, or corrupt individual messages.
- undetectably drop individual messages, so long as a subsequent message is delivered
- undetectably drop individual messages, so long as a subsequent message is delivered.
- learn the contents of messages
- learn the contents or type of messages.
- distinguish noise messages from regular messages except via timing regularities
- distinguish noise messages from regular messages except via timing regularities.
- compromise the user's end-to-end encryption with an active attack
- compromise the users' end-to-end encryption with an active attack.
- learn a sender's IP address, track them through other IP addresses they use to access the same queue, and infer information (e.g. employer) based on the IP addresses, even if Tor is not used (provided messages are sent via proxy SMP server).
- perform senders' queue correlation (matching multiple queues to a single sender) via either a re-used transport connection, user's IP Address, or connection timing regularities, unless it has additional information from the proxy SMP server (provided messages are sent via proxy SMP server).
#### SimpleX Messaging Protocol server that proxies the messages to another SMP server
*can:*
- learn a sender's IP address, as long as Tor is not used.
- learn when a sender with a given IP address is online.
- know how many messages are sent from a given IP address and to a given destination SMP server.
- drop all messages from a given IP address or to a given destination server.
- unless destination SMP server detects repeated public DH keys of senders, replay messages to a destination server within a single session, causing either duplicate message delivery (which will be detected and ignored by the receiving clients), or, when receiving client is not connected to SMP server, exhausting capacity of destination queues used within the session.
*cannot:*
- perform queue correlation (matching multiple queues to a single user), unless it has additional information from the destination SMP server.
- undetectably add, duplicate, or corrupt individual messages.
- undetectably drop individual messages, so long as a subsequent message is delivered.
- learn the contents or type of messages.
- learn which messages would trigger notifications.
- learn the destination queues of messages.
- distinguish noise messages from regular messages except via timing regularities.
- compromise the user's end-to-end encryption with another user via an active attack.
- compromise the user's end-to-end encryption with the destination SMP servers via an active attack.
#### An attacker who obtained Alice's (decrypted) chat database
*can:*
- see the history of all messages exchanged by Alice with her communication partners
- see the history of all messages exchanged by Alice with her communication partners.
- see shared profiles of contacts and groups
- see shared profiles of contacts and groups.
- surreptitiously receive new messages sent to Alice via existing queues; until communication queues are rotated or the Double-Ratchet advances forward
- surreptitiously receive new messages sent to Alice via existing queues; until communication queues are rotated or the Double-Ratchet advances forward.
- prevent Alice from receiving all new messages sent to her - either surreptitiously by emptying the queues regularly or overtly by deleting them
- prevent Alice from receiving all new messages sent to her - either surreptitiously by emptying the queues regularly or overtly by deleting them.
- send messages from the user to their contacts; recipients will detect it as soon as the user sends the next message, because the previous message hash won’t match (and potentially won’t be able to decrypt them in case they don’t keep the previous ratchet keys).
@@ -269,41 +340,41 @@ SimpleX agents provide higher-level operations compared to SimpleX Clients, who
*can:*
- spam the user with messages
- spam the user with messages.
- forever retain messages from the user
- forever retain messages from the user.
*cannot:*
- cryptographically prove to a third-party that a message came from a user (assuming the user’s device is not seized)
- cryptographically prove to a third-party that a message came from a user (assuming the user’s device is not seized).
- prove that two contacts they have is the same user
- prove that two contacts they have is the same user.
- cannot collaborate with another of the user's contacts to confirm they are communicating with the same user
- cannot collaborate with another of the user's contacts to confirm they are communicating with the same user.
#### An attacker who observes Alice showing an introduction message to Bob
*can:*
- Impersonate Bob to Alice
- Impersonate Bob to Alice.
*cannot:*
- Impersonate Alice to Bob
- Impersonate Alice to Bob.
#### An attacker with Internet access
*can:*
- Denial of Service SimpleX messaging servers
- Denial of Service SimpleX messaging servers.
- spam a user's public “contact queue” with connection requests
- spam a user's public “contact queue” with connection requests.
*cannot:*
- send messages to a user who they are not connected with
- send messages to a user who they are not connected with.
- enumerate queues on a SimpleX server
- enumerate queues on a SimpleX server.
## Acknowledgements
+222
View File
@@ -0,0 +1,222 @@
Version 1, 2024-06-22
# Post-quantum resistant augmented double ratchet algorithm (PQDR)
## Table of contents
- [Overview](#overview)
- [Comparison with the other approaches](#comparison-with-the-other-approaches)
- [PQXDH for post-quantum key agreement](#pqxdh-for-post-quantum-key-agreement) (Signal)
- [Hybrid Signal protocol for post-quantum encryption](#hybrid-signal-protocol-for-post-quantum-encryption) (Tutanota)
- [Augmented double ratchet algorithm](#augmented-double-ratchet-algorithm)
- [Double ratchet with encrypted headers augmented with double PQ KEM](#double-ratchet-with-encrypted-headers-augmented-with-double-pq-kem)
- [Initialization](#initialization)
- [Encrypting messages](#encrypting-messages)
- [Decrypting messages](#decrypting-messages)
- [Implementation considerations](#implementation-considerations)
- [Chosen KEM algorithm](#chosen-kem-algorithm)
- [Summary](#summary)
## Overview
It is a reasonable assumption that "record-now-decrypt-later" attacks are ongoing, so the users want to use cryptographic schemes for end-to-end encryption that are augmented with some post-quantum algorithm that is believed to be resistant to quantum computers.
SimpleX Chat uses [double-ratchet with header encryption](https://signal.org/docs/specifications/doubleratchet/#double-ratchet-with-header-encryption) to provide end-to-end encryption to messages and files. This document describes augmented algorithm with post-quantum key encapsulation mechanism (KEM) making it resistant to quantum computers.
Double-ratchet algorithm is a state of the art solution for end to end encryption offering a set of qualities that is not present in any other algorithm:
- perfect forward secrecy, i.e. compromise of session or long term keys does not lead to the ability to decrypt any of the past messages.
- deniability (also known as repudiation), i.e. the fact that the recipient of the message while having the proof of message authenticity, cannot prove to a third party that the sender actually sent this message.
- break-in recovery (also know as post-compromise security or future secrecy), i.e. the ability of the end-to-end encryption security to recover from the compromise of the long term keys. This is achieved by generating a new random key pair whenever a new DH key is received (DH ratchet step).
It is desirable to preserve all these qualities when augmenting the algorithm with a post-quantum algorithm, and having these qualities resistant to both conventional and quantum computers.
## Comparison with the other approaches
### PQXDH for post-quantum key agreement
[The solution](https://signal.org/docs/specifications/pqxdh/) recently [introduced by Signal](https://signal.org/blog/pqxdh/) augments the initial key agreement ([X3DH](https://signal.org/docs/specifications/x3dh/)) that is made prior to double ratchet algorithm. This is believed to provide protection from "record-now-decrypt-later" attack, but if the attacker at any point obtains long term keys from any of the devices, the break-in recovery will not be post-quantum resistant, and the attacker with quantum computer will be able to decrypt all the subsequent messages.
### Hybrid Signal protocol for post-quantum encryption
[The solution](https://eprint.iacr.org/2021/875.pdf) [proposed by Tutanota](https://tutanota.com/blog/posts/pqmail-update/) aims to preserve the break-in recovery property of double ratchet, but in doing so it:
- replaces rather than augments DH key agreement with post-quantum KEM mechanism, making it potentially vulnerable to conventional computers.
- adds signature to the DH ratchet step, to compensate for not keeping DH key agreement, but losing the deniability property for some of the messages.
## Augmented double ratchet algorithm
The double ratchet algorithm is augmented with post-quantum KEM mechanism, preserving all properties of the double ratchet algorithm.
It is possible, because although double ratchet uses DH (which is a non-interactive key exchanges), it uses it "interactively", when the new DH keys are generated by both parties in turns. Parties of double-ratchet encrypted communication can run two post-quantum key encapsulation mechanisms in parallel with both DH and KEM key agreements in each DH ratchet step, making break-in recovery of double ratchet algorithm post-quantum resistant, without losing deniability or resistance to conventional computers.
Specifically, [double ratchet with encrypted headers](https://signal.org/docs/specifications/doubleratchet/#double-ratchet-with-header-encryption) is augmented with some post-quantum key encapsulation mechanism (KEM) as described below. A possible algorithm for PQ KEM is [NTRU-prime](https://ntruprime.cr.yp.to), that is currently adopted in SSH and has available implementations. It is important though that the proposed scheme can be used with any PQ KEM algorithm.
The downside of the scheme is its substantial size overhead, as the encapsulation key and encapsulated shared secret are added to the header of each message. For the algorithm described below NTRU-prime adds ~2-4kb to each message (depending on the key size and the chosen variant). See [this table](https://ntruprime.cr.yp.to/security.html) for key and ciphertext sizes and the assessment of the security level for various key sizes.
It is possible to reduce size overhead by using only one KEM agreement and making only one of two ratchet steps providing post-quantum resistant break-in recovery.
## Double ratchet with encrypted headers augmented with double PQ KEM
Algorithm below assumes that in addition to shared secret from the initial key agreement, there will be an encapsulation key available from the party that published its keys (Bob).
### Initialization
The double ratchet initialization is defined in pseudo-code. This pseudo-code is identical to Signal algorithm specification except for that parts that add post-quantum key agreement.
```
// Alice obtained Bob's keys and initializes ratchet first
def RatchetInitAlicePQ2HE(state, SK, bob_dh_public_key, shared_hka, shared_nhkb, bob_pq_kem_encapsulation_key):
state.DHRs = GENERATE_DH()
state.DHRr = bob_dh_public_key
// below added for post-quantum KEM
state.PQRs = GENERATE_PQKEM()
state.PQRr = bob_pq_kem_encapsulation_key
state.PQRss = random // shared secret for KEM
state.PQRct = PQKEM-ENC(state.PQRr, state.PQRss) // encapsulated additional shared secret
// above added for KEM
// the next line augments DH key agreement with PQ shared secret
state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr) || state.PQRss)
state.CKr = None
state.Ns = 0
state.Nr = 0
state.PN = 0
state.MKSKIPPED = {}
state.HKs = shared_hka
state.HKr = None
state.NHKr = shared_nhkb
// Bob initializes ratchet second, having received Alice's connection request
def RatchetInitBobPQ2HE(state, SK, bob_dh_key_pair, shared_hka, shared_nhkb, bob_pq_kem_key_pair):
state.DHRs = bob_dh_key_pair
state.DHRr = None
// below added for KEM
state.PQRs = bob_pq_kem_key_pair
state.PQRr = None
state.PQRss = None
state.PQRct = None
// above added for KEM
state.RK = SK
state.CKs = None
state.CKr = None
state.Ns = 0
state.Nr = 0
state.PN = 0
state.MKSKIPPED = {}
state.HKs = None
state.NHKs = shared_nhkb
state.HKr = None
state.NHKr = shared_hka
```
`GENERATE_PQKEM` generates decapsulation/encapsulation key pair.
`PQKEM-ENC` is key encapsulation algorithm.
Other than commented lines, the above adds parameters `bob_pq_kem_encapsulation_key` and `bob_pq_kem_key_pair` to the ratchet initialization. Otherwise it is identical to the original double ratchet initialization.
### Encrypting messages
```
def RatchetEncryptPQ2HE(state, plaintext, AD):
state.CKs, mk = KDF_CK(state.CKs)
// encapsulation key from PQRs and encapsulated shared secret is added to header
header = HEADER_PQ2(
dh = state.DHRs.public,
kem = state.PQRs.public, // added for KEM #2
ct = state.PQRct // added for KEM #1
pn = state.PN,
n = state.Ns,
)
enc_header = HENCRYPT(state.HKs, header)
state.Ns += 1
return enc_header, ENCRYPT(mk, plaintext, CONCAT(AD, enc_header))
```
Other than adding encapsulation key and encapsulated shared secret into the header, the above is identical to the original double ratchet message encryption step.
### Decrypting messages
```
def RatchetDecryptPQ2HE(state, enc_header, ciphertext, AD):
plaintext = TrySkippedMessageKeysHE(state, enc_header, ciphertext, AD)
if plaintext != None:
return plaintext
header, dh_ratchet = DecryptHeader(state, enc_header) // DecryptHeader is the same as in double ratchet specification
if dh_ratchet:
SkipMessageKeysHE(state, header.pn) // SkipMessageKeysHE is the same as in double ratchet specification
DHRatchetPQ2HE(state, header)
SkipMessageKeysHE(state, header.n)
state.CKr, mk = KDF_CK(state.CKr)
state.Nr += 1
return DECRYPT(mk, ciphertext, CONCAT(AD, enc_header))
// DecryptHeader is the same as in double ratchet specification
def DecryptHeader(state, enc_header):
header = HDECRYPT(state.HKr, enc_header)
if header != None:
return header, False
header = HDECRYPT(state.NHKr, enc_header)
if header != None:
return header, True
raise Error()
def DHRatchetPQ2HE(state, header):
state.PN = state.Ns
state.Ns = 0
state.Nr = 0
state.HKs = state.NHKs
state.HKr = state.NHKr
state.DHRr = header.dh
// save new encapsulation key from header
state.PQRr = header.kem
// decapsulate shared secret from header - KEM #2
ss = PQKEM-DEC(state.PQRs.private, header.ct)
// use decapsulated shared secret with receiving ratchet
state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || ss)
state.DHRs = GENERATE_DH()
// below is added for KEM
state.PQRs = GENERATE_PQKEM() // generate new PQ key pair
state.PQRss = random // shared secret for KEM
state.PQRct = PQKEM-ENC(state.PQRr, state.PQRss) // encapsulated additional shared secret KEM #1
// above is added for KEM
// use new shared secret with sending ratchet
state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || state.PQRss)
```
`PQKEM-DEC` is key decapsulation algorithm.
`DHRatchetPQ2HE` augments both DH agreements with decapsulated shared secret from the received header and with the new shared secret, respectively. The new shared secret together with the new encapsulation key are saved in the state and will be added to the header in the next sent message.
Other than augmenting DH key agreements with the shared secrets from KEM, the above is identical to the original double ratchet DH ratchet step.
It is worth noting that while DH agreements work as ping-pong, when the new received DH key is used for both DH agreements (and only the sent DH key is updated for the second DH key agreement), PQ KEM agreements in the proposed scheme work as a "parallel ping-pong", with two balls in play all the time (two KEM agreements run in parallel).
## Implementation considerations for SimpleX Messaging Protocol
As SimpleX Messaging Protocol pads messages to a fixed size, using 16kb transport blocks, the size increase introduced by this scheme can be compensated for by using ZSTD encryption of JSON bodies and image previews encoded as base64. While there may be some rare cases of random texts that would fail to compress, in all real scenarios it would not cause the message size reduction.
Sharing the initial keys in case of SimpleX Chat it is equivalent to sharing the invitation link. As encapsulation key is large, it may be inconvenient to share it in the link in some contexts, e.g. when QR codes are used.
It is possible to postpone sharing the encapsulation key until the first message from Alice (confirmation message in SMP protocol), the party sending connection request. The upside here is that the invitation link size would not increase. The downside is that the user profile shared in this confirmation will not be encrypted with PQ-resistant algorithm.
Another consideration is pairwise ratchets in groups. Key generation in sntrup761 is quite slow - on slow devices it can be as slow as 10-20 keys per second, so using this primitive in groups larger than 10-20 members would result in slow performance.
For backward compatibility the implementation must support adding PQ-resistant key agreement to the existing connections.
It is also beneficial to support removing PQ-resistant key agreement from the connections that have them, e.g. as the group size grows.
### Chosen KEM algorithm
The implementation uses Streamlined NTRU-Prime 761 (sntrup761) that was also used for OpenSSH for a long time.
It was chosen over ML-KEM (Kyber) standardized by NIST for several reasons:
- sntrup761 was used in OpenSSH for a long period of time.
- ML-KEM standardization process raised [concerns](https://groups.google.com/a/list.nist.gov/g/pqc-forum/c/WFRDl8DqYQ4) [amongst](https://blog.cr.yp.to/20231003-countcorrectly.html) the experts.
- ML-KEM (if modified) is likely to have conflicts with the existing patents, unlike sntrup761.
It was chosen over non-interactive CTIDH due to its slower implementation, and lack of optimized code for aarch64 CPUs used in mobile devices.
## Summary
If chosen PQ KEM proves secure against quantum computer attacks, then the proposed augmented double ratchet will also be secure against quantum computer attack, including break-in recovery property, while keeping deniability and forward secrecy, because the [same proof](https://eprint.iacr.org/2016/1013.pdf) as for double ratchet algorithm would hold here, provided chosen KEM is secure.
+398
View File
@@ -0,0 +1,398 @@
Version 2, 2024-06-22
# Overview of push notifications for SimpleX Messaging Servers
## Table of contents
- [Introduction](#introduction)
- [Participating servers](#participating-servers)
- [Register device token to receive push notifications](#register-device-token-to-receive-push-notifications)
- [Subscribe to connection notifications](#subscribe-to-connection-notifications)
- [SimpleX Notification Server protocol](#simplex-notification-server-protocol)
- [Register new notification token](#register-new-notification-token)
- [Verify notification token](#verify-notification-token)
- [Check notification token status](#check-notification-token-status)
- [Replace notification token](#replace-notification-token)
- [Delete notification token](#delete-notification-token)
- [Subscribe to periodic notifications](#subscribe-to-periodic-notifications)
- [Create SMP message notification subscription](#create-smp-message-notification-subscription)
- [Check notification subscription status](#check-notification-subscription-status)
- [Delete notification subscription](#delete-notification-subscription)
- [Error responses](#error-responses)
- [Threat model](#threat-model)
## Introduction
SimpleX Messaging servers already operate as push servers and deliver the messages to subscribed clients as soon as they are sent to the servers.
The reason for push notifications is to support instant message notifications on iOS that does not allow background services.
## Participating servers
The diagram below shows which servers participate in message notification delivery.
While push provider (e.g., APN) can learn how many notifications are delivered to the user, it cannot access message content, even encrypted, or any message metadata - the notifications are e2e encrypted between SimpleX Notification Server and the user's device.
```
User's iOS device Internet Servers
--------------------- . ------------------------ . -----------------------------
. .
. . can be self-hosted now
+--------------+ . . +----------------+
| SimpleX Chat | -------------- TLS --------------- | SimpleX |
| client |------> SimpleX Messaging Protocol (SMP) ------> | Messaging |
+--------------+ ---------------------------------- | Server |
^ | . . +----------------+
| | . . . . . | . . .
| | . . | V |
| | . . |SMP| TLS
| | . . | | | SimpleX
| | . . . . . V . . . NTF Server
| | . . +----------------------------------+
| | . . | +---------------+ |
| | -------------- TLS --------------- | | SimpleX | can be |
| |-----------> Notification Server Protocol -----> | | Notifications | self-hosted |
| ---------------------------------- | | Subscriber | in the future |
| . . | +---------------+ |
| . . | | |
| . . | V |
| . . | +---------------+ |
| . . | | SimpleX | |
| . . | | Push | |
| . . | | Server | |
| . . | +---------------+ |
| . . +----------------------------------+
| . . . . . | . . .
| . . | V |
| . . |SMP| TLS
| . . | | |
| . . . . . V . . .
| -------------- TLS --------------- +-----------------+
|----------------- Notification delivery <-------| Apple PN server |
---------------------------------- +-----------------+
. .
```
## Register device token to receive push notifications
This diagram shows the process of registering a device to receive PUSH notifications via Apple Push Notification (APN) servers.
![Register device notification token](./diagrams/notifications/register-token.svg)
## Subscribe to connection notifications
This diagram shows the process of subscription to notifications, notification delivery and device token update.
![Subscribe to notifications](./diagrams/notifications/subscription.svg)
## SimpleX Notification Server protocol
To manage notification subscriptions to SMP servers, SimpleX Notification Server provides an RPC protocol with a similar design to SimpleX Messaging Protocol server.
This protocol sends requests and responses in a fixed size blocks of 512 bytes over TLS, uses the same [syntax of protocol transmissions](./simplex-messaging.md#smp-transmission-and-transport-block-structure) as SMP protocol, and has the same transport [handshake syntax](./simplex-messaging.md#transport-handshake) (except the server certificate is not included in the handshake).
Protocol commands have this syntax:
```
ntfServerTransmission =
ntfServerCmd = newTokenCmd / verifyTokenCmd / checkTokenCmd /
replaceTokenCmd / deleteTokenCmd / cronCmd /
newSubCmd / checkSubCmd / deleteSubCmd
```
### Register new notification token
This command should be used after the client app obtains a token from push notifications provider to register the token with the server.
Having received this command the server will deliver a test notification via the push provider to validate that the client has this token.
The command syntax:
```abnf
newTokenCmd = %s"TNEW" SP newToken
newToken = %s"T" deviceToken authPubKey clientDhPubKey
deviceToken = pushProvider tokenString
pushProvider = apnsDev / apnsProd / apnsNull
apnsDev = "AD" ; APNS token for development environment
apnsProd = "AP" ; APNS token for production environment
apnsNull = "AN" ; token that does not trigger any notification delivery - used for server testing
tokenString = shortString
authPubKey = length x509encoded ; Ed25519 key used to verify clients commands
clientDhPubKey = length x509encoded ; X25519 key to agree e2e encryption between the server and client
shortString = length *OCTET
length = 1*1 OCTET
```
The server response syntax:
```abnf
tokenIdResp = %s"IDTKN" SP entityId serverDhPubKey
entityId = shortString
serverDhPubKey = length x509encoded ; X25519 key to agree e2e encryption between the server and client
```
### Verify notification token
This command is used to verify the token after the device receives the test notification from the push provider.
The command syntax:
```abnf
verifyTokenCmd = %s"TVFY" SP regCode
regCode = shortString
```
The response to this command is `okResp` or `errorResp`
```abnf
okResp = %s"OK"
```
### Check notification token status
This command is used to check the token status:
```abnf
checkTokenCmd = %s"TCHK"
```
The response to this command:
```abnf
tokenStatusResp = %s"TKN" SP tokenStatus
tokenStatus = %s"NEW" / %s"REGISTERED" / %s"INVALID" / %s"CONFIRMED" / %s"ACTIVE" / %s"EXPIRED"
```
### Replace notification token
This command should be used when push provider issues a new notification token.
It happens when:
- the app data is migrated to another device.
- the app is re-installed on the same device.
- can happen periodically, at push provider discretion.
This command allows to replace the token without re-registering and re-subscribing all notification subscriptions.
Using this command triggers the same verification flow as registering a new token.
The command syntax:
```abnf
replaceTokenCmd = %s"TRPL" SP deviceToken
```
The response to this command is `okResp` or `errorResp`.
### Delete notification token
The command syntax:
```abnf
deleteTokenCmd = %s"TDEL"
```
The response to this command is `okResp` or `errorResp`.
After this command all message notification subscriptions will be removed and no more notifications will be sent.
### Subscribe to periodic notifications
This command enables or disables periodic notifications sent to the client device irrespective of message notifications.
This is useful for two reasons:
- it provides better privacy from notification server, as while the server learns the device token, it doesn't learn anything else about user communications.
- it allows to receive messages when notifications were dropped by push provider, e.g. while the device was offline, or lost by notification server, e.g. while it was restarting.
The command syntax:
```abnf
cronCmd = %s"TCRN" SP interval
interval = 2*2 OCTET ; Word16, minutes
```
The interval for periodic notifications is set in minutes, with the minimum of 20 minutes. The client should pass `0` to disable periodic notifications.
### Create SMP message notification subscription
This command makes notification server subscribe to message notifications from SMP server and to deliver them to push provider:
```abnf
newSubCmd = %s"SNEW" newSub
newSub = %s "S" tokenId smpServer notifierId notifierKey
tokenId = shortString ; returned in response to `TNEW` command
smpServer = smpServer = hosts port fingerprint
hosts = length 1*host
host = shortString
port = shortString
fingerprint = shortString
notifierId = shortString ; returned by SMP server in response to `NKEY` SMP command
notifierKey = length x509encoded ; private key used to authorize requests to subscribe to message notifications
```
The response syntax:
```abnf
subIdResp = %s"IDSUB" SP entityId
```
### Check notification subscription status
This command syntax:
```abnf
checkSubCmd = %s"SCHK"
```
The response:
```abnf
subStatusResp = %s"SUB" SP subStatus
subStatus = %s"NEW" / %s"PENDING" / ; e.g., after SMP server disconnect/timeout while ntf server is retrying to connect
%s"ACTIVE" / %s"INACTIVE" / %s"END" / ; if another server subscribed to notifications
%s"AUTH" / subErrStatus
subErrStatus = %s"ERR" SP shortString
```
### Delete notification subscription
The command syntax:
```abnf
deleteSubCmd = %s"SDEL"
```
The response to this command is `okResp` or `errorResp`.
After this command no more message notifications will be sent from this queue.
### Error responses
All commands can return error response:
```abnf
errorResp = %s"ERR" SP errorType
```
Where `errorType` has the same syntax as in [SimpleX Messaging Protocol](./simplex-messaging.md#error-responses)
## Threat Model
This threat model compliments SimpleX Messaging Protocol [threat model](./overview-tjr.md#threat-model)
#### A passive adversary able to monitor the traffic of one user
*can:*
- identify that and a user is using SimpleX push notifications.
*cannot:*
- determine which servers a user subscribed to the notifications from.
#### A passive adversary able to monitor a set of senders and recipients
*can:*
- perform more efficient traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers.
#### SimpleX Messaging Protocol server
*can:*
- learn which messages trigger push notifications.
- learn IP address of SimpleX notification servers used by the user.
- drop message notifications.
- spam a user with invalid notifications.
*cannot:*
- learn user device token for push notifications.
- learn which queues belong to the same users with any additional efficiency compared with not using push notifications.
#### SimpleX Notification Server subscribed to message notifications
*can:*
- learn a user device token.
- learn how many messaging queues and servers a user receives messages from.
- learn how many message notifications are delivered to the user from each queue.
- undetectably drop notifications.
- spam a user with background notifications.
*cannot:*
- learn queue addresses for receiving or sending messages.
- learn the contents or type of messages (not even encrypted).
- learn anything about messages sent without notification flag.
- spam a user with visible notifications (provided the client app can filter push notifications).
- add, duplicate, or corrupt individual messages that will be shown to the user.
#### SimpleX Notification Server subscribed ONLY to periodic notifications
*can:*
- learn a user device token.
- drop periodic notifications.
- spam a user with background notifications.
*cannot:*
- learn how many messaging queues and servers a user receives messages from.
- learn how many message notifications are delivered to the user from each queue.
- learn queue addresses for receiving or sending messages.
- learn the contents or type of messages (not even encrypted).
- learn anything about messages sent without notification flag.
- spam a user with visible notifications (provided the client app can filter push notifications).
- add, duplicate, or corrupt individual messages that will be shown to the user.
#### A user’s contact
*cannot:*
- determine if a user uses push notifications or not.
#### Push notification provider (e.g., APN)
*can:*
- learn that a user uses SimpleX app.
- learn how many notifications are delivered to user's device.
- drop notifications (in fact, APN coalesces notifications delivered while user's device is offline, delivering only the last one).
*cannot:*
- learn which SimpleX Messaging Protocol servers are used by a user (notifications are e2e encrypted).
- learn which or how many messaging queues a user receives notifications from.
- learn the contents or type of messages (not even encrypted, notifications only contain encrypted metadata).
#### An attacker with Internet access
*cannot:*
- register notification token not present on attacker's device.
- enumerate tokens or subscriptions on a SimpleX Notification Server.
File diff suppressed because it is too large Load Diff
+632
View File
@@ -0,0 +1,632 @@
Version 2, 2024-06-22
# SimpleX File Transfer Protocol
## Table of contents
- [Abstract](#abstract)
- [Introduction](#introduction)
- [XFTP Model](#xftp-model)
- [Persistence model](#persistence-model)
- [XFTP procedure](#xftp-procedure)
- [File description](#file-description)
- [URIs syntax](#uris-syntax)
- [XFTP server URI](#xftp-server-uri)
- [File description URI](#file-description-URI)
- [XFTP qualities and features](#xftp-qualities-and-features)
- [Cryptographic algorithms](#cryptographic-algorithms)
- [File chunk IDs](#file-chunk-ids)
- [Server security requirements](#server-security-requirements)
- [Transport protocol](#transport-protocol)
- [TLS ALPN](#tls-alpn)
- [Connection handshake](#connection-handshake)
- [Requests and responses](#requests-and-responses)
- [XFTP commands](#xftp-commands)
- [Correlating responses with commands](#correlating-responses-with-commands)
- [Command authentication](#command-authentication)
- [Keep-alive command](#keep-alive-command)
- [File sender commands](#file-sender-commands)
- [Register new file chunk](#register-new-file-chunk)
- [Add file chunk recipients](#add-file-chunk-recipients)
- [Upload file chunk](#upload-file-chunk)
- [Delete file chunk](#delete-file-chunk)
- [File recipient commands](#file-recipient-commands)
- [Download file chunk](#download-file-chunk)
- [Acknowledge file chunk download](#acknowledge-file-chunk-download)
- [Threat model](#threat-model)
## Abstract
SimpleX File Transfer Protocol is a client-server protocol for asynchronous unidirectional file transmission.
It's designed with the focus on communication security, integrity and meta-data privacy, under the assumption that any part of the message transmission network can be compromised.
It is designed as a application level protocol to solve the problem of secure and private file transmission, making [MITM attacks][1] very difficult at any part of the file transmission system, and preserving meta-data privacy of the sent files.
## Introduction
The objective of SimpleX File Transfer Protocol (XFTP) is to facilitate the secure and private unidirectional transfer of files from senders to recipients via persistent file chunks stored by the xftp server.
XFTP is implemented as an application level protocol on top of HTTP2 and TLS.
The protocol describes the set of commands that senders and recipients can send to XFTP servers to create, upload, download and delete file chunks of several pre-defined sizes. XFTP servers SHOULD support chunks of 4 sizes: 64KB, 256KB, 1MB and 4MB (1KB = 1024 bytes, 1MB = 1024KB).
The protocol is designed with the focus on meta-data privacy and security. While using TLS, the protocol does not rely on TLS security by using additional encryption to achieve that there are no identifiers or ciphertext in common in received and sent server traffic, frustrating traffic correlation even if TLS is compromised.
XFTP does not use any form of participants' identities. It relies on out-of-band passing of "file description" - a human-readable YAML document with the list of file chunk locations, hashes and necessary cryptographic keys.
## XFTP Model
The XFTP model has three communication participants: the recipient, the file server (XFTP server) that is chosen and, possibly, controlled by the sender, and the sender.
XFTP server allows uploading fixed size file chunks, with or without basic authentication. The same party that can be the sender of one file chunk can be the recipient of another, without exposing it to the server.
Each file chunk allows multiple recipients, each recipient can download the same chunk multiple times. It allows depending on the threat model use the same recipient credentials for multiple parties, thus reducing server ability to understand the number of intended recipients (but server can still track IP addresses to determine it), or use one unique set of credentials for each recipient, frustrating traffic correlation on the assumption of compromised TLS. In the latter case, senders can create a larger number of recipient credentials to hide the actual number of intended recipients from the servers (which is what SimpleX clients do).
```
Sender Internet XFTP relays Internet Recipient
---------------------------- | ----------------- | ------------------- | ------------ | ----------
| | | |
| | (can be self-hosted) | |
| | +---------+ | |
chunk 1 ----- HTTP2 over TLS ------ | XFTP | ---- HTTP2 / TLS ----- chunk 1
|---> SimpleX File Transfer Protocol (XFTP) --> | Relay | ---> XFTP ------------->|
| --------------------------- +---------+ ---------------------- |
| | | | | |
| | | | | v
+----------+ | | +---------+ | | +-------------+
| Sending | ch. 2 ------- HTTP2 / TLS ------- | XFTP | ---- HTTP2 / TLS ---- ch. 2 | Receiving |
file ---> | XFTP | ------> XFTP ----> | Relay | ---> XFTP ------> | XFTP | ---> file
| Client | --------------------------- +---------+ ---------------------- | Client |
+----------+ | | | | +-------------+
| | | | | ^
| | | +---------+ | | |
| ------- HTTP2 / TLS ------- | XFTP | ---- HTTP2 / TLS ---- |
|-------------> XFTP ----> | Relay | ---> XFTP ------------->|
chunk N --------------------------- +---------+ --------------------- chunk N
| | (store file chunks) | |
| | | |
| | | |
```
When sender client uploads a file chunk, it has to register it first with one sender ID and multiple recipient IDs, and one random unique key per ID to authenticate sender and recipients, and also provide its size and hash that will be validated when chunk is uploaded.
To send the actual file, the sender client MUST pad it and encrypt it with a random symmetric key and distribute chunks of fixed sized across multiple XFTP servers. Information about chunk locations, keys, hashes and required keys is passed to the recipients as "[file description](#file-description)" out-of-band.
Creating, uploading, downloading and deleting file chunks requires sending commands to the XFTP server - they are described in detail in [XFTP commands](#xftp-commands) section.
## Persistence model
Server stores file chunk records in memory, with optional adding to append-only log, to allow restoring them on server restart. File chunk bodies can be stored as files or as objects in any object store (e.g. S3).
## XFTP procedure
1. Sending the file.
To send the file, the sender will:
1) Prepare file
- compute its SHA512 digest.
- prepend header with the name and pad the file to match the whole number of chunks in size. It is RECOMMENDED to use 2 of 4 allowed chunk sizes, to balance upload size and metadata privacy.
- encrypt it with a randomly chosen symmetric key and IV (e.g., using NaCL secret_box).
- split into allowed size chunks.
- generate per-recipient keys. It is recommended that the sending client generates more per-recipient keys than the actual number of recipients, rounding up to a power of 2, to conceal the actual number of intended recipients.
2) Upload file chunks
- register each chunk record with randomly chosen one or more (for redundancy) XFTP server(s).
- optionally request additional recipient IDs, if required number of recipient keys didn't fit into register request.
- upload each chunk to chosen server(s).
3) Prepare file descriptions, one per recipient.
The sending client combines addresses of all chunks and other information into "file description", different for each file recipient, that will include:
- an encryption key used to encrypt/decrypt the full file (the same for all recipients).
- file SHA512 digest to validate download.
- list of chunk descriptions; information for each chunk:
- private Ed25519 key to sign commands for file transfer server.
- chunk address (server host and chunk ID).
- chunk sha512 digest.
To reduce the size of file description, chunks are grouped by the server host.
4) Send file description(s) to the recipient(s) out-of-band, via pre-existing secure and authenticated channel. E.g., SimpleX clients send it as messages via SMP protocol, but it can be done via any other channel.
![Sending file](./diagrams/xftp/xftp-sending-file.svg)
2. Receiving the file.
Having received the description, the recipient will:
1) Download all chunks.
The receiving client can fall back to secondary servers, if necessary:
- if the server is not available.
- if the chunk is not present on the server (ERR AUTH response).
- if the hash of the downloaded file chunk does not match the description.
Optionally recipient can acknowledge file chunk reception to delete file ID from server for this recipient.
2) Combine the chunks into a file.
3) Decrypt the file using the key in file description.
4) Extract file name and unpad the file.
5) Validate file digest with the file description.
![Receiving file](./diagrams/xftp/xftp-receiving-file.svg)
## File description
"File description" is a human-readable YAML document that is sent via secure and authenticated channel.
It includes these fields:
- `party` - "sender" or "recipient". Sender's file description is required to delete the file.
- `size` - padded file size equal to total size of all chunks, see `fileSize` syntax below.
- `digest` - SHA512 hash of encrypted file, base64url encoded string.
- `key` - symmetric encryption key to decrypt the file, base64url encoded string.
- `nonce` - nonce to decrypt the file, base64url encoded string.
- `chunkSize` - default chunk size, see `fileSize` syntax below.
- `replicas` - the array of file chunk replicas descriptions.
- `redirect` - optional property for redirect information indicating that the file is itself a description to another file, allowing to use file description as a short URI.
Each replica description is an object with 2 fields:
- `chunks` - and array of chunk replica descriptions stored on one server.
- `server` - [server address](#xftp-server-uri) where the chunks can be downloaded from.
Each server replica description is a string with this syntax:
```abnf
chunkReplica = chunkNo ":" replicaId ":" replicaKey [":" chunkDigest [":" chunkSize]]
chunkNo = 1*DIGIT
; a sequential 1-based chunk number in the original file.
replicaId = base64url
; server-assigned random chunk replica ID.
replicaKey = base64url
; sender-generated random key to receive (or to delete, in case of sender's file description) the chunk replica.
chunkDigest = base64url
; chunk digest that MUST be specified for the first replica of each chunk,
; and SHOULD be omitted (or be the same) on the subsequent replicas
chunkSize = fileSize
fileSize = sizeInBytes / sizeInUnits
; chunk size SHOULD only be specified on the first replica and only if it is different from default chunk size
sizeInBytes = 1*DIGIT
sizeInUnits = 1*DIGIT sizeUnit
sizeUnit = %s"kb" / %s"mb" / %s"gb"
base64url = <base64url encoded binary> ; RFC4648, section 5
```
Optional redirect information has two fields:
- `size` - the size of the original encrypted file to which file description downloaded via the current file description will lead to, see `fileSize` syntax below.
- `digest` - SHA512 hash of the original file, base64url encoded string.
## URIs syntax
### XFTP server URI
The XFTP server address is a URI with the following syntax:
```abnf
xftpServerURI = %s"xftp://" xftpServer
xftpServer = serverIdentity [":" basicAuth] "@" srvHost [":" port]
srvHost = <hostname> ; RFC1123, RFC5891
port = 1*DIGIT
serverIdentity = base64url
basicAuth = base64url
```
### File description URI
This file description URI can be generated by the client application to share a small file description as a QR code or as a link. Practically, to be able to scan a QR code it should be under 1000 characters, so only file descriptions with 1-2 chunks can be used in this case. This is supported with `redirect` property when file description leads to a file which in itself is a larger file description to another file - akin to URL shortener.
File description URI syntax:
```abnf
fileDescriptionURI = serviceScheme "/file" "#/?desc=" description [ "&data=" userData ]
serviceScheme = (%s"https://" clientAppServer) | %s"simplex:"
clientAppServer = hostname [ ":" port ]
; client app server, e.g. simplex.chat
description = <URI-escaped YAML file description>
userData = <any URI-compatible string>
```
clientAppServer is not a server the client connects to - it is a server that shows the instruction on how to download the client app that will connect using this connection request. This server can also host a mobile or desktop app manifest so that this link is opened directly in the app if it is installed on the device.
"simplex" URI scheme in serviceScheme can be used instead of client app server. Client apps MUST support this URI scheme.
## XFTP qualities and features
XFTP stands for SimpleX File Transfer Protocol. Its design is based on the same ideas and has some of the qualities of SimpleX Messaging Protocol:
- recipient cannot see sender's IP address, as the file fragments (chunks) are temporarily stored on multiple XFTP relays.
- file can be sent asynchronously, without requiring the sender to be online for file to be received.
- there is no network of peers that can observe this transfer - sender chooses which XFTP relays to use, and can self-host their own.
- XFTP relays do not have any file metadata - they only see individual chunks, with access to each chunk authorized with anonymous credentials (using Edwards curve cryptographic signature) that are random per chunk.
- chunks have one of the sizes allowed by the servers - 64KB, 256KB, 1MB and 4MB chunks, so sending a large file looks indistinguishable from sending many small files to XFTP server. If the same transport connection is reused, server would only know that chunks are sent by the same user.
- each chunk can be downloaded by multiple recipients, but each recipient uses their own key and chunk ID to authorize access, and the chunk is encrypted by a different key agreed via ephemeral DH keys (NaCl crypto_box (SalsaX20Poly1305 authenticated encryption scheme ) with shared secret derived from Curve25519 key exchange) on the way from the server to each recipient. XFTP protocol as a result has the same quality as SMP protocol - there are no identifiers and ciphertext in common between sent and received traffic inside TLS connection, so even if TLS is compromised, it complicates traffic correlation attacks.
- XFTP protocol supports redundancy - each file chunk can be sent via multiple relays, and the recipient can choose the one that is available. Current implementation of XFTP protocol in SimpleX Chat does not support redundancy though.
- the file as a whole is encrypted with a random symmetric key using NaCl secret_box.
## Cryptographic algorithms
Clients must cryptographically authorize XFTP commands, see [Command authentication](#command-authentication).
To authorize/verify transmissions clients and servers MUST use either signature algorithm Ed25519 algorithm defined in RFC8709 or using deniable authentication scheme based on NaCL crypto_box (see Simplex Messaging Protocol).
To encrypt/decrypt file chunk bodies delivered to the recipients, servers/clients MUST use NaCL crypto_box.
Clients MUST encrypt file chunk bodies sent via XFTP servers using use NaCL crypto_box.
## File chunk IDs
XFTP servers MUST generate a separate new set of IDs for each new chunk - for the sender (that uploads the chunk) and for each intended recipient. It is REQUIRED that:
- These IDs are different and unique within the server.
- Based on random bytes generated with cryptographically strong pseudo-random number generator.
## Server security requirements
XFTP server implementations MUST NOT create, store or send to any other servers:
- Logs of the client commands and transport connections in the production environment.
- History of retrieved files.
- Snapshots of the database they use to store file chunks (instead clients can manage redundancy by creating chunk replicas using more than one XFTP server). In-memory persistence is recommended for file chunks records.
- Any other information that may compromise privacy or [forward secrecy][4] of communication between clients using XFTP servers.
## Transport protocol
- binary-encoded commands sent as fixed-size padded block in the body of HTTP2 POST request, similar to SMP and notifications server protocol transmission encodings.
- HTTP2 POST with a fixed size padded block body for file upload and download.
Block size - 4096 bytes (it would fit ~120 Ed25519 recipient keys).
The reasons to use HTTP2:
- avoid the need to have two hostnames (or two different ports) for commands and file uploads.
- compatibility with the existing HTTP2 client libraries.
The reason not to use JSON bodies:
- bigger request size, so fewer recipient keys would fit in a single request
- signature over command has to be outside of JSON anyway.
The reason not to use URI segments / HTTP verbs / REST semantics is to have consistent request size.
### ALPN to agree handshake version
Client and server use [ALPN extension][18] of TLS to agree handshake version.
Server SHOULD send `xftp/1` protocol name and the client should confirm this name in order to use the current protocol version. This is added to allow support of older clients without breaking backward compatibility and to extend or modify handshake syntax.
If the client does not confirm this protocol name, the server would fall back to v1 of XFTP protocol.
### Transport handshake
When a client and a server agree on handshake version using ALPN extension, they should proceed with XFTP handshake.
As with SMP, a client doesn't reveal its version range to avoid version fingerprinting. Unlike SMP, XFTP runs a HTTP2 protocol over TLS and the server can't just send its handshake right away. So a session handshake is driven by client-sent requests:
1. To pass initiative to the server, the client sends a request with empty body.
2. Server responds with its `paddedServerHello` block.
3. Clients sends a request containing `paddedClientHello` block,
4. Server sends an empty response, finalizing the handshake.
Once TLS handshake is complete, client and server will exchange blocks of fixed size (16384 bytes).
```abnf
paddedServerHello = <padded(serverHello, 16384)>
serverHello = xftpVersionRange sessionIdentifier serverCert signedServerKey ignoredPart
xftpVersionRange = minXftpVersion maxXftpVersion
minXftpVersion = xftpVersion
maxXftpVersion = xftpVersion
sessionIdentifier = shortString
; unique session identifier derived from transport connection handshake
serverCert = originalLength <x509encoded>
signedServerKey = originalLength <x509encoded> ; signed by server certificate
paddedClientHello = <padded(clientHello, 16384)>
clientHello = xftpVersion keyHash ignoredPart
; chosen XFTP protocol version - must be the maximum supported version
; within the range offered by the server
xftpVersion = 2*2OCTET ; Word16 version number
keyHash = shortString
shortString = length length*OCTET
length = 1*1OCTET
originalLength = 2*2OCTET
ignoredPart = *OCTET
```
In XFTP v2 the handshake is only used for version negotiation, but `serverCert` and `signedServerKey` must be validated by the client.
`keyHash` is the CA fingerprint used by client to validate TLS certificate chain and is checked by a server against its own key.
`ignoredPart` in handshake allows to add additional parameters in handshake without changing protocol version - the client and servers must ignore any extra bytes within the original block length.
For TLS transport client should assert that `sessionIdentifier` is equal to `tls-unique` channel binding defined in [RFC 5929][14] (TLS Finished message struct); we pass it in `serverHello` block to allow communication over some other transport protocol (possibly, with another channel binding).
### Requests and responses
- File sender:
- create file chunk record.
- Parameters:
- Ed25519 key for subsequent sender commands and Ed25519 keys for commands of each recipient.
- chunk size.
- Response:
- chunk ID for the sender and different IDs for all recipients.
- add recipients to file chunk
- Parameters:
- sender's chunk ID
- Ed25519 keys for commands of each recipient.
- Response:
- chunk IDs for new recipients.
- upload file chunk.
- delete file chunk (invalidates all recipient IDs).
- File recipient:
- download file chunk:
- chunk ID
- DH key for additional encryption of the chunk.
- command should be signed with the key passed by the sender when creating chunk record.
- delete file chunk ID (only for one recipient): signed with the same key.
## XFTP commands
Commands syntax below is provided using ABNF with case-sensitive strings extension.
```abnf
xftpCommand = ping / senderCommand / recipientCmd / serverMsg
senderCommand = register / add / put / delete
recipientCmd = get / ack
serverMsg = pong / sndIds / rcvIds / ok / file
```
The syntax of specific commands and responses is defined below.
### Correlating responses with commands
Commands are made via HTTP2 requests, responses to commands are correlated as HTTP2 responses.
### Command authentication
XFTP servers must authenticate all transmissions (excluding `ping`) by verifying the client signatures. Command signature should be generated by applying the algorithm specified for the file to the `signed` block of the transmission, using the key associated with the file chunk ID (recipient's or sender's depending on which file chunk ID is used).
### Keep-alive command
To keep the transport connection alive and to generate noise traffic the clients should use `ping` command to which the server responds with `pong` response. This command should be sent unsigned and without file chunk ID.
```abnf
ping = %s"PING"
```
This command is always sent unsigned.
data FileResponse = ... | FRPong | ...
```abnf
pong = %s"PONG"
```
### File sender commands
Sending any of the commands in this section (other than `register`, that is sent without file chunk ID) is only allowed with sender's ID.
#### Register new file chunk
This command is sent by the sender to the XFTP server to register a new file chunk.
Servers SHOULD support basic auth with this command, to allow only server owners and trusted users to create file chunks on the servers.
The syntax is:
```abnf
register = %s"FNEW " fileInfo rcvPublicAuthKeys basicAuth
fileInfo = sndKey size digest
sndKey = length x509encoded
size = 1*DIGIT
digest = length *OCTET
rcvPublicAuthKeys = length 1*rcvPublicAuthKey
rcvPublicAuthKey = length x509encoded
basicAuth = "0" / "1" length *OCTET
x509encoded = <binary X509 key encoding>
length = 1*1 OCTET
```
If the file chunk is registered successfully, the server must send `sndIds` response with the sender's and recipients' file chunk IDs:
```abnf
sndIds = %s"SIDS " senderId recipientIds
senderId = length *OCTET
recipientIds = length 1*recipientId
recipientId = length *OCTET
```
#### Add file chunk recipients
This command is sent by the sender to the XFTP server to add additional recipient keys to the file chunk record, in case number of keys requested by client didn't fit into `register` command. The syntax is:
```abnf
add = %s"FADD " rcvPublicAuthKeys
rcvPublicAuthKeys = length 1*rcvPublicAuthKey
rcvPublicAuthKey = length x509encoded
```
If additional keys were added successfully, the server must send `rcvIds` response with the added recipients' file chunk IDs:
```abnf
rcvIds = %s"RIDS " recipientIds
recipientIds = length 1*recipientId
recipientId = length *OCTET
```
#### Upload file chunk
This command is sent by the sender to the XFTP server to upload file chunk body to server. The syntax is:
```abnf
put = %s"FPUT"
```
Chunk body is streamed via HTTP2 request.
If file chunk body was successfully received, the server must send `ok` response.
```abnf
ok = %s"OK"
```
#### Delete file chunk
This command is sent by the sender to the XFTP server to delete file chunk from the server. The syntax is:
```abnf
delete = %s"FDEL"
```
Server should delete file chunk record, invalidating all recipient IDs, and delete file body from file storage. If file chunk was successfully deleted, the server must send `ok` response.
### File recipient commands
Sending any of the commands in this section is only allowed with recipient's ID.
#### Download file chunk
This command is sent by the recipient to the XFTP server to download file chunk body from the server. The syntax is:
```abnf
get = %s"FGET " rDhKey
rDhKey = length x509encoded
```
If requested file is successfully located, the server must send `file` response. File chunk body is sent as HTTP2 response body.
```abnf
file = %s"FILE " sDhKey cbNonce
sDhKey = length x509encoded
cbNonce = <nonce used in NaCl crypto_box encryption scheme>
```
Chunk is additionally encrypted on the way from the server to the recipient using a key agreed via ephemeral DH keys `rDhKey` and `sDhKey`, so there is no ciphertext in common between sent and received traffic inside TLS connection, in order to complicate traffic correlation attacks, if TLS is compromised.
#### Acknowledge file chunk download
This command is sent by the recipient to the XFTP server to acknowledge file reception, deleting file ID from server for this recipient. The syntax is:
```abnf
ack = %s"FACK"
```
If file recipient ID is successfully deleted, the server must send `ok` response.
In current implementation of XFTP protocol in SimpleX Chat clients don't use FACK command. Files are automatically expired on servers after configured time interval.
## Threat model
#### Global Assumptions
- A user protects their local database and key material.
- The user's application is authentic, and no local malware is running.
- The cryptographic primitives in use are not broken.
- A user's choice of servers is not directly tied to their identity or otherwise represents distinguishing information about the user.
#### A passive adversary able to monitor the traffic of one user
*can:*
- identify that and when a user is sending files over XFTP protocol.
- determine which servers the user sends/receives files to/from.
- observe how much traffic is being sent, and make guesses as to its purpose.
*cannot:*
- see who sends files to the user and who the user sends the files to.
#### A passive adversary able to monitor a set of file senders and recipients
*can:*
- learn which XFTP servers are used to send and receive files for which users.
- learn when files are sent and received.
- perform traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers.
- observe how much traffic is being sent, and make guesses as to its purpose
*cannot, even in case of a compromised transport protocol:*
- perform traffic correlation attacks with any increase in efficiency over a non-compromised transport protocol
#### XFTP server
*can:*
- learn when file senders and recipients are online.
- know how many file chunks and chunk sizes are sent via the server.
- perform the correlation of the file chunks as belonging to one file via either a re-used transport connection, user's IP address, or connection timing regularities.
- learn file senders' and recipients' IP addresses, and infer information (e.g. employer) based on the IP addresses, as long as Tor is not used.
- delete file chunks, preventing file delivery, as long as redundant delivery is not used.
- lie about the state of a file chunk to the recipient and/or to the sender (e.g. deleted when it is not).
- refuse deleting the file when instructed by the sender.
*cannot:*
- undetectably corrupt file chunks.
- learn the contents, name or the exact size of sent files.
- learn approximate size of sent files, as long as more than one server is used to send file chunks.
- compromise the users' end-to-end encryption of files with an active attack.
#### An attacker who obtained Alice's (decrypted) chat database
*can:*
- see the history of all files exchanged by Alice with her communication partners, as long as files were not deleted from the database.
- receive all files sent and received by Alice that did not expire yet, as long as information about these files was not removed from the database.
- prevent Alice's contacts from receiving the files she sent by deleting all or some of the file chunks from XFTP servers.
#### A user's contact
*can:*
- spam the user with files.
- forever retain files from the user.
*cannot:*
- cryptographically prove to a third-party that a file came from a user (assuming the user's device is not seized).
- prove that two contacts they have is the same user.
- cannot collaborate with another of the user's contacts to confirm they are communicating with the same user, even if they receive the same file.
#### An attacker with Internet access
*can:*
- Denial of Service XFTP servers.
*cannot:*
- send files to a user who they are not connected with.
- enumerate file chunks on an XFTP server.
+330
View File
@@ -0,0 +1,330 @@
Version 1, 2024-06-22
# SimpleX Remote Control Protocol
## Table of contents
- [Abstract](#abstract)
- [XRCP model](#xrcp-model)
- [Transport protocol](#transport-protocol)
- [Session invitation](#session-invitation)
- [Establishing TLS connection](#establishing-tls-connection)
- [Session verification and protocol negotiation](#session-verification-and-protocol-negotiation)
- [Controller/host session operation](#сontrollerhost-session-operation)
- [Key agreement for announcement packet and for session](#key-agreement-for-announcement-packet-and-for-session)
- [Threat model](#threat-model)
## Abstract
The SimpleX Remote Control Protocol is a client-server protocol designed to transform application UIs into thin clients, enabling remote control from another device. This approach allows users to remotely access and utilize chat profiles without the complexities of master-master replication for end-to-end encryption states.
Like SMP and XFTP, XRCP leverages out-of-band invitations to mitigate MITM attacks and employs multiple cryptographic layers to safeguard application data.
## XRCP model
XRCP assumes two application roles: host (that contain the application data) and controller that gains limited access to host data.
Applications are also split into two components: UI and core.
When an XRCP session is established a host UI is locked out and a controller UI uses its core to proxy commands to the host core, getting back responses and events.
```
+------+ +------+ xrcp +------+ +------+
| Ctrl | commands | Ctrl | commands | Host | | Host |
user ---> | UI | -----------> | Core | -----------> | Core | | UI |
+------+ +------+ +------+ +------+
^ responses | ^ xrcp responses | ^
|<------------------| |<-----------------| | +-------------+
| events | | | Application |-+
|<------------------| |----> | protocol | |
| servers | |
+-------------+ |
+--------------+
```
## Transport protocol
Protocol consists of four phases:
- controller session invitation
- establishing session TLS connection
- session verification and protocol negotiation
- session operation
![Session sequence](./diagrams/xrcp/session.svg)
### Session invitation
The invitation to the first session between host and controller pair MUST be shared out-of-band, to establish a long term identity keys/certificates of the controller to host device.
The subsequent sessions can be announced via an application-defined site-local multicast group, e.g. `224.0.0.251` (also used in mDNS/bonjour) and an application-defined port (SimpleX Chat uses 5227).
The session invitation contains this data:
- supported version range for remote control protocol.
- application-specific information, e.g. device name, application name and supported version range, settings, etc.
- session start time in seconds since epoch.
- if multicast is used, counter of announce packets sent by controller.
- network address (ipv4 address and port) of the controller.
- CA TLS certificate fingerprint of the controller - this is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements.
- Session Ed25519 public key used to verify the announcement and commands - this mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first.
- Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity.
- Session X25519 DH key and SNTRUP761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. DH public key and KEM encapsulation key are sent unencrypted. NaCL crypto_box is used for encryption.
Host application decrypts (except the first session) and validates the invitation:
- Session signature is valid.
- Timestamp is within some window from the current time.
- Long-term key signature is valid.
- Long-term CA and signature key are the same as in the first session.
- Some version in the offered range is supported.
OOB session invitation is a URI with this syntax:
```abnf
sessionAddressUri = "xrcp:/" encodedCAFingerprint "@" host ":" port "#/?" qsParams
encodedCAFingerprint = base64url
host = <ipv4 or ipv6 address> ; in textual form, RFC4001
port = 1*DIGIT ; uint16
qsParams = param *("&" param)
param = versionRangeParam / appInfoParam / sessionTsParam /
sessPubKeyParam / idPubKeyParam / dhPubKeyParam /
sessSignatureParam / idSignatureParam
versionRangeParam = "v=" (versionParam / (versionParam "-" versionParam))
versionParam = 1*DIGIT
appInfoParam = "app=" escapedJSON
sessionTsParam = "ts=" 1*DIGIT
sessPubKeyParam = "skey=" base64url
idPubKeyParam = "idkey=" base64url
dhPubKeyParam = "dh=" base64url
sessSignatureParam = "ssig=" base64url ; signs the URI with this and idSignatureParam param removed
idSignatureParam = "idsig=" base64url ; signs the URI with this param removed
base64url = <base64url encoded binary> ; RFC4648, section 5
```
Multicast session announcement is a binary encoded packet with this syntax:
```abnf
sessionAddressPacket = dhPubKey nonce encrypted(unpaddedSize sessionAddress packetPad)
dhPubKey = length x509encoded ; same as announced
nonce = length *OCTET
sessionAddress = largeLength sessionAddressUri ; as above
length = 1*1 OCTET ; for binary data up to 255 bytes
largeLength = 2*2 OCTET ; for binary data up to 65535 bytes
packetPad = <pad packet size to 1450 bytes> ; possibly, we may need to move KEM agreement one step later,
; with encapsulation key in HELLO block and KEM ciphertext in reply to HELLO.
```
### Establishing TLS connection
Both controller and host use 2-element certificate chains with unique self-signed CA root representing long-term identities. Leaf certificates aren't stored and instead generated on each session start.
A controller runs a TCP server to avoid opening listening socket on a host, which might create an attack vector. A controller keeps no sensitive data to be exposed this way.
During TLS handshake, parties validate certificate chains against previously known (from invitation or storage) CA fingerprints. The fingerprints MUST be the same as in the invitation and in the subsequent connections.
### Session verification and protocol negotiation
Once TLS session is established, both the host and controller devices present a "session security code" to the user who must match them (e.g., visually or via QR code scan) and confirm on the host device. The session security code must be a digest of tlsunique channel binding. As it is computed as a digest of the TLS handshake for both the controller and the host, it will validate that the same TLS certificates are used on both sides, and that the same TLS session is established, mitigating the possibility of MITM attack in the connection.
Once the session is confirmed by the user, the host sends HELLO block to the controller.
XRCP blocks inside TLS are padded to 16384 bytes.
Host HELLO block must contain:
- new session DH key - used to compute new shared secret with the controller keys from the announcement.
- encrypted part of HELLO block (JSON object), containing:
- chosen protocol version.
- host CA TLS certificate fingerprint - part of host long term identity - must match the one presented in TLS handshake and the previous sessions, otherwise the connection is terminated.
- KEM encapsulation key - used to compute new shared secret for the session.
- additional application specific parameters, e.g host device name, application version, host settings or JSON encoding format.
Host HELLO block syntax:
```abnf
hostHello = %s"HELLO " dhPubKey nonce encrypted(unpaddedSize hostHelloJSON helloPad) pad
unpaddedSize = largeLength
dhPubKey = length x509encoded
pad = <pad block size to 16384 bytes>
helloPad = <pad hello size to 12888 bytes>
largeLength = 2*2 OCTET
```
The controller decrypts (including the first session) and validates the received HELLO block:
- Chosen versions are supported (must be within offered ranges).
- CA fingerprint matches the one presented in TLS handshake and the previous sessions - in subsequent sessions TLS connection should be rejected if the fingerprint is different.
[JTD schema](https://www.rfc-editor.org/rfc/rfc8927) for the encrypted part of host HELLO block `hostHelloJSON`:
```json
{
"definitions": {
"version": {
"type": "string",
"metadata": {
"format": "[0-9]+"
}
},
"base64url": {
"type": "string",
"metadata": {
"format": "base64url"
}
}
},
"properties": {
"v": {"ref": "version"},
"ca": {"ref": "base64url"},
"kem": {"ref": "base64url"}
},
"optionalProperties": {
"app": {"properties": {}, "additionalProperties": true}
},
"additionalProperties": true
}
```
The controller should reply with with `ctrlHello` or `ctrlError` response:
```abnf
ctrlHello = %s"HELLO " kemCiphertext nonce encrypted(unpaddedSize ctrlHelloJSON helloPad) pad
; ctrlHelloJSON is encrypted with the hybrid secret,
; including both previously agreed DH secret and KEM secret from kemCiphertext
unpaddedSize = largeLength
kemCiphertext = largeLength *OCTET
pad = <pad block size to 16384 bytes>
helloPad = <pad hello size to 12888 bytes>
largeLength = 2*2 OCTET
ctrlError = %s"ERROR " nonce encrypted(unpaddedSize ctrlErrorMessage helloPad) pad
ctrlErrorMessage = <utf-8 encoded text>; encrypted using previously agreed DH secret.
```
JTD schema for the encrypted part of controller HELLO block `ctrlHelloJSON`:
```json
{
"properties": {},
"additionalProperties": true
}
```
Once the controller replies HELLO to the valid host HELLO block, it should stop accepting new TCP connections.
### Controller/host session operation
The protocol for communication during the session is out of scope of this protocol.
SimpleX Chat uses HTTP2 encoding, where host device acts as a server and controller acts as a client (these roles are reversed compared with TLS connection, restoring client-server semantics in HTTP).
Payloads in the protocol must be encrypted using NaCL secret_box using the hybrid shared secret agreed during session establishment.
Commands of the controller must be signed after the encryption using the controller's session and long term Ed25519 keys.
tlsunique channel binding from TLS session MUST be included in commands (included in the signed body).
The syntax for encrypted command and response body encoding:
```abnf
commandBody = encBody sessSignature idSignature [attachment]
responseBody = encBody [attachment] ; counter must match command
encBody = nonce encLength32 encrypted(tlsunique counter body)
attachment = %x01 nonce encLength32 encrypted(attachment)
noAttachment = %x00
tlsunique = length 1*OCTET
counter = 8*8 OCTET ; int64
encLength32 = 4*4 OCTET ; uint32, includes authTag
```
If the command or response includes attachment, its hash must be included in command/response and validated.
## Key agreement for announcement packet and for session
Initial announcement is shared out-of-band (URI with xrcp scheme), and it is not encrypted.
This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will contain DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA256 over concatenated DH shared secret and KEM encapsulated secret) both for controller HELLO response (that contains KEM ciphertext in plaintext part) and subsequent session commands and responses.
During the next session the announcement is sent via encrypted multicast block. The shared key for this announcement and for host HELLO block is determined using the KEM shared secret from the previous session and DH shared secret computed using the host DH key from the previous session and the new controller DH key from the announcement.
For the session, the shared secret is computed again using the KEM shared secret encapsulated by the controller using the new KEM key from the host HELLO block and DH shared secret computed using the host DH key from HELLO block and the new controller DH key from the announcement.
In pseudo-code:
```
// session 1
hostHelloSecret(1) = dhSecret(1)
sessionSecret(1) = sha256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello
dhSecret(1) = dh(hostHelloDhKey(1), controllerInvitationDhKey(1))
kemCiphertext(1) = enc(kemSecret(1), kemEncKey(1))
// kemEncKey is included in host HELLO, kemCiphertext - in controller HELLO
kemSecret(1) = dec(kemCiphertext(1), kemDecKey(1))
// multicast announcement for session n
announcementSecret(n) = sha256(dhSecret(n'))
dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerDhKey(n))
// session n
hostHelloSecret(n) = dhSecret(n)
sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello
dhSecret(n) = dh(hostHelloDhKey(n), controllerDhKey(n))
// controllerDhKey(n) is either from invitation or from multicast announcement
kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n))
kemSecret(n) = dec(kemCiphertext(n), kemDecKey(n))
```
If controller fails to store the new host DH key after receiving HELLO block, the encryption will become out of sync and the host won't be able to decrypt the next announcement. To mitigate it, the host should keep the last session DH key and also previous session DH key to try to decrypt the next announcement computing shared secret using both keys (first the new one, and in case it fails - the previous).
To decrypt a multicast announcement, the host should try to decrypt it using the keys of all known (paired) remote controllers.
## Threat model
#### A passive network adversary able to monitor the site-local traffic:
*can:*
- observe session times, duration and volume of the transmitted data between host and controller.
*cannot:*
- observe the content of the transmitted data.
- substitute the transmitted commands or responses.
- replay transmitted commands or events from the hosts.
#### An active network adversary able to intercept and substitute the site-local traffic:
*can:*
- prevent host and controller devices from establishing the session
*cannot:*
- same as passive adversary, provided that user visually verified session code out-of-band.
#### An active adversary with the access to the network:
*can:*
- spam controller device.
*cannot:*
- compromise host or controller devices.
#### An active adversary with the access to the network who also observed OOB announcement:
*can:*
- connect to controller instead of the host.
- present incorrect data to the controller.
*cannot:*
- connect to the host or make host connect to itself.
#### Compromised controller device:
*can:*
- observe the content of the transmitted data.
- access any data of the controlled host application, within the capabilities of the provided API.
*cannot:*
- access other data on the host device.
- compromise host device.
#### Compromised host device:
*can:*
- present incorrect data to the controller.
- incorrectly interpret controller commands.
*cannot:*
- access controller data, even related to this host device.
+42
View File
@@ -0,0 +1,42 @@
# Faster connection establishment
## Problem
SMP protocol is unidirectional, and to create a connection users have to agree two messaging queues.
V1 of handshake protocol required 5 messages and multiple HELLO sent between the users, which consumed a lot of traffic.
V2 of handshake protocol was optimized to remove multiple HELLO and also REPLY message, thanks to including queue address together with the key to secure this queue into the confirmation message.
This eliminated unnecessary traffic from repeated HELLOs, but still requires 4 messages in total and 2 times of each client being online. It is perceived by the users as "it didn't work" (because they see "connecting" after using the link) or "we have to be online at the same time" (and even in this case it is slow on bad network). This hurts usability and creates churn of the new users, as unless people are onboarded by the friends who know how the app works, they cannot figure out how to connect.
Ideally, we want to have handshake protocol design when an accepting user can send messages straight after using the link (their client says "connected") and the initiating client can send messages as soon as it received confirmation message with the profile.
This RFC proposes modifications to SMP and SMP Agent protocols to reduce the number of required messages to 2 and allows accepting client to send messages straight after using the link (and sending the confirmation), before receiving the profile of the initiating client in the second message, and the initiating client can send the messages straight after processing the confirmation and sending its own confirmation.
## Solution
The current protocol design allows additional confirmation step where the initiating client can confirm the connection having received the profile of the sender. We don't use it in the UI - this confirmation is done automatically and unconditionally.
Instead of requiring the initiating client to secure its queue with sender's key, we can allow the accepting client to secure it with the additional SKEY command. This would avoid "connecting" state but would introduce "Profile unknown" state where the accepting client does not yet have the profile of the initiating client. In this case we could also use the non-optional alias created during the connection (or have something like "Add alias to be able to send messages immediately" and show warning if the user proceeds without it).
The additional advantage here is that if the queue of the initiating client was removed, the connection will not procede to create additional queue, failing faster.
These are the proposed changes:
1. Modify NEW command to add flag allowing sender to secure the queue (it should not be allowed if queue is created for the contact address).
2. Include flag into the invitation link URI and in reply address encoding that queue(s) can be secured by the sender (to avoid coupling with the protocol version and preserve the possibility of the longer handshakes).
3. Add SKEY command to SMP protocol to allow the sender securing the message queue.
4. This command has to be supported by SMP proxy as well, so that the sender does not connect to the recipient's server directly.
5. Accepting client will secure the messaging queue before sending the confirmation to it.
6. Initiating client will secure the messaging queue before sending the confirmation.
See [this sequence diagram](../protocol/diagrams/duplex-messaging/duplex-creating-v6.mmd) for the updated handshake protocol.
Changes to threat model: the attacker who compromised TLS and knows the queue address can block the connection, as the protocol no longer requires the recipient to decrypt the confirmation to secure the queue.
Possibly, "fast connection" should be an option in Privacy & security settings.
## Implementation questions
Currently we store received confirmations in the database, so that the client can confirm them. This becomes unnecessary.
+98 -1
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 5.8.0.10
version: 6.0.0.3
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -95,6 +95,7 @@ library
Simplex.Messaging.Agent.Protocol
Simplex.Messaging.Agent.QueryString
Simplex.Messaging.Agent.RetryInterval
Simplex.Messaging.Agent.Stats
Simplex.Messaging.Agent.Store
Simplex.Messaging.Agent.Store.SQLite
Simplex.Messaging.Agent.Store.SQLite.Common
@@ -132,6 +133,8 @@ library
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
Simplex.Messaging.Agent.TRcvQueues
Simplex.Messaging.Client
Simplex.Messaging.Client.Agent
@@ -230,6 +233,7 @@ library
, crypton-x509-validation ==1.6.*
, cryptostore ==0.3.*
, data-default ==0.7.*
, deepseq ==1.4.*
, direct-sqlcipher ==2.3.*
, directory ==1.3.*
, filepath ==1.4.*
@@ -304,6 +308,7 @@ executable ntf-server
, crypton-x509-validation ==1.6.*
, cryptostore ==0.3.*
, data-default ==0.7.*
, deepseq ==1.4.*
, direct-sqlcipher ==2.3.*
, directory ==1.3.*
, filepath ==1.4.*
@@ -382,6 +387,7 @@ executable smp-server
, crypton-x509-validation ==1.6.*
, cryptostore ==0.3.*
, data-default ==0.7.*
, deepseq ==1.4.*
, direct-sqlcipher ==2.3.*
, directory ==1.3.*
, file-embed
@@ -461,6 +467,7 @@ executable xftp
, crypton-x509-validation ==1.6.*
, cryptostore ==0.3.*
, data-default ==0.7.*
, deepseq ==1.4.*
, direct-sqlcipher ==2.3.*
, directory ==1.3.*
, filepath ==1.4.*
@@ -536,6 +543,7 @@ executable xftp-server
, crypton-x509-validation ==1.6.*
, cryptostore ==0.3.*
, data-default ==0.7.*
, deepseq ==1.4.*
, direct-sqlcipher ==2.3.*
, directory ==1.3.*
, filepath ==1.4.*
@@ -698,3 +706,92 @@ test-suite simplexmq-test
bytestring ==0.10.*
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3
benchmark simplexmq-bench
type: exitcode-stdio-1.0
main-is: Bench.hs
other-modules:
Bench.Base64
Bench.BsConcat
Bench.Compression
Bench.SNTRUP761
Bench.TRcvQueues
Paths_simplexmq
hs-source-dirs:
benchmarks
default-extensions:
StrictData
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -fproc-alignment=64 -rtsopts -threaded -with-rtsopts=-A64m -with-rtsopts=-N1 -with-rtsopts=-T
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
, asn1-encoding ==0.9.*
, asn1-types ==0.3.*
, async ==2.2.*
, attoparsec ==0.14.*
, base >=4.14 && <5
, base64 >=1.0
, base64-bytestring
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers
, crypton ==0.34.*
, crypton-x509 ==1.7.*
, crypton-x509-store ==1.6.*
, crypton-x509-validation ==1.6.*
, cryptostore ==0.3.*
, data-default ==0.7.*
, deepseq ==1.4.*
, direct-sqlcipher ==2.3.*
, directory ==1.3.*
, filepath ==1.4.*
, hashable ==1.4.*
, hourglass ==0.2.*
, hspec
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
, ini ==0.4.1
, iproute ==1.7.*
, iso8601-time ==0.1.*
, memory ==0.18.*
, mtl >=2.3.1 && <3.0
, network >=3.1.2.7 && <3.2
, network-info ==0.2.*
, network-transport ==0.5.6
, network-udp ==0.0.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlcipher-simple ==0.4.*
, stm ==2.5.*
, tasty
, tasty-bench
, tasty-hspec
, temporary ==1.3.*
, time ==1.12.*
, time-manager ==0.0.*
, tls >=1.7.0 && <1.8
, transformers ==0.6.*
, unliftio
, unliftio-core ==0.2.*
, unordered-containers
, websockets ==0.12.*
, yaml ==0.11.*
, zstd
default-language: Haskell2010
if flag(swift)
cpp-options: -DswiftJSON
if impl(ghc >= 9.6.2)
build-depends:
bytestring ==0.11.*
, template-haskell ==2.20.*
, text >=2.0.1 && <2.2
if impl(ghc < 9.6.2)
build-depends:
bytestring ==0.10.*
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3
+36 -8
View File
@@ -12,6 +12,7 @@
module Simplex.FileTransfer.Agent
( startXFTPWorkers,
startXFTPSndWorkers,
closeXFTPAgent,
toFSFilePath,
-- Receiving files
@@ -49,6 +50,7 @@ import qualified Data.Set as S
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Simplex.FileTransfer.Chunks (toKB)
import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
import Simplex.FileTransfer.Client.Main
import Simplex.FileTransfer.Crypto
@@ -63,6 +65,7 @@ import Simplex.Messaging.Agent.Client
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Stats
import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
@@ -80,13 +83,21 @@ import UnliftIO.Directory
import qualified UnliftIO.Exception as E
startXFTPWorkers :: AgentClient -> Maybe FilePath -> AM ()
startXFTPWorkers c workDir = do
startXFTPWorkers = startXFTPWorkers_ True
{-# INLINE startXFTPWorkers #-}
startXFTPSndWorkers :: AgentClient -> Maybe FilePath -> AM ()
startXFTPSndWorkers = startXFTPWorkers_ False
{-# INLINE startXFTPSndWorkers #-}
startXFTPWorkers_ :: Bool -> AgentClient -> Maybe FilePath -> AM ()
startXFTPWorkers_ allWorkers c workDir = do
wd <- asks $ xftpWorkDir . xftpAgent
atomically $ writeTVar wd workDir
cfg <- asks config
startRcvFiles cfg
when allWorkers $ startRcvFiles cfg
startSndFiles cfg
startDelFiles cfg
when allWorkers $ startDelFiles cfg
where
startRcvFiles :: AgentConfig -> AM ()
startRcvFiles AgentConfig {rcvFilesTTL} = do
@@ -184,6 +195,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
liftIO $ waitForUserNetwork c
atomically $ incXFTPServerStat c userId srv downloadAttempts
downloadFileChunk fc replica approvedRelays
`catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
where
@@ -194,13 +206,18 @@ runXFTPRcvWorker c srv Worker {doWork} = do
withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
atomically $ assertAgentForeground c
loop
retryDone = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath)
retryDone e = do
atomically . incXFTPServerStat c userId srv $ case e of
XFTP _ XFTP.AUTH -> downloadAuthErrs
_ -> downloadErrs
rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) e
downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> Bool -> AM ()
downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica approvedRelays = do
unlessM ((approvedRelays ||) <$> ipAddressProtected') $ throwE $ FILE NOT_APPROVED
fsFileTmpPath <- lift $ toFSFilePath fileTmpPath
chunkPath <- uniqueCombine fsFileTmpPath $ show chunkNo
let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
let chSize = unFileSize chunkSize
chunkSpec = XFTPRcvChunkSpec chunkPath chSize (unFileDigest digest)
relChunkPath = fileTmpPath </> takeFileName chunkPath
agentXFTPDownloadChunk c userId digest replica chunkSpec
atomically $ waitUntilForeground c
@@ -214,6 +231,8 @@ runXFTPRcvWorker c srv Worker {doWork} = do
Just RcvFileRedirect {redirectFileInfo = RedirectFileInfo {size = FileSize finalSize}, redirectEntityId} -> (redirectEntityId, finalSize)
liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived
pure (entityId, complete, RFPROG rcvd total)
atomically $ incXFTPServerStat c userId srv downloads
atomically $ incXFTPServerSizeStat c userId srv downloadsSize (fromIntegral $ toKB chSize)
notify c entityId progress
when complete . lift . void $
getXFTPRcvWorker True c Nothing
@@ -484,6 +503,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
liftIO $ waitForUserNetwork c
atomically $ incXFTPServerStat c userId srv uploadAttempts
uploadFileChunk cfg fc replica
`catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
where
@@ -494,9 +514,11 @@ runXFTPSndWorker c srv Worker {doWork} = do
withStore' c $ \db -> updateSndChunkReplicaDelay db sndChunkReplicaId replicaDelay
atomically $ assertAgentForeground c
loop
retryDone = sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath)
retryDone e = do
atomically $ incXFTPServerStat c userId srv uploadErrs
sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) e
uploadFileChunk :: AgentConfig -> SndFileChunk -> SndFileChunkReplica -> AM ()
uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath}, digest = chunkDigest} replica = do
uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath, chunkSize = chSize}, digest = chunkDigest} replica = do
replica'@SndFileChunkReplica {sndChunkReplicaId} <- addRecipients sndFileChunk replica
fsFilePath <- lift $ toFSFilePath filePath
unlessM (doesFileExist fsFilePath) $ throwE $ FILE NO_FILE
@@ -510,6 +532,8 @@ runXFTPSndWorker c srv Worker {doWork} = do
let uploaded = uploadedSize chunks
total = totalSize chunks
complete = all chunkUploaded chunks
atomically $ incXFTPServerStat c userId srv uploads
atomically $ incXFTPServerSizeStat c userId srv uploadsSize (fromIntegral $ toKB chSize)
notify c sndFileEntityId $ SFPROG uploaded total
when complete $ do
(sndDescr, rcvDescrs) <- sndFileToDescrs sf
@@ -651,6 +675,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
liftIO $ waitForUserNetwork c
atomically $ incXFTPServerStat c userId srv deleteAttempts
deleteChunkReplica
`catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
where
@@ -661,10 +686,13 @@ runXFTPDelWorker c srv Worker {doWork} = do
withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay
atomically $ assertAgentForeground c
loop
retryDone = delWorkerInternalError c deletedSndChunkReplicaId
retryDone e = do
atomically $ incXFTPServerStat c userId srv deleteErrs
delWorkerInternalError c deletedSndChunkReplicaId e
deleteChunkReplica = do
agentXFTPDeleteChunk c userId replica
withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
atomically $ incXFTPServerStat c userId srv deletions
delWorkerInternalError :: AgentClient -> Int64 -> AgentErrorType -> AM ()
delWorkerInternalError c deletedSndChunkReplicaId e = do
+4
View File
@@ -26,6 +26,10 @@ kb :: Integral a => a -> a
kb n = 1024 * n
{-# INLINE kb #-}
toKB :: Integral a => a -> a
toKB n = n `div` 1024
{-# INLINE toKB #-}
mb :: Integral a => a -> a
mb n = 1024 * kb n
{-# INLINE mb #-}
-4
View File
@@ -22,7 +22,6 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Time (UTCTime)
import Data.Word (Word32)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
@@ -168,9 +167,6 @@ xftpClientServer = B.unpack . strEncode . snd3 . transportSession
xftpTransportHost :: XFTPClient -> TransportHost
xftpTransportHost XFTPClient {http2Client = HTTP2Client {client_ = HClient {host}}} = host
xftpSessionTs :: XFTPClient -> UTCTime
xftpSessionTs = sessionTs . http2Client
xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfig
xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} =
defaultHTTP2ClientConfig
File diff suppressed because it is too large Load Diff
+312 -150
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
@@ -32,6 +33,7 @@ module Simplex.Messaging.Agent.Client
closeAgentClient,
closeProtocolServerClients,
reconnectServerClients,
reconnectSMPServer,
closeXFTPServerClient,
runSMPServerTest,
runXFTPServerTest,
@@ -51,6 +53,7 @@ module Simplex.Messaging.Agent.Client
temporaryOrHostError,
serverHostError,
secureQueue,
secureSndQueue,
enableQueueNotifications,
enableQueuesNtfs,
disableQueueNotifications,
@@ -71,7 +74,6 @@ module Simplex.Messaging.Agent.Client
agentXFTPUploadChunk,
agentXFTPAddRecipients,
agentXFTPDeleteChunk,
agentCbEncrypt,
agentCbDecrypt,
cryptoError,
sendAck,
@@ -87,6 +89,11 @@ module Simplex.Messaging.Agent.Client
activeClientSession,
agentClientStore,
agentDRG,
ServerQueueInfo (..),
AgentServersSummary (..),
ServerSessions (..),
SMPServerSubs (..),
getAgentServersSummary,
getAgentSubscriptions,
slowNetworkConfig,
protocolClientError,
@@ -98,7 +105,6 @@ module Simplex.Messaging.Agent.Client
AgentOpState (..),
AgentState (..),
AgentLocks (..),
AgentStatsKey (..),
getAgentWorker,
getAgentWorker',
cancelWorker,
@@ -134,6 +140,11 @@ module Simplex.Messaging.Agent.Client
getNextServer,
withUserServers,
withNextSrv,
incSMPServerStat,
incSMPServerStat',
incXFTPServerStat,
incXFTPServerStat',
incXFTPServerSizeStat,
AgentWorkersDetails (..),
getAgentWorkersDetails,
AgentWorkersSummary (..),
@@ -149,7 +160,7 @@ module Simplex.Messaging.Agent.Client
where
import Control.Applicative ((<|>))
import Control.Concurrent (ThreadId, forkIO, threadDelay)
import Control.Concurrent (ThreadId, forkIO)
import Control.Concurrent.Async (Async, uninterruptibleCancel)
import Control.Concurrent.STM (retry, throwSTM)
import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..))
@@ -163,17 +174,18 @@ import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as J
import Data.Bifunctor (bimap, first, second)
import Data.ByteString.Base64
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (partitionEithers)
import Data.Either (isRight, partitionEithers)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (deleteFirstsBy, foldl', partition, (\\))
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (isJust, isNothing, listToMaybe)
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
@@ -195,6 +207,7 @@ import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Stats
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), withTransaction)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
@@ -223,6 +236,7 @@ import Simplex.Messaging.Protocol
ProtoServerWithAuth (..),
Protocol (..),
ProtocolServer (..),
ProtocolType (..),
ProtocolTypeI (..),
QueueId,
QueueIdsKeys (..),
@@ -230,6 +244,7 @@ import Simplex.Messaging.Protocol
RcvNtfPublicDhKey,
SMPMsgMeta (..),
SProtocolType (..),
SenderCanSecure,
SndPublicAuthKey,
SubscriptionMode (..),
UserProtocol,
@@ -275,7 +290,7 @@ data AgentClient = AgentClient
active :: TVar Bool,
subQ :: TBQueue ATransmission,
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
smpServers :: TMap UserId (NonEmpty SMPServerWithAuth),
smpServers :: TMap UserId (UserServers 'PSMP),
smpClients :: TMap SMPTransportSession SMPClientVar,
-- smpProxiedRelays:
-- SMPTransportSession defines connection from proxy to relay,
@@ -283,7 +298,7 @@ data AgentClient = AgentClient
smpProxiedRelays :: TMap SMPTransportSession SMPServerWithAuth,
ntfServers :: TVar [NtfServer],
ntfClients :: TMap NtfTransportSession NtfClientVar,
xftpServers :: TMap UserId (NonEmpty XFTPServerWithAuth),
xftpServers :: TMap UserId (UserServers 'PXFTP),
xftpClients :: TMap XFTPTransportSession XFTPClientVar,
useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks
userNetworkInfo :: TVar UserNetworkInfo,
@@ -311,10 +326,11 @@ data AgentClient = AgentClient
deleteLock :: Lock,
-- smpSubWorkers for SMP servers sessions
smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ())),
agentStats :: TMap AgentStatsKey (TVar Int),
msgCounts :: TMap ConnId (TVar (Int, Int)), -- (total, duplicates)
clientId :: Int,
agentEnv :: Env
agentEnv :: Env,
smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats,
xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats,
srvStatsStartedAt :: TVar UTCTime
}
data SMPConnectedClient = SMPConnectedClient
@@ -417,15 +433,6 @@ data AgentLocks = AgentLocks
}
deriving (Show)
data AgentStatsKey = AgentStatsKey
{ userId :: UserId,
host :: ByteString,
clientTs :: ByteString,
cmd :: ByteString,
res :: ByteString
}
deriving (Eq, Ord, Show)
data UserNetworkInfo = UserNetworkInfo
{ networkType :: UserNetworkType,
online :: Bool
@@ -442,20 +449,20 @@ data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther
deriving (Eq, Show)
-- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
newAgentClient :: Int -> InitialAgentServers -> Env -> STM AgentClient
newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do
newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Env -> STM AgentClient
newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs agentEnv = do
let cfg = config agentEnv
qSize = tbqSize cfg
acThread <- newTVar Nothing
active <- newTVar True
subQ <- newTBQueue qSize
msgQ <- newTBQueue qSize
smpServers <- newTVar smp
smpServers <- newTVar $ M.map mkUserServers smp
smpClients <- TM.empty
smpProxiedRelays <- TM.empty
ntfServers <- newTVar ntf
ntfClients <- TM.empty
xftpServers <- newTVar xftp
xftpServers <- newTVar $ M.map mkUserServers xftp
xftpClients <- TM.empty
useNetworkConfig <- newTVar (slowNetworkConfig netCfg, netCfg)
userNetworkInfo <- newTVar $ UserNetworkInfo UNOther True
@@ -479,8 +486,9 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
invLocks <- TM.empty
deleteLock <- createLock
smpSubWorkers <- TM.empty
agentStats <- TM.empty
msgCounts <- TM.empty
smpServersStats <- TM.empty
xftpServersStats <- TM.empty
srvStatsStartedAt <- newTVar currentTs
return
AgentClient
{ acThread,
@@ -516,10 +524,11 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
invLocks,
deleteLock,
smpSubWorkers,
agentStats,
msgCounts,
clientId,
agentEnv
agentEnv,
smpServersStats,
xftpServersStats,
srvStatsStartedAt
}
slowNetworkConfig :: NetworkConfig -> NetworkConfig
@@ -546,7 +555,6 @@ class (Encoding err, Show err) => ProtocolServerClient v err msg | msg -> v, msg
closeProtocolServerClient :: ProtoClient msg -> IO ()
clientServer :: ProtoClient msg -> String
clientTransportHost :: ProtoClient msg -> TransportHost
clientSessionTs :: ProtoClient msg -> UTCTime
instance ProtocolServerClient SMPVersion ErrorType BrokerMsg where
type Client BrokerMsg = SMPConnectedClient
@@ -557,7 +565,6 @@ instance ProtocolServerClient SMPVersion ErrorType BrokerMsg where
closeProtocolServerClient = closeProtocolClient
clientServer = protocolClientServer
clientTransportHost = transportHost'
clientSessionTs = sessionTs
instance ProtocolServerClient NTFVersion ErrorType NtfResponse where
type Client NtfResponse = ProtocolClient NTFVersion ErrorType NtfResponse
@@ -568,7 +575,6 @@ instance ProtocolServerClient NTFVersion ErrorType NtfResponse where
closeProtocolServerClient = closeProtocolClient
clientServer = protocolClientServer
clientTransportHost = transportHost'
clientSessionTs = sessionTs
instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where
type Client FileResponse = XFTPClient
@@ -579,7 +585,6 @@ instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where
closeProtocolServerClient = X.closeXFTPClient
clientServer = X.xftpClientServer
clientTransportHost = X.xftpTransportHost
clientSessionTs = X.xftpSessionTs
getSMPServerClient :: AgentClient -> SMPTransportSession -> AM SMPConnectedClient
getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
@@ -592,10 +597,10 @@ getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
prs <- atomically TM.empty
smpConnectClient c tSess prs v
getSMPProxyClient :: AgentClient -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} destSess@(userId, destSrv, qId) = do
getSMPProxyClient :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} proxySrv_ destSess@(userId, destSrv, qId) = do
unlessM (readTVarIO active) $ throwE INACTIVE
proxySrv <- getNextServer c userId [destSrv]
proxySrv <- maybe (getNextServer c userId [destSrv]) pure proxySrv_
ts <- liftIO getCurrentTime
atomically (getClientVar proxySrv ts) >>= \(tSess, auth, v) ->
either (newProxyClient tSess auth ts) (waitForProxyClient tSess auth) v
@@ -623,14 +628,12 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
>>= either (newProxiedRelay clnt auth) (waitForProxiedRelay tSess)
pure (clnt, sess)
newProxiedRelay :: SMPConnectedClient -> Maybe SMP.BasicAuth -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay)
newProxiedRelay clnt@(SMPConnectedClient smp prs) proxyAuth rv =
newProxiedRelay (SMPConnectedClient smp prs) proxyAuth rv =
tryAgentError (liftClient SMP (clientServer smp) $ connectSMPProxiedRelay smp destSrv proxyAuth) >>= \case
Right sess -> do
atomically $ putTMVar (sessionVar rv) (Right sess)
liftIO $ incClientStat c userId clnt "PROXY" "OK"
pure $ Right sess
Left e -> do
liftIO $ incClientStat c userId clnt "PROXY" $ bshow e
atomically $ do
unless (serverHostError e) $ do
removeSessVar rv destSrv prs
@@ -682,7 +685,6 @@ smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess
serverDown :: ([RcvQueue], [ConnId]) -> IO ()
serverDown (qs, conns) = whenM (readTVarIO active) $ do
incClientStat' c userId client "DISCONNECT" ""
notifySub "" $ hostEvent' DISCONNECT client
unless (null conns) $ notifySub "" $ DOWN srv conns
unless (null qs) $ do
@@ -744,7 +746,7 @@ reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId, srv, _) = do
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(_, srv, _) = do
unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess ntfClients ts)
@@ -763,12 +765,11 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId,
clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
clientDisconnected v client = do
atomically $ removeSessVar v tSess ntfClients
incClientStat c userId client "DISCONNECT" ""
atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId, srv, _) = do
getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(_, srv, _) = do
unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess xftpClients ts)
@@ -787,7 +788,6 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId
clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
clientDisconnected v client = do
atomically $ removeSessVar v tSess xftpClients
incClientStat c userId client "DISCONNECT" ""
atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
@@ -827,11 +827,9 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v =
Right client -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
atomically $ putTMVar (sessionVar v) (Right client)
liftIO $ incClientStat c userId client "CLIENT" "OK"
atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent CONNECT client)
pure client
Left e -> do
liftIO $ incServerStat c userId srv "CLIENT" $ bshow e
ei <- asks $ persistErrorInterval . config
if ei == 0
then atomically $ do
@@ -925,6 +923,16 @@ reconnectServerClients :: ProtocolServerClient v err msg => AgentClient -> (Agen
reconnectServerClients c clientsSel =
readTVarIO (clientsSel c) >>= mapM_ (forkIO . closeClient_ c)
reconnectSMPServer :: AgentClient -> UserId -> SMPServer -> IO ()
reconnectSMPServer c userId srv = do
cs <- readTVarIO $ smpClients c
let vs = M.foldrWithKey srvClient [] cs
mapM_ (forkIO . closeClient_ c) vs
where
srvClient (userId', srv', _) v
| userId == userId' && srv == srv' = (v :)
| otherwise = id
closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO ()
closeClient c clientSel tSess =
atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c)
@@ -975,46 +983,42 @@ getMapLock locks key = TM.lookup key locks >>= maybe newLock pure
where
newLock = createLock >>= \l -> TM.insert key l locks $> l
withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> AM a) -> AM a
withClient_ c tSess@(userId, srv, _) statCmd action = do
withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> AM a) -> AM a
withClient_ c tSess@(_, srv, _) action = do
cl <- getProtocolServerClient c tSess
(action cl <* stat cl "OK") `catchAgentError` logServerError cl
action cl `catchAgentError` logServerError
where
stat cl = liftIO . incClientStat c userId cl statCmd
logServerError :: Client msg -> AgentErrorType -> AM a
logServerError cl e = do
logServerError :: AgentErrorType -> AM a
logServerError e = do
logServer "<--" c srv "" $ bshow e
stat cl $ bshow e
throwE e
withProxySession :: AgentClient -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
withProxySession c destSess@(userId, destSrv, _) entId cmdStr action = do
(cl, sess_) <- getSMPProxyClient c destSess
withProxySession :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do
(cl, sess_) <- getSMPProxyClient c proxySrv_ destSess
logServer ("--> " <> proxySrv cl <> " >") c destSrv entId cmdStr
case sess_ of
Right sess -> do
r <- (action (cl, sess) <* stat cl "OK") `catchAgentError` logServerError cl
r <- action (cl, sess) `catchAgentError` logServerError cl
logServer ("<-- " <> proxySrv cl <> " <") c destSrv entId "OK"
pure r
Left e -> logServerError cl e
where
stat cl = liftIO . incClientStat c userId cl cmdStr
proxySrv = showServer . protocolClientServer' . protocolClient
logServerError :: SMPConnectedClient -> AgentErrorType -> AM a
logServerError cl e = do
logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ bshow e
stat cl $ bshow e
throwE e
withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> AM a) -> AM a
withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do
logServer "-->" c srv entId cmdStr
res <- withClient_ c tSess cmdStr action
res <- withClient_ c tSess action
logServer "<--" c srv entId "OK"
return res
withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
withClient c tSess action = withClient_ c tSess $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
{-# INLINE withClient #-}
withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
@@ -1027,9 +1031,29 @@ withSMPClient c q cmdStr action = do
withLogClient c tSess (queueId q) cmdStr $ action . connectedClient
sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer)
sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg = do
sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg =
sendOrProxySMPCommand c userId destSrv cmdStr senderId sendViaProxy sendDirectly
where
sendViaProxy smp proxySess = do
atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts
atomically $ incSMPServerStat c userId (protocolClientServer' smp) sentProxiedAttempts
proxySMPMessage smp proxySess spKey_ senderId msgFlags msg
sendDirectly smp = do
atomically $ incSMPServerStat c userId destSrv sentDirectAttempts
sendSMPMessage smp spKey_ senderId msgFlags msg
sendOrProxySMPCommand ::
AgentClient ->
UserId ->
SMPServer ->
ByteString ->
SMP.SenderId ->
(SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) ->
(SMPClient -> ExceptT SMPClientError IO ()) ->
AM (Maybe SMPServer)
sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
sess <- liftIO $ mkTransportSession c userId destSrv senderId
ifM (atomically shouldUseProxy) (sendViaProxy sess) (sendDirectly sess $> Nothing)
ifM (atomically shouldUseProxy) (sendViaProxy Nothing sess) (sendDirectly sess $> Nothing)
where
shouldUseProxy = do
cfg <- getNetworkConfig c
@@ -1046,22 +1070,32 @@ sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg = do
SPFAllow -> True
SPFAllowProtected -> ipAddressProtected cfg destSrv
SPFProhibit -> False
unknownServer = maybe True (all ((destSrv /=) . protoServer)) <$> TM.lookup userId (userServers c)
sendViaProxy destSess@(_, _, qId) = do
r <- tryAgentError . withProxySession c destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess) -> do
liftClient SMP (clientServer smp) (proxySMPMessage smp proxySess spKey_ senderId msgFlags msg) >>= \case
Right () -> pure . Just $ protocolClientServer' smp
unknownServer = maybe True (notElem destSrv . knownSrvs) <$> TM.lookup userId (smpServers c)
sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer)
sendViaProxy proxySrv_ destSess@(_, _, qId) = do
r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess
let proxySrv = protocolClientServer' smp
case r' of
Right () -> pure $ Just proxySrv
Left proxyErr -> do
case proxyErr of
(ProxyProtocolError (SMP.PROXY SMP.NO_SESSION)) -> atomically deleteRelaySession
_ -> pure ()
throwE
PROXY
{ proxyServer = protocolClientServer smp,
relayServer = B.unpack $ strEncode destSrv,
proxyErr
}
ProxyProtocolError (SMP.PROXY SMP.NO_SESSION) -> do
atomically deleteRelaySession
case proxySrv_ of
Just _ -> proxyError
-- sendViaProxy is called recursively here to re-create the session via the same server
-- to avoid failure in interactive calls that don't retry after the session disconnection.
Nothing -> sendViaProxy (Just $ ProtoServerWithAuth proxySrv prBasicAuth) destSess
_ -> proxyError
where
proxyError =
throwE
PROXY
{ proxyServer = protocolClientServer smp,
relayServer = B.unpack $ strEncode destSrv,
proxyErr
}
-- checks that the current proxied relay session is the same one that was used to send the message and removes it
deleteRelaySession =
( TM.lookup destSess (smpProxiedRelays c)
@@ -1077,13 +1111,19 @@ sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg = do
sameClient smp' = sessionId (thParams smp) == sessionId (thParams smp')
sameProxiedRelay proxySess' = prSessionId proxySess == prSessionId proxySess'
case r of
Right r' -> pure r'
Right r' -> do
atomically $ incSMPServerStat c userId destSrv sentViaProxy
forM_ r' $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied
pure r'
Left e
| serverHostError e -> ifM (atomically directAllowed) (sendDirectly destSess $> Nothing) (throwE e)
| otherwise -> throwE e
sendDirectly tSess =
withLogClient_ c tSess senderId ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) ->
liftClient SMP (clientServer smp) $ sendSMPMessage smp spKey_ senderId msgFlags msg
withLogClient_ c tSess senderId ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
r <- tryAgentError $ liftClient SMP (clientServer smp) $ sendCmdDirectly smp
case r of
Right () -> atomically $ incSMPServerStat c userId destSrv sentDirect
Left e -> throwE e
ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool
ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts _ _) = do
@@ -1153,11 +1193,14 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case
Right smp -> do
rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g
(sKey, _) <- atomically $ C.generateAuthKeyPair sa g
(sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
(dhKey, _) <- atomically $ C.generateKeyPair g
r <- runExceptT $ do
SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe
liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey
SMP.QIK {rcvId, sndId, sndSecure} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe True
liftError (testErr TSSecureQueue) $
if sndSecure
then secureSndSMPQueue smp spKey sndId sKey
else 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 (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
@@ -1192,7 +1235,6 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
unless (digest == rcvDigest) $ throwE $ ProtocolTestFailure TSCompareFile $ XFTP (B.unpack $ strEncode srv) DIGEST
liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId
ok <- tcpTimeout xftpNetworkConfig `timeout` X.closeXFTPClient xftp
incClientStat c userId xftp "XFTP_TEST" "OK"
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
Left e -> pure (Just $ testErr TSConnect e)
where
@@ -1231,7 +1273,6 @@ runNTFServerTest c userId (ProtoServerWithAuth srv _) = do
(tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf npKey (NewNtfTkn deviceToken nKey dhKey)
liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf npKey tknId
ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient ntf
incClientStat c userId ntf "NTF_TEST" "OK"
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
Left e -> pure (Just $ testErr TSConnect e)
where
@@ -1264,8 +1305,8 @@ getSessionMode :: AgentClient -> IO TransportSessionMode
getSessionMode = atomically . fmap sessionMode . getNetworkConfig
{-# INLINE getSessionMode #-}
newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do
newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> SenderCanSecure -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode senderCanSecure = do
C.AuthAlg a <- asks (rcvAuthAlg . config)
g <- asks random
rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g
@@ -1273,9 +1314,9 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do
(e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g
logServer "-->" c srv "" "NEW"
tSess <- liftIO $ mkTransportSession c userId srv connId
(sessId, QIK {rcvId, sndId, rcvPublicDhKey}) <-
withClient c tSess "NEW" $ \(SMPConnectedClient smp _) ->
(sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode
(sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <-
withClient c tSess $ \(SMPConnectedClient smp _) ->
(sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode senderCanSecure
liftIO . logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
let rq =
RcvQueue
@@ -1288,6 +1329,7 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do
e2ePrivKey,
e2eDhSecret = Nothing,
sndId,
sndSecure,
status = New,
dbQueueId = DBNewQueue,
primary = True,
@@ -1297,17 +1339,20 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do
clientNtfCreds = Nothing,
deleteErrors = 0
}
qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey
qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey sndSecure
pure (rq, qUri, tSess, sessId)
processSubResult :: AgentClient -> RcvQueue -> Either SMPClientError () -> STM ()
processSubResult c rq@RcvQueue {connId} = \case
processSubResult c rq@RcvQueue {userId, server, connId} = \case
Left e ->
unless (temporaryClientError e) $
unless (temporaryClientError e) $ do
incSMPServerStat c userId server connSubErrs
failSubscription c rq e
Right () ->
whenM (hasPendingSubscription c connId) $
addSubscription c rq
ifM
(hasPendingSubscription c connId)
(incSMPServerStat c userId server connSubscribed >> addSubscription c rq)
(incSMPServerStat c userId server connSubIgnored)
temporaryAgentError :: AgentErrorType -> Bool
temporaryAgentError = \case
@@ -1350,7 +1395,7 @@ subscribeQueues c qs = do
env <- ask
-- only "checked" queues are subscribed
session <- newTVarIO Nothing
rs <- sendTSessionBatches "SUB" 90 id (subscribeQueues_ env session) c qs'
rs <- sendTSessionBatches "SUB" id (subscribeQueues_ env session) c qs'
(errs <> rs,) <$> readTVarIO session
where
checkQueue rq = do
@@ -1358,13 +1403,15 @@ subscribeQueues c qs = do
pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq
subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
subscribeQueues_ env session smp qs' = do
let (userId, srv, _) = transportSession' smp
atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs'
rs <- sendBatch subscribeSMPQueues smp qs'
active <-
atomically $
ifM
(activeClientSession c tSess sessId)
(writeTVar session (Just sessId) >> processSubResults rs $> True)
(pure False)
(incSMPServerStat' c userId srv connSubIgnored (length rs) $> False)
if active
then when (hasTempErrors rs) resubscribe $> rs
else do
@@ -1387,9 +1434,8 @@ activeClientSession c tSess sessId = sameSess <$> tryReadSessVar tSess (smpClien
type BatchResponses e r = NonEmpty (RcvQueue, Either e r)
-- statBatchSize is not used to batch the commands, only for traffic statistics
sendTSessionBatches :: forall q r. ByteString -> Int -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> AM' [(RcvQueue, Either AgentErrorType r)]
sendTSessionBatches statCmd statBatchSize toRQ action c qs =
sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> AM' [(RcvQueue, Either AgentErrorType r)]
sendTSessionBatches statCmd toRQ action c qs =
concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
where
batchQueues :: AM' [(SMPTransportSession, NonEmpty q)]
@@ -1401,19 +1447,14 @@ sendTSessionBatches statCmd statBatchSize toRQ action c qs =
let tSess = mkSMPTSession (toRQ q) mode
in M.alter (Just . maybe [q] (q <|)) tSess m
sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses AgentErrorType r)
sendClientBatch (tSess@(userId, srv, _), qs') =
sendClientBatch (tSess@(_, srv, _), qs') =
tryAgentError' (getSMPServerClient c tSess) >>= \case
Left e -> pure $ L.map ((,Left e) . toRQ) qs'
Right (SMPConnectedClient smp _) -> liftIO $ do
logServer "-->" c srv (bshow (length qs') <> " queues") statCmd
rs <- L.map agentError <$> action smp qs'
statBatch
pure rs
L.map agentError <$> action smp qs'
where
agentError = second . first $ protocolClientError SMP $ clientServer smp
statBatch =
let n = (length qs - 1) `div` statBatchSize + 1
in incClientStatN c userId smp n statCmd "OK"
sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
@@ -1475,14 +1516,15 @@ showServer ProtocolServer {host, port} =
{-# INLINE showServer #-}
logSecret :: ByteString -> ByteString
logSecret bs = encode $ B.take 3 bs
logSecret bs = B64.encode $ B.take 3 bs
{-# INLINE logSecret #-}
sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer)
sendConfirmation c sq@SndQueue {userId, server, sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation
sendConfirmation c sq@SndQueue {userId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
let (privHdr, spKey) = if sndSecure then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation sndPublicKey, Nothing)
clientMsg = SMP.ClientMessage privHdr agentConfirmation
msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
sendOrProxySMPMessage c userId server "<CONF>" Nothing sndId (MsgFlags {notification = True}) msg
sendOrProxySMPMessage c userId server "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
sendInvitation :: AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
@@ -1523,13 +1565,21 @@ secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
withSMPClient c rq "KEY <key>" $ \smp ->
secureSMPQueue smp rcvPrivateKey rcvId senderKey
secureSndQueue :: AgentClient -> SndQueue -> AM ()
secureSndQueue c SndQueue {userId, server, sndId, sndPrivateKey, sndPublicKey} =
void $ sendOrProxySMPCommand c userId server "SKEY <key>" sndId secureViaProxy secureDirectly
where
-- TODO track statistics
secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey
secureDirectly smp = secureSndSMPQueue smp sndPrivateKey sndId sndPublicKey
enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey)
enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
withSMPClient c rq "NKEY <nkey>" $ \smp ->
enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
enableQueuesNtfs :: AgentClient -> [(RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)] -> AM' [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
enableQueuesNtfs = sendTSessionBatches "NKEY" 90 fst3 enableQueues_
enableQueuesNtfs = sendTSessionBatches "NKEY" fst3 enableQueues_
where
fst3 (x, _, _) = x
enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
@@ -1543,7 +1593,7 @@ disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
disableSMPQueueNotifications smp rcvPrivateKey rcvId
disableQueuesNtfs :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
disableQueuesNtfs = sendTSessionBatches "NDEL" 90 id $ sendBatch disableSMPQueuesNtfs
disableQueuesNtfs = sendTSessionBatches "NDEL" id $ sendBatch disableSMPQueuesNtfs
sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
@@ -1570,7 +1620,15 @@ deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do
deleteSMPQueue smp rcvPrivateKey rcvId
deleteQueues :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
deleteQueues = sendTSessionBatches "DEL" 90 id $ sendBatch deleteSMPQueues
deleteQueues c = sendTSessionBatches "DEL" id deleteQueues_ c
where
deleteQueues_ smp rqs = do
let (userId, srv, _) = transportSession' smp
atomically $ incSMPServerStat' c userId srv connDelAttempts $ length rqs
rs <- sendBatch deleteSMPQueues smp rqs
let successes = foldl' (\n (_, r) -> if isRight r then n + 1 else n) 0 rs
atomically $ incSMPServerStat' c userId srv connDeleted successes
pure rs
sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer)
sendAgentMessage c sq@SndQueue {userId, server, sndId, sndPrivateKey} msgFlags agentMsg = do
@@ -1578,14 +1636,28 @@ sendAgentMessage c sq@SndQueue {userId, server, sndId, sndPrivateKey} msgFlags a
msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
sendOrProxySMPMessage c userId server "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
getQueueInfo :: AgentClient -> RcvQueue -> AM QueueInfo
getQueueInfo c rq@RcvQueue {rcvId, rcvPrivateKey} =
withSMPClient c rq "QUE" $ \smp ->
getSMPQueueInfo smp rcvPrivateKey rcvId
data ServerQueueInfo = ServerQueueInfo
{ server :: SMPServer,
rcvId :: Text,
sndId :: Text,
ntfId :: Maybe Text,
status :: Text,
info :: QueueInfo
}
deriving (Show)
getQueueInfo :: AgentClient -> RcvQueue -> AM ServerQueueInfo
getQueueInfo c rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientNtfCreds} =
withSMPClient c rq "QUE" $ \smp -> do
info <- getSMPQueueInfo smp rcvPrivateKey rcvId
let ntfId = enc . (\ClientNtfCreds {notifierId} -> notifierId) <$> clientNtfCreds
pure ServerQueueInfo {server, rcvId = enc rcvId, sndId = enc sndId, ntfId, status = serializeQueueStatus status, info}
where
enc = decodeLatin1 . B64.encode
agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
withClient c (0, ntfServer, Nothing) "TNEW" $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
withClient c (0, ntfServer, Nothing) $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
agentNtfVerifyToken :: AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> AM ()
agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code =
@@ -1631,7 +1703,7 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize},
let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
logServer "-->" c srv "" "FNEW"
tSess <- liftIO $ mkTransportSession c userId srv chunkDigest
(sndId, rIds) <- withClient c tSess "FNEW" $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
(sndId, rIds) <- withClient c tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
logServer "<--" c srv "" $ B.unwords ["SIDS", logSecret sndId]
pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys}
@@ -1842,34 +1914,7 @@ storeError = \case
SEDatabaseBusy e -> CRITICAL True $ B.unpack e
e -> INTERNAL $ show e
incStat :: AgentClient -> Int -> AgentStatsKey -> STM ()
incStat AgentClient {agentStats} n k = do
TM.lookup k agentStats >>= \case
Just v -> modifyTVar' v (+ n)
_ -> newTVar n >>= \v -> TM.insert k v agentStats
incClientStat :: ProtocolServerClient v err msg => AgentClient -> UserId -> Client msg -> ByteString -> ByteString -> IO ()
incClientStat c userId = incClientStat' c userId . protocolClient
{-# INLINE incClientStat #-}
incClientStat' :: ProtocolServerClient v err msg => AgentClient -> UserId -> ProtoClient msg -> ByteString -> ByteString -> IO ()
incClientStat' c userId pc = incClientStatN c userId pc 1
{-# INLINE incClientStat' #-}
incServerStat :: AgentClient -> UserId -> ProtocolServer p -> ByteString -> ByteString -> IO ()
incServerStat c userId ProtocolServer {host} cmd res = do
threadDelay 100000
atomically $ incStat c 1 statsKey
where
statsKey = AgentStatsKey {userId, host = strEncode $ L.head host, clientTs = "", cmd, res}
incClientStatN :: ProtocolServerClient v err msg => AgentClient -> UserId -> ProtoClient msg -> Int -> ByteString -> ByteString -> IO ()
incClientStatN c userId pc n cmd res = do
atomically $ incStat c n statsKey
where
statsKey = AgentStatsKey {userId, host = strEncode $ clientTransportHost pc, clientTs = strEncode $ clientSessionTs pc, cmd, res}
userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMap UserId (NonEmpty (ProtoServerWithAuth p))
userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMap UserId (UserServers p)
userServers c = case protocolTypeI @p of
SPSMP -> smpServers c
SPXFTP -> xftpServers c
@@ -1891,7 +1936,7 @@ getNextServer c userId usedSrvs = withUserServers c userId $ \srvs ->
withUserServers :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> (NonEmpty (ProtoServerWithAuth p) -> AM a) -> AM a
withUserServers c userId action =
atomically (TM.lookup userId $ userServers c) >>= \case
Just srvs -> action srvs
Just srvs -> action $ enabledSrvs srvs
_ -> throwE $ INTERNAL "unknown userId - no user servers"
withNextSrv :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> TVar [ProtocolServer p] -> [ProtocolServer p] -> (ProtoServerWithAuth p -> AM a) -> AM a
@@ -1900,11 +1945,120 @@ withNextSrv c userId usedSrvs initUsed action = do
srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId used
atomically $ do
srvs_ <- TM.lookup userId $ userServers c
let unused = maybe [] ((\\ used) . map protoServer . L.toList) srvs_
let unused = maybe [] ((\\ used) . map protoServer . L.toList . enabledSrvs) srvs_
used' = if null unused then initUsed else srv : used
writeTVar usedSrvs $! used'
action srvAuth
incSMPServerStat :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> STM ()
incSMPServerStat c userId srv sel = incSMPServerStat' c userId srv sel 1
incSMPServerStat' :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> Int -> STM ()
incSMPServerStat' AgentClient {smpServersStats} userId srv sel n = do
TM.lookup (userId, srv) smpServersStats >>= \case
Just v -> modifyTVar' (sel v) (+ n)
Nothing -> do
newStats <- newAgentSMPServerStats
modifyTVar' (sel newStats) (+ n)
TM.insert (userId, srv) newStats smpServersStats
incXFTPServerStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> STM ()
incXFTPServerStat c userId srv sel = incXFTPServerStat_ c userId srv sel 1
{-# INLINE incXFTPServerStat #-}
incXFTPServerStat' :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> Int -> STM ()
incXFTPServerStat' = incXFTPServerStat_
{-# INLINE incXFTPServerStat' #-}
incXFTPServerSizeStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int64) -> Int64 -> STM ()
incXFTPServerSizeStat = incXFTPServerStat_
{-# INLINE incXFTPServerSizeStat #-}
incXFTPServerStat_ :: Num n => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar n) -> n -> STM ()
incXFTPServerStat_ AgentClient {xftpServersStats} userId srv sel n = do
TM.lookup (userId, srv) xftpServersStats >>= \case
Just v -> modifyTVar' (sel v) (+ n)
Nothing -> do
newStats <- newAgentXFTPServerStats
modifyTVar' (sel newStats) (+ n)
TM.insert (userId, srv) newStats xftpServersStats
data AgentServersSummary = AgentServersSummary
{ smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData,
xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData,
statsStartedAt :: UTCTime,
smpServersSessions :: Map (UserId, SMPServer) ServerSessions,
smpServersSubs :: Map (UserId, SMPServer) SMPServerSubs,
xftpServersSessions :: Map (UserId, XFTPServer) ServerSessions,
xftpRcvInProgress :: [XFTPServer],
xftpSndInProgress :: [XFTPServer],
xftpDelInProgress :: [XFTPServer]
}
deriving (Show)
data SMPServerSubs = SMPServerSubs
{ ssActive :: Int, -- based on activeSubs
ssPending :: Int -- based on pendingSubs
}
deriving (Show)
data ServerSessions = ServerSessions
{ ssConnected :: Int,
ssErrors :: Int,
ssConnecting :: Int
}
deriving (Show)
getAgentServersSummary :: AgentClient -> IO AgentServersSummary
getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt, agentEnv} = do
sss <- mapM getAgentSMPServerStats =<< readTVarIO smpServersStats
xss <- mapM getAgentXFTPServerStats =<< readTVarIO xftpServersStats
statsStartedAt <- readTVarIO srvStatsStartedAt
smpServersSessions <- countSessions =<< readTVarIO (smpClients c)
smpServersSubs <- getServerSubs
xftpServersSessions <- countSessions =<< readTVarIO (xftpClients c)
xftpRcvInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpRcvWorkers
xftpSndInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpSndWorkers
xftpDelInProgress <- getXFTPWorkerSrvs xftpDelWorkers
pure
AgentServersSummary
{ smpServersStats = sss,
xftpServersStats = xss,
statsStartedAt,
smpServersSessions,
smpServersSubs,
xftpServersSessions,
xftpRcvInProgress,
xftpSndInProgress,
xftpDelInProgress
}
where
getServerSubs = do
subs <- M.foldrWithKey' (addSub incActive) M.empty <$> readTVarIO (getRcvQueues $ activeSubs c)
M.foldrWithKey' (addSub incPending) subs <$> readTVarIO (getRcvQueues $ pendingSubs c)
where
addSub f (userId, srv, _) _ = M.alter (Just . f . fromMaybe SMPServerSubs {ssActive = 0, ssPending = 0}) (userId, srv)
incActive ss = ss {ssActive = ssActive ss + 1}
incPending ss = ss {ssPending = ssPending ss + 1}
Env {xftpAgent = XFTPAgent {xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}} = agentEnv
getXFTPWorkerSrvs workers = foldM addSrv [] . M.toList =<< readTVarIO workers
where
addSrv acc (srv, Worker {doWork}) = do
hasWork <- atomically $ not <$> isEmptyTMVar doWork
pure $ if hasWork then srv : acc else acc
countSessions :: Map (TransportSession msg) (ClientVar msg) -> IO (Map (UserId, ProtoServer msg) ServerSessions)
countSessions = foldM addClient M.empty . M.toList
where
addClient !acc ((userId, srv, _), SessionVar {sessionVar}) = do
c_ <- atomically $ tryReadTMVar sessionVar
pure $ M.alter (Just . add c_) (userId, srv) acc
where
add c_ = modifySessions c_ . fromMaybe ServerSessions {ssConnected = 0, ssErrors = 0, ssConnecting = 0}
modifySessions c_ ss = case c_ of
Just (Right _) -> ss {ssConnected = ssConnected ss + 1}
Just (Left _) -> ss {ssErrors = ssErrors ss + 1}
Nothing -> ss {ssConnecting = ssConnecting ss + 1}
data SubInfo = SubInfo {userId :: UserId, server :: Text, rcvId :: Text, subError :: Maybe String}
deriving (Show)
@@ -2095,6 +2249,12 @@ $(J.deriveJSON (enumJSON $ dropPrefix "TS") ''ProtocolTestStep)
$(J.deriveJSON defaultJSON ''ProtocolTestFailure)
$(J.deriveJSON defaultJSON ''ServerSessions)
$(J.deriveJSON defaultJSON ''SMPServerSubs)
$(J.deriveJSON defaultJSON ''AgentServersSummary)
$(J.deriveJSON defaultJSON ''SubInfo)
$(J.deriveJSON defaultJSON ''SubscriptionsInfo)
@@ -2114,3 +2274,5 @@ $(J.deriveJSON defaultJSON ''AgentQueuesInfo)
$(J.deriveJSON (enumJSON $ dropPrefix "UN") ''UserNetworkType)
$(J.deriveJSON defaultJSON ''UserNetworkInfo)
$(J.deriveJSON defaultJSON ''ServerQueueInfo)
+53 -3
View File
@@ -7,6 +7,7 @@
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
@@ -15,7 +16,12 @@ module Simplex.Messaging.Agent.Env.SQLite
AM,
AgentConfig (..),
InitialAgentServers (..),
ServerCfg (..),
UserServers (..),
NetworkConfig (..),
presetServerCfg,
enabledServerCfg,
mkUserServers,
defaultAgentConfig,
defaultReconnectInterval,
tryAgentError,
@@ -39,10 +45,14 @@ import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Crypto.Random
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson.TH as JQ
import Data.ByteArray (ScrubbedBytes)
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Time.Clock (NominalDiffTime, nominalDay)
import Data.Time.Clock.System (SystemTime (..))
import Data.Word (Word16)
@@ -59,7 +69,8 @@ import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRa
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Notifications.Transport (NTFVersion)
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Protocol (NtfServer, VersionRangeSMPC, XFTPServer, XFTPServerWithAuth, supportedSMPClientVRange)
import Simplex.Messaging.Parsers (defaultJSON)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth, ProtocolServer, ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SMPVersion, TLS, Transport (..))
@@ -74,12 +85,38 @@ type AM' a = ReaderT Env IO a
type AM a = ExceptT AgentErrorType (ReaderT Env IO) a
data InitialAgentServers = InitialAgentServers
{ smp :: Map UserId (NonEmpty SMPServerWithAuth),
{ smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)),
ntf :: [NtfServer],
xftp :: Map UserId (NonEmpty XFTPServerWithAuth),
xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)),
netCfg :: NetworkConfig
}
data ServerCfg p = ServerCfg
{ server :: ProtoServerWithAuth p,
preset :: Bool,
tested :: Maybe Bool,
enabled :: Bool
}
deriving (Show)
enabledServerCfg :: ProtoServerWithAuth p -> ServerCfg p
enabledServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = True}
presetServerCfg :: Bool -> ProtoServerWithAuth p -> ServerCfg p
presetServerCfg enabled server = ServerCfg {server, preset = True, tested = Nothing, enabled}
data UserServers p = UserServers
{ enabledSrvs :: NonEmpty (ProtoServerWithAuth p),
knownSrvs :: NonEmpty (ProtocolServer p)
}
-- This function sets all servers as enabled in case all passed servers are disabled.
mkUserServers :: NonEmpty (ServerCfg p) -> UserServers p
mkUserServers srvs = UserServers {enabledSrvs, knownSrvs}
where
enabledSrvs = L.map (\ServerCfg {server} -> server) $ fromMaybe srvs $ L.nonEmpty $ L.filter (\ServerCfg {enabled} -> enabled) srvs
knownSrvs = L.map (\ServerCfg {server = ProtoServerWithAuth srv _} -> srv) srvs
data AgentConfig = AgentConfig
{ tcpPort :: Maybe ServiceName,
rcvAuthAlg :: C.AuthAlg,
@@ -100,6 +137,8 @@ data AgentConfig = AgentConfig
persistErrorInterval :: NominalDiffTime,
initialCleanupDelay :: Int64,
cleanupInterval :: Int64,
initialLogStatsDelay :: Int64,
logStatsInterval :: Int64,
cleanupStepInterval :: Int,
maxWorkerRestartsPerMin :: Int,
storedMsgDataTTL :: NominalDiffTime,
@@ -170,6 +209,8 @@ defaultAgentConfig =
persistErrorInterval = 3, -- seconds
initialCleanupDelay = 30 * 1000000, -- 30 seconds
cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
initialLogStatsDelay = 10 * 1000000, -- 10 seconds
logStatsInterval = 10 * 1000000, -- 10 seconds
cleanupStepInterval = 200000, -- 200ms
maxWorkerRestartsPerMin = 5,
storedMsgDataTTL = 21 * nominalDay,
@@ -290,3 +331,12 @@ updateRestartCount :: SystemTime -> RestartCount -> RestartCount
updateRestartCount t (RestartCount minute count) = do
let min' = systemSeconds t `div` 60
in RestartCount min' $ if minute == min' then count + 1 else 1
$(pure [])
instance ProtocolTypeI p => ToJSON (ServerCfg p) where
toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg)
toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg)
instance ProtocolTypeI p => FromJSON (ServerCfg p) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerCfg)
+49 -24
View File
@@ -41,6 +41,8 @@ module Simplex.Messaging.Agent.Protocol
ratchetSyncSMPAgentVersion,
deliveryRcptsSMPAgentVersion,
pqdrSMPAgentVersion,
sndAuthKeySMPAgentVersion,
ratchetOnConfSMPAgentVersion,
currentSMPAgentVersion,
supportedSMPAgentVRange,
e2eEncConnInfoLength,
@@ -48,6 +50,7 @@ module Simplex.Messaging.Agent.Protocol
-- * SMP agent protocol types
ConnInfo,
SndQueueSecured,
ACommand (..),
AEvent (..),
AEvt (..),
@@ -208,6 +211,7 @@ import Simplex.Messaging.Protocol
legacyStrEncodeServer,
noAuthSrv,
sameSrvAddr,
sndAuthKeySMPClientVersion,
srvHostnamesSMPClientVersion,
pattern ProtoServerWithAuth,
pattern SMPServer,
@@ -227,6 +231,7 @@ import UnliftIO.Exception (Exception)
-- 3 - support ratchet renegotiation (6/30/2023)
-- 4 - delivery receipts (7/13/2023)
-- 5 - post-quantum double ratchet (3/14/2024)
-- 6 - secure reply queues with provided keys (6/14/2024)
data SMPAgentVersion
@@ -251,11 +256,20 @@ deliveryRcptsSMPAgentVersion = VersionSMPA 4
pqdrSMPAgentVersion :: VersionSMPA
pqdrSMPAgentVersion = VersionSMPA 5
sndAuthKeySMPAgentVersion :: VersionSMPA
sndAuthKeySMPAgentVersion = VersionSMPA 6
ratchetOnConfSMPAgentVersion :: VersionSMPA
ratchetOnConfSMPAgentVersion = VersionSMPA 7
minSupportedSMPAgentVersion :: VersionSMPA
minSupportedSMPAgentVersion = duplexHandshakeSMPAgentVersion
currentSMPAgentVersion :: VersionSMPA
currentSMPAgentVersion = VersionSMPA 5
currentSMPAgentVersion = VersionSMPA 7
supportedSMPAgentVRange :: VersionRangeSMPA
supportedSMPAgentVRange = mkVersionRange duplexHandshakeSMPAgentVersion currentSMPAgentVersion
supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPAgentVersion
-- it is shorter to allow all handshake headers,
-- including E2E (double-ratchet) parameters and
@@ -318,6 +332,8 @@ deriving instance Show AEvt
type ConnInfo = ByteString
type SndQueueSecured = Bool
-- | Parameterized type for SMP agent events
data AEvent (e :: AEntity) where
INV :: AConnectionRequestUri -> AEvent AEConn
@@ -332,7 +348,6 @@ data AEvent (e :: AEntity) where
UP :: SMPServer -> [ConnId] -> AEvent AENone
SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent AEConn
RSYNC :: RatchetSyncState -> Maybe AgentCryptoError -> ConnectionStats -> AEvent AEConn
MID :: AgentMsgId -> PQEncryption -> AEvent AEConn
SENT :: AgentMsgId -> Maybe SMPServer -> AEvent AEConn
MWARN :: AgentMsgId -> AgentErrorType -> AEvent AEConn
MERR :: AgentMsgId -> AgentErrorType -> AEvent AEConn
@@ -346,6 +361,7 @@ data AEvent (e :: AEntity) where
DEL_USER :: Int64 -> AEvent AENone
STAT :: ConnectionStats -> AEvent AEConn
OK :: AEvent AEConn
JOINED :: SndQueueSecured -> AEvent AEConn
ERR :: AgentErrorType -> AEvent AEConn
SUSPENDED :: AEvent AENone
RFPROG :: Int64 -> Int64 -> AEvent AERcvFile
@@ -401,7 +417,6 @@ data AEventTag (e :: AEntity) where
UP_ :: AEventTag AENone
SWITCH_ :: AEventTag AEConn
RSYNC_ :: AEventTag AEConn
MID_ :: AEventTag AEConn
SENT_ :: AEventTag AEConn
MWARN_ :: AEventTag AEConn
MERR_ :: AEventTag AEConn
@@ -415,6 +430,7 @@ data AEventTag (e :: AEntity) where
DEL_USER_ :: AEventTag AENone
STAT_ :: AEventTag AEConn
OK_ :: AEventTag AEConn
JOINED_ :: AEventTag AEConn
ERR_ :: AEventTag AEConn
SUSPENDED_ :: AEventTag AENone
-- XFTP commands and responses
@@ -454,7 +470,6 @@ aEventTag = \case
UP {} -> UP_
SWITCH {} -> SWITCH_
RSYNC {} -> RSYNC_
MID {} -> MID_
SENT {} -> SENT_
MWARN {} -> MWARN_
MERR {} -> MERR_
@@ -468,6 +483,7 @@ aEventTag = \case
DEL_USER _ -> DEL_USER_
STAT _ -> STAT_
OK -> OK_
JOINED _ -> JOINED_
ERR _ -> ERR_
SUSPENDED -> SUSPENDED_
RFPROG {} -> RFPROG_
@@ -688,7 +704,7 @@ data MsgMeta = MsgMeta
data SMPConfirmation = SMPConfirmation
{ -- | sender's public key to use for authentication of sender's commands at the recepient's server
senderKey :: SndPublicAuthKey,
senderKey :: Maybe SndPublicAuthKey,
-- | sender's DH public key for simple per-queue e2e encryption
e2ePubKey :: C.PublicKeyX25519,
-- | sender's information to be associated with the connection, e.g. sender's profile information
@@ -778,12 +794,12 @@ instance Encoding AgentMessage where
'M' -> AgentMessage <$> smpP <*> smpP
_ -> fail "bad AgentMessage"
-- internal type for storing message type in the database
data AgentMessageType
= AM_CONN_INFO
| AM_CONN_INFO_REPLY
| AM_RATCHET_INFO
| AM_HELLO_
| AM_REPLY_
| AM_A_MSG_
| AM_A_RCVD_
| AM_QCONT_
@@ -800,7 +816,6 @@ instance Encoding AgentMessageType where
AM_CONN_INFO_REPLY -> "D"
AM_RATCHET_INFO -> "S"
AM_HELLO_ -> "H"
AM_REPLY_ -> "R"
AM_A_MSG_ -> "M"
AM_A_RCVD_ -> "V"
AM_QCONT_ -> "QC"
@@ -815,7 +830,6 @@ instance Encoding AgentMessageType where
'D' -> pure AM_CONN_INFO_REPLY
'S' -> pure AM_RATCHET_INFO
'H' -> pure AM_HELLO_
'R' -> pure AM_REPLY_
'M' -> pure AM_A_MSG_
'V' -> pure AM_A_RCVD_
'Q' ->
@@ -1007,7 +1021,8 @@ instance ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where
where
queryStr =
strEncode . QSP QEscape $
[("v", strEncode crAgentVRange), ("smp", strEncode crSmpQueues)]
-- semicolon is used to separate SMP queues because comma is used to separate server address hostnames
[("v", strEncode crAgentVRange), ("smp", B.intercalate ";" $ map strEncode $ L.toList crSmpQueues)]
<> maybe [] (\e2e -> [("e2e", strEncode e2e)]) e2eParams
<> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData
strP = connReqUriP' (Just SSSimplex)
@@ -1029,7 +1044,7 @@ connReqUriP overrideScheme = do
crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?"
query <- strP
aVRange <- queryParam "v" query
crSmpQueues <- queryParam "smp" query
crSmpQueues <- queryParamParser queuesP "smp" query
let crClientData = safeDecodeUtf8 <$> queryParamStr "data" query
crData = ConnReqUriData {crScheme, crAgentVRange = aVRange, crSmpQueues, crClientData}
case crMode of
@@ -1041,8 +1056,10 @@ connReqUriP overrideScheme = do
CMContact -> pure . ACR SCMContact $ CRContactUri crData {crAgentVRange = adjustAgentVRange aVRange}
where
crModeP = "invitation" $> CMInvitation <|> "contact" $> CMContact
-- semicolon is used to separate SMP queues because comma is used to separate server address hostnames
queuesP = L.fromList <$> (strDecode <$?> A.takeTill (== ';')) `A.sepBy1'` A.char ';'
adjustAgentVRange vr =
let v = max duplexHandshakeSMPAgentVersion $ minVersion vr
let v = max minSupportedSMPAgentVersion $ minVersion vr
in fromMaybe vr $ safeVersionRange v (max v $ maxVersion vr)
instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where
@@ -1120,14 +1137,16 @@ data SMPQueueInfo = SMPQueueInfo {clientVersion :: VersionSMPC, queueAddress ::
deriving (Eq, Show)
instance Encoding SMPQueueInfo where
smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey})
smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure})
| clientVersion >= sndAuthKeySMPClientVersion && sndSecure = smpEncode (clientVersion, smpServer, senderId, dhPublicKey, sndSecure)
| clientVersion > initialSMPClientVersion = smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
| otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey)
smpP = do
clientVersion <- smpP
smpServer <- if clientVersion > initialSMPClientVersion then smpP else updateSMPServerHosts <$> legacyServerP
(senderId, dhPublicKey) <- smpP
pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey}
sndSecure <- fromMaybe False <$> optional smpP
pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}
-- This instance seems contrived and there was a temptation to split a common part of both types.
-- But this is created to allow backward and forward compatibility where SMPQueueUri
@@ -1153,7 +1172,8 @@ data SMPQueueUri = SMPQueueUri {clientVRange :: VersionRangeSMPC, queueAddress :
data SMPQueueAddress = SMPQueueAddress
{ smpServer :: SMPServer,
senderId :: SMP.SenderId,
dhPublicKey :: C.PublicKeyX25519
dhPublicKey :: C.PublicKeyX25519,
sndSecure :: Bool
}
deriving (Eq, Show)
@@ -1180,37 +1200,42 @@ sameQAddress (srv, qId) (srv', qId') = sameSrvAddr srv srv' && qId == qId'
{-# INLINE sameQAddress #-}
instance StrEncoding SMPQueueUri where
strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey})
strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey, sndSecure})
| minVersion vr >= srvHostnamesSMPClientVersion = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams
| otherwise = legacyStrEncodeServer srv <> "/" <> strEncode qId <> "#/?" <> query (queryParams <> srvParam)
where
query = strEncode . QSP QEscape
queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)]
queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] <> [("k", "s") | sndSecure]
srvParam = [("srv", strEncode $ TransportHosts_ hs) | not (null hs)]
hs = L.tail $ host srv
strP = do
srv@ProtocolServer {host = h :| host} <- strP <* A.char '/'
senderId <- strP <* optional (A.char '/') <* A.char '#'
(vr, hs, dhPublicKey) <- unversioned <|> versioned
(vr, hs, dhPublicKey, sndSecure) <- versioned <|> unversioned
let srv' = srv {host = h :| host <> hs}
smpServer = if maxVersion vr < srvHostnamesSMPClientVersion then updateSMPServerHosts srv' else srv'
pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey}
pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}
where
unversioned = (versionToRange initialSMPClientVersion,[],) <$> strP <* A.endOfInput
unversioned = (versionToRange initialSMPClientVersion,[],,False) <$> strP <* A.endOfInput
versioned = do
dhKey_ <- optional strP
query <- optional (A.char '/') *> A.char '?' *> strP
vr <- queryParam "v" query
dhKey <- maybe (queryParam "dh" query) pure dhKey_
hs_ <- queryParam_ "srv" query
pure (vr, maybe [] thList_ hs_, dhKey)
let sndSecure = queryParamStr "k" query == Just "s"
pure (vr, maybe [] thList_ hs_, dhKey, sndSecure)
instance Encoding SMPQueueUri where
smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey}) =
smpEncode (clientVRange, smpServer, senderId, dhPublicKey)
smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure})
| maxVersion clientVRange >= sndAuthKeySMPClientVersion && sndSecure =
smpEncode (clientVRange, smpServer, senderId, dhPublicKey, sndSecure)
| otherwise =
smpEncode (clientVRange, smpServer, senderId, dhPublicKey)
smpP = do
(clientVRange, smpServer, senderId, dhPublicKey) <- smpP
pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey}
sndSecure <- fromMaybe False <$> optional smpP
pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}
data ConnectionRequestUri (m :: ConnectionMode) where
CRInvitationUri :: ConnReqUriData -> RcvE2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation
+5 -2
View File
@@ -24,9 +24,12 @@ instance StrEncoding QueryStringParams where
strP = QSP QEscape . Q.parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')
queryParam :: StrEncoding a => ByteString -> QueryStringParams -> Parser a
queryParam name q =
queryParam = queryParamParser strP
queryParamParser :: Parser a -> ByteString -> QueryStringParams -> Parser a
queryParamParser p name q =
case queryParamStr name q of
Just p -> either fail pure $ parseAll strP p
Just s -> either fail pure $ parseAll p s
_ -> fail $ "no qs param " <> B.unpack name
queryParam_ :: StrEncoding a => ByteString -> QueryStringParams -> Parser (Maybe a)
+511
View File
@@ -0,0 +1,511 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
module Simplex.Messaging.Agent.Stats where
import qualified Data.Aeson.TH as J
import Data.Int (Int64)
import Data.Map (Map)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import Simplex.Messaging.Agent.Protocol (UserId)
import Simplex.Messaging.Parsers (defaultJSON, fromTextField_)
import Simplex.Messaging.Protocol (SMPServer, XFTPServer)
import Simplex.Messaging.Util (decodeJSON, encodeJSON)
import UnliftIO.STM
data AgentSMPServerStats = AgentSMPServerStats
{ sentDirect :: TVar Int, -- successfully sent messages
sentViaProxy :: TVar Int, -- successfully sent messages via proxy
sentProxied :: TVar Int, -- successfully sent messages to other destination server via this as proxy
sentDirectAttempts :: TVar Int, -- direct sending attempts (min 1 for each sent message)
sentViaProxyAttempts :: TVar Int, -- proxy sending attempts
sentProxiedAttempts :: TVar Int, -- attempts sending to other destination server via this as proxy
sentAuthErrs :: TVar Int, -- send AUTH errors
sentQuotaErrs :: TVar Int, -- send QUOTA permanent errors (message expired)
sentExpiredErrs :: TVar Int, -- send expired errors
sentOtherErrs :: TVar Int, -- other send permanent errors (excluding above)
recvMsgs :: TVar Int, -- total messages received
recvDuplicates :: TVar Int, -- duplicate messages received
recvCryptoErrs :: TVar Int, -- message decryption errors
recvErrs :: TVar Int, -- receive errors
ackMsgs :: TVar Int, -- total messages acknowledged
ackAttempts :: TVar Int, -- acknowledgement attempts
ackNoMsgErrs :: TVar Int, -- NO_MSG ack errors
ackOtherErrs :: TVar Int, -- other permanent ack errors (temporary accounted for in attempts)
-- conn stats are accounted for rcv queue server
connCreated :: TVar Int, -- total connections created
connSecured :: TVar Int, -- connections secured
connCompleted :: TVar Int, -- connections completed
connDeleted :: TVar Int, -- total connections deleted
connDelAttempts :: TVar Int, -- total connection deletion attempts
connDelErrs :: TVar Int, -- permanent connection deletion errors (temporary accounted for in attempts)
connSubscribed :: TVar Int, -- total successful subscription
connSubAttempts :: TVar Int, -- subscription attempts
connSubIgnored :: TVar Int, -- subscription results ignored (client switched to different session or it was not pending)
connSubErrs :: TVar Int -- permanent subscription errors (temporary accounted for in attempts)
}
data AgentSMPServerStatsData = AgentSMPServerStatsData
{ _sentDirect :: Int,
_sentViaProxy :: Int,
_sentProxied :: Int,
_sentDirectAttempts :: Int,
_sentViaProxyAttempts :: Int,
_sentProxiedAttempts :: Int,
_sentAuthErrs :: Int,
_sentQuotaErrs :: Int,
_sentExpiredErrs :: Int,
_sentOtherErrs :: Int,
_recvMsgs :: Int,
_recvDuplicates :: Int,
_recvCryptoErrs :: Int,
_recvErrs :: Int,
_ackMsgs :: Int,
_ackAttempts :: Int,
_ackNoMsgErrs :: Int,
_ackOtherErrs :: Int,
_connCreated :: Int,
_connSecured :: Int,
_connCompleted :: Int,
_connDeleted :: Int,
_connDelAttempts :: Int,
_connDelErrs :: Int,
_connSubscribed :: Int,
_connSubAttempts :: Int,
_connSubIgnored :: Int,
_connSubErrs :: Int
}
deriving (Show)
newAgentSMPServerStats :: STM AgentSMPServerStats
newAgentSMPServerStats = do
sentDirect <- newTVar 0
sentViaProxy <- newTVar 0
sentProxied <- newTVar 0
sentDirectAttempts <- newTVar 0
sentViaProxyAttempts <- newTVar 0
sentProxiedAttempts <- newTVar 0
sentAuthErrs <- newTVar 0
sentQuotaErrs <- newTVar 0
sentExpiredErrs <- newTVar 0
sentOtherErrs <- newTVar 0
recvMsgs <- newTVar 0
recvDuplicates <- newTVar 0
recvCryptoErrs <- newTVar 0
recvErrs <- newTVar 0
ackMsgs <- newTVar 0
ackAttempts <- newTVar 0
ackNoMsgErrs <- newTVar 0
ackOtherErrs <- newTVar 0
connCreated <- newTVar 0
connSecured <- newTVar 0
connCompleted <- newTVar 0
connDeleted <- newTVar 0
connDelAttempts <- newTVar 0
connDelErrs <- newTVar 0
connSubscribed <- newTVar 0
connSubAttempts <- newTVar 0
connSubIgnored <- newTVar 0
connSubErrs <- newTVar 0
pure
AgentSMPServerStats
{ sentDirect,
sentViaProxy,
sentProxied,
sentDirectAttempts,
sentViaProxyAttempts,
sentProxiedAttempts,
sentAuthErrs,
sentQuotaErrs,
sentExpiredErrs,
sentOtherErrs,
recvMsgs,
recvDuplicates,
recvCryptoErrs,
recvErrs,
ackMsgs,
ackAttempts,
ackNoMsgErrs,
ackOtherErrs,
connCreated,
connSecured,
connCompleted,
connDeleted,
connDelAttempts,
connDelErrs,
connSubscribed,
connSubAttempts,
connSubIgnored,
connSubErrs
}
newAgentSMPServerStatsData :: AgentSMPServerStatsData
newAgentSMPServerStatsData =
AgentSMPServerStatsData
{ _sentDirect = 0,
_sentViaProxy = 0,
_sentProxied = 0,
_sentDirectAttempts = 0,
_sentViaProxyAttempts = 0,
_sentProxiedAttempts = 0,
_sentAuthErrs = 0,
_sentQuotaErrs = 0,
_sentExpiredErrs = 0,
_sentOtherErrs = 0,
_recvMsgs = 0,
_recvDuplicates = 0,
_recvCryptoErrs = 0,
_recvErrs = 0,
_ackMsgs = 0,
_ackAttempts = 0,
_ackNoMsgErrs = 0,
_ackOtherErrs = 0,
_connCreated = 0,
_connSecured = 0,
_connCompleted = 0,
_connDeleted = 0,
_connDelAttempts = 0,
_connDelErrs = 0,
_connSubscribed = 0,
_connSubAttempts = 0,
_connSubIgnored = 0,
_connSubErrs = 0
}
newAgentSMPServerStats' :: AgentSMPServerStatsData -> STM AgentSMPServerStats
newAgentSMPServerStats' s = do
sentDirect <- newTVar $ _sentDirect s
sentViaProxy <- newTVar $ _sentViaProxy s
sentProxied <- newTVar $ _sentProxied s
sentDirectAttempts <- newTVar $ _sentDirectAttempts s
sentViaProxyAttempts <- newTVar $ _sentViaProxyAttempts s
sentProxiedAttempts <- newTVar $ _sentProxiedAttempts s
sentAuthErrs <- newTVar $ _sentAuthErrs s
sentQuotaErrs <- newTVar $ _sentQuotaErrs s
sentExpiredErrs <- newTVar $ _sentExpiredErrs s
sentOtherErrs <- newTVar $ _sentOtherErrs s
recvMsgs <- newTVar $ _recvMsgs s
recvDuplicates <- newTVar $ _recvDuplicates s
recvCryptoErrs <- newTVar $ _recvCryptoErrs s
recvErrs <- newTVar $ _recvErrs s
ackMsgs <- newTVar $ _ackMsgs s
ackAttempts <- newTVar $ _ackAttempts s
ackNoMsgErrs <- newTVar $ _ackNoMsgErrs s
ackOtherErrs <- newTVar $ _ackOtherErrs s
connCreated <- newTVar $ _connCreated s
connSecured <- newTVar $ _connSecured s
connCompleted <- newTVar $ _connCompleted s
connDeleted <- newTVar $ _connDeleted s
connDelAttempts <- newTVar $ _connDelAttempts s
connDelErrs <- newTVar $ _connDelErrs s
connSubscribed <- newTVar $ _connSubscribed s
connSubAttempts <- newTVar $ _connSubAttempts s
connSubIgnored <- newTVar $ _connSubIgnored s
connSubErrs <- newTVar $ _connSubErrs s
pure
AgentSMPServerStats
{ sentDirect,
sentViaProxy,
sentProxied,
sentDirectAttempts,
sentViaProxyAttempts,
sentProxiedAttempts,
sentAuthErrs,
sentQuotaErrs,
sentExpiredErrs,
sentOtherErrs,
recvMsgs,
recvDuplicates,
recvCryptoErrs,
recvErrs,
ackMsgs,
ackAttempts,
ackNoMsgErrs,
ackOtherErrs,
connCreated,
connSecured,
connCompleted,
connDeleted,
connDelAttempts,
connDelErrs,
connSubscribed,
connSubAttempts,
connSubIgnored,
connSubErrs
}
-- as this is used to periodically update stats in db,
-- this is not STM to decrease contention with stats updates
getAgentSMPServerStats :: AgentSMPServerStats -> IO AgentSMPServerStatsData
getAgentSMPServerStats s = do
_sentDirect <- readTVarIO $ sentDirect s
_sentViaProxy <- readTVarIO $ sentViaProxy s
_sentProxied <- readTVarIO $ sentProxied s
_sentDirectAttempts <- readTVarIO $ sentDirectAttempts s
_sentViaProxyAttempts <- readTVarIO $ sentViaProxyAttempts s
_sentProxiedAttempts <- readTVarIO $ sentProxiedAttempts s
_sentAuthErrs <- readTVarIO $ sentAuthErrs s
_sentQuotaErrs <- readTVarIO $ sentQuotaErrs s
_sentExpiredErrs <- readTVarIO $ sentExpiredErrs s
_sentOtherErrs <- readTVarIO $ sentOtherErrs s
_recvMsgs <- readTVarIO $ recvMsgs s
_recvDuplicates <- readTVarIO $ recvDuplicates s
_recvCryptoErrs <- readTVarIO $ recvCryptoErrs s
_recvErrs <- readTVarIO $ recvErrs s
_ackMsgs <- readTVarIO $ ackMsgs s
_ackAttempts <- readTVarIO $ ackAttempts s
_ackNoMsgErrs <- readTVarIO $ ackNoMsgErrs s
_ackOtherErrs <- readTVarIO $ ackOtherErrs s
_connCreated <- readTVarIO $ connCreated s
_connSecured <- readTVarIO $ connSecured s
_connCompleted <- readTVarIO $ connCompleted s
_connDeleted <- readTVarIO $ connDeleted s
_connDelAttempts <- readTVarIO $ connDelAttempts s
_connDelErrs <- readTVarIO $ connDelErrs s
_connSubscribed <- readTVarIO $ connSubscribed s
_connSubAttempts <- readTVarIO $ connSubAttempts s
_connSubIgnored <- readTVarIO $ connSubIgnored s
_connSubErrs <- readTVarIO $ connSubErrs s
pure
AgentSMPServerStatsData
{ _sentDirect,
_sentViaProxy,
_sentProxied,
_sentDirectAttempts,
_sentViaProxyAttempts,
_sentProxiedAttempts,
_sentAuthErrs,
_sentQuotaErrs,
_sentExpiredErrs,
_sentOtherErrs,
_recvMsgs,
_recvDuplicates,
_recvCryptoErrs,
_recvErrs,
_ackMsgs,
_ackAttempts,
_ackNoMsgErrs,
_ackOtherErrs,
_connCreated,
_connSecured,
_connCompleted,
_connDeleted,
_connDelAttempts,
_connDelErrs,
_connSubscribed,
_connSubAttempts,
_connSubIgnored,
_connSubErrs
}
addSMPStatsData :: AgentSMPServerStatsData -> AgentSMPServerStatsData -> AgentSMPServerStatsData
addSMPStatsData sd1 sd2 =
AgentSMPServerStatsData
{ _sentDirect = _sentDirect sd1 + _sentDirect sd2,
_sentViaProxy = _sentViaProxy sd1 + _sentViaProxy sd2,
_sentProxied = _sentProxied sd1 + _sentProxied sd2,
_sentDirectAttempts = _sentDirectAttempts sd1 + _sentDirectAttempts sd2,
_sentViaProxyAttempts = _sentViaProxyAttempts sd1 + _sentViaProxyAttempts sd2,
_sentProxiedAttempts = _sentProxiedAttempts sd1 + _sentProxiedAttempts sd2,
_sentAuthErrs = _sentAuthErrs sd1 + _sentAuthErrs sd2,
_sentQuotaErrs = _sentQuotaErrs sd1 + _sentQuotaErrs sd2,
_sentExpiredErrs = _sentExpiredErrs sd1 + _sentExpiredErrs sd2,
_sentOtherErrs = _sentOtherErrs sd1 + _sentOtherErrs sd2,
_recvMsgs = _recvMsgs sd1 + _recvMsgs sd2,
_recvDuplicates = _recvDuplicates sd1 + _recvDuplicates sd2,
_recvCryptoErrs = _recvCryptoErrs sd1 + _recvCryptoErrs sd2,
_recvErrs = _recvErrs sd1 + _recvErrs sd2,
_ackMsgs = _ackMsgs sd1 + _ackMsgs sd2,
_ackAttempts = _ackAttempts sd1 + _ackAttempts sd2,
_ackNoMsgErrs = _ackNoMsgErrs sd1 + _ackNoMsgErrs sd2,
_ackOtherErrs = _ackOtherErrs sd1 + _ackOtherErrs sd2,
_connCreated = _connCreated sd1 + _connCreated sd2,
_connSecured = _connSecured sd1 + _connSecured sd2,
_connCompleted = _connCompleted sd1 + _connCompleted sd2,
_connDeleted = _connDeleted sd1 + _connDeleted sd2,
_connDelAttempts = _connDelAttempts sd1 + _connDelAttempts sd2,
_connDelErrs = _connDelErrs sd1 + _connDelErrs sd2,
_connSubscribed = _connSubscribed sd1 + _connSubscribed sd2,
_connSubAttempts = _connSubAttempts sd1 + _connSubAttempts sd2,
_connSubIgnored = _connSubIgnored sd1 + _connSubIgnored sd2,
_connSubErrs = _connSubErrs sd1 + _connSubErrs sd2
}
data AgentXFTPServerStats = AgentXFTPServerStats
{ uploads :: TVar Int, -- total replicas uploaded to server
uploadsSize :: TVar Int64, -- total size of uploaded replicas in KB
uploadAttempts :: TVar Int, -- upload attempts
uploadErrs :: TVar Int, -- upload errors
downloads :: TVar Int, -- total replicas downloaded from server
downloadsSize :: TVar Int64, -- total size of downloaded replicas in KB
downloadAttempts :: TVar Int, -- download attempts
downloadAuthErrs :: TVar Int, -- download AUTH errors
downloadErrs :: TVar Int, -- other download errors (excluding above)
deletions :: TVar Int, -- total replicas deleted from server
deleteAttempts :: TVar Int, -- delete attempts
deleteErrs :: TVar Int -- delete errors
}
data AgentXFTPServerStatsData = AgentXFTPServerStatsData
{ _uploads :: Int,
_uploadsSize :: Int64,
_uploadAttempts :: Int,
_uploadErrs :: Int,
_downloads :: Int,
_downloadsSize :: Int64,
_downloadAttempts :: Int,
_downloadAuthErrs :: Int,
_downloadErrs :: Int,
_deletions :: Int,
_deleteAttempts :: Int,
_deleteErrs :: Int
}
deriving (Show)
newAgentXFTPServerStats :: STM AgentXFTPServerStats
newAgentXFTPServerStats = do
uploads <- newTVar 0
uploadsSize <- newTVar 0
uploadAttempts <- newTVar 0
uploadErrs <- newTVar 0
downloads <- newTVar 0
downloadsSize <- newTVar 0
downloadAttempts <- newTVar 0
downloadAuthErrs <- newTVar 0
downloadErrs <- newTVar 0
deletions <- newTVar 0
deleteAttempts <- newTVar 0
deleteErrs <- newTVar 0
pure
AgentXFTPServerStats
{ uploads,
uploadsSize,
uploadAttempts,
uploadErrs,
downloads,
downloadsSize,
downloadAttempts,
downloadAuthErrs,
downloadErrs,
deletions,
deleteAttempts,
deleteErrs
}
newAgentXFTPServerStatsData :: AgentXFTPServerStatsData
newAgentXFTPServerStatsData =
AgentXFTPServerStatsData
{ _uploads = 0,
_uploadsSize = 0,
_uploadAttempts = 0,
_uploadErrs = 0,
_downloads = 0,
_downloadsSize = 0,
_downloadAttempts = 0,
_downloadAuthErrs = 0,
_downloadErrs = 0,
_deletions = 0,
_deleteAttempts = 0,
_deleteErrs = 0
}
newAgentXFTPServerStats' :: AgentXFTPServerStatsData -> STM AgentXFTPServerStats
newAgentXFTPServerStats' s = do
uploads <- newTVar $ _uploads s
uploadsSize <- newTVar $ _uploadsSize s
uploadAttempts <- newTVar $ _uploadAttempts s
uploadErrs <- newTVar $ _uploadErrs s
downloads <- newTVar $ _downloads s
downloadsSize <- newTVar $ _downloadsSize s
downloadAttempts <- newTVar $ _downloadAttempts s
downloadAuthErrs <- newTVar $ _downloadAuthErrs s
downloadErrs <- newTVar $ _downloadErrs s
deletions <- newTVar $ _deletions s
deleteAttempts <- newTVar $ _deleteAttempts s
deleteErrs <- newTVar $ _deleteErrs s
pure
AgentXFTPServerStats
{ uploads,
uploadsSize,
uploadAttempts,
uploadErrs,
downloads,
downloadsSize,
downloadAttempts,
downloadAuthErrs,
downloadErrs,
deletions,
deleteAttempts,
deleteErrs
}
-- as this is used to periodically update stats in db,
-- this is not STM to decrease contention with stats updates
getAgentXFTPServerStats :: AgentXFTPServerStats -> IO AgentXFTPServerStatsData
getAgentXFTPServerStats s = do
_uploads <- readTVarIO $ uploads s
_uploadsSize <- readTVarIO $ uploadsSize s
_uploadAttempts <- readTVarIO $ uploadAttempts s
_uploadErrs <- readTVarIO $ uploadErrs s
_downloads <- readTVarIO $ downloads s
_downloadsSize <- readTVarIO $ downloadsSize s
_downloadAttempts <- readTVarIO $ downloadAttempts s
_downloadAuthErrs <- readTVarIO $ downloadAuthErrs s
_downloadErrs <- readTVarIO $ downloadErrs s
_deletions <- readTVarIO $ deletions s
_deleteAttempts <- readTVarIO $ deleteAttempts s
_deleteErrs <- readTVarIO $ deleteErrs s
pure
AgentXFTPServerStatsData
{ _uploads,
_uploadsSize,
_uploadAttempts,
_uploadErrs,
_downloads,
_downloadsSize,
_downloadAttempts,
_downloadAuthErrs,
_downloadErrs,
_deletions,
_deleteAttempts,
_deleteErrs
}
addXFTPStatsData :: AgentXFTPServerStatsData -> AgentXFTPServerStatsData -> AgentXFTPServerStatsData
addXFTPStatsData sd1 sd2 =
AgentXFTPServerStatsData
{ _uploads = _uploads sd1 + _uploads sd2,
_uploadsSize = _uploadsSize sd1 + _uploadsSize sd2,
_uploadAttempts = _uploadAttempts sd1 + _uploadAttempts sd2,
_uploadErrs = _uploadErrs sd1 + _uploadErrs sd2,
_downloads = _downloads sd1 + _downloads sd2,
_downloadsSize = _downloadsSize sd1 + _downloadsSize sd2,
_downloadAttempts = _downloadAttempts sd1 + _downloadAttempts sd2,
_downloadAuthErrs = _downloadAuthErrs sd1 + _downloadAuthErrs sd2,
_downloadErrs = _downloadErrs sd1 + _downloadErrs sd2,
_deletions = _deletions sd1 + _deletions sd2,
_deleteAttempts = _deleteAttempts sd1 + _deleteAttempts sd2,
_deleteErrs = _deleteErrs sd1 + _deleteErrs sd2
}
-- Type for gathering both smp and xftp stats across all users and servers,
-- to then be persisted to db as a single json.
data AgentPersistedServerStats = AgentPersistedServerStats
{ smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData,
xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData
}
deriving (Show)
$(J.deriveJSON defaultJSON ''AgentSMPServerStatsData)
$(J.deriveJSON defaultJSON ''AgentXFTPServerStatsData)
$(J.deriveJSON defaultJSON ''AgentPersistedServerStats)
instance ToField AgentPersistedServerStats where
toField = toField . encodeJSON
instance FromField AgentPersistedServerStats where
fromField = fromTextField_ decodeJSON
+15 -2
View File
@@ -44,6 +44,7 @@ import Simplex.Messaging.Protocol
RcvPrivateAuthKey,
SndPrivateAuthKey,
SndPublicAuthKey,
SenderCanSecure,
VersionSMPC,
)
import qualified Simplex.Messaging.Protocol as SMP
@@ -83,6 +84,8 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
e2eDhSecret :: Maybe C.DhSecretX25519,
-- | sender queue ID
sndId :: SMP.SenderId,
-- | sender can secure the queue
sndSecure :: SenderCanSecure,
-- | queue status
status :: QueueStatus,
-- | database queue ID (within connection)
@@ -138,9 +141,11 @@ data StoredSndQueue (q :: QueueStored) = SndQueue
server :: SMPServer,
-- | sender queue ID
sndId :: SMP.SenderId,
-- | sender can secure the queue
sndSecure :: SenderCanSecure,
-- | key pair used by the sender to authorize transmissions
-- TODO combine keys to key pair so that types match
sndPublicKey :: Maybe SndPublicAuthKey,
sndPublicKey :: SndPublicAuthKey,
sndPrivateKey :: SndPrivateAuthKey,
-- | DH public key used to negotiate per-queue e2e encryption
e2ePubKey :: Maybe C.PublicKeyX25519,
@@ -170,6 +175,12 @@ instance SMPQueue RcvQueue where
queueId RcvQueue {rcvId} = rcvId
{-# INLINE queueId #-}
instance SMPQueue NewRcvQueue where
qServer RcvQueue {server} = server
{-# INLINE qServer #-}
queueId RcvQueue {rcvId} = rcvId
{-# INLINE queueId #-}
instance SMPQueue SndQueue where
qServer SndQueue {server} = server
{-# INLINE qServer #-}
@@ -372,7 +383,7 @@ instance StrEncoding AgentCommandTag where
data InternalCommand
= ICAck SMP.RecipientId MsgId
| ICAckDel SMP.RecipientId MsgId InternalId
| ICAllowSecure SMP.RecipientId SMP.SndPublicAuthKey
| ICAllowSecure SMP.RecipientId (Maybe SMP.SndPublicAuthKey)
| ICDuplexSecure SMP.RecipientId SMP.SndPublicAuthKey
| ICDeleteConn
| ICDeleteRcvQueue SMP.RecipientId
@@ -635,4 +646,6 @@ data StoreError
SEDeletedSndChunkReplicaNotFound
| -- | Error when reading work item that suspends worker - do not use!
SEWorkItemError ByteString
| -- | Servers stats not found.
SEServersStatsNotFound
deriving (Eq, Show, Exception)
+55 -27
View File
@@ -102,8 +102,10 @@ module Simplex.Messaging.Agent.Store.SQLite
-- Messages
updateRcvIds,
createRcvMsg,
updateRcvMsgHash,
updateSndIds,
createSndMsg,
updateSndMsgHash,
createSndMsgDelivery,
getSndMsgViaRcpt,
updateSndMsgRcpt,
@@ -210,6 +212,10 @@ module Simplex.Messaging.Agent.Store.SQLite
deleteDeletedSndChunkReplica,
getPendingDelFilesServers,
deleteDeletedSndChunkReplicasExpired,
-- Stats
updateServersStats,
getServersStats,
resetServersStats,
-- * utilities
withConnection,
@@ -263,6 +269,7 @@ import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
import Simplex.FileTransfer.Types
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval (RI2State (..))
import Simplex.Messaging.Agent.Stats
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite.Common
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
@@ -806,7 +813,7 @@ setRcvQueueNtfCreds db connId clientNtfCreds =
Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
Nothing -> (Nothing, Nothing, Nothing, Nothing)
type SMPConfirmationRow = (SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC)
type SMPConfirmationRow = (Maybe SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC)
smpConfirmation :: SMPConfirmationRow -> SMPConfirmation
smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) =
@@ -953,10 +960,10 @@ updateRcvIds db connId = do
pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash)
createRcvMsg :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO ()
createRcvMsg db connId rq rcvMsgData = do
createRcvMsg db connId rq rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalRcvId, internalHash} = do
insertRcvMsgBase_ db connId rcvMsgData
insertRcvMsgDetails_ db connId rq rcvMsgData
updateHashRcv_ db connId rcvMsgData
updateRcvMsgHash db connId sndMsgId internalRcvId internalHash
updateSndIds :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash)
updateSndIds db connId = do
@@ -967,10 +974,10 @@ updateSndIds db connId = do
pure (internalId, internalSndId, prevSndHash)
createSndMsg :: DB.Connection -> ConnId -> SndMsgData -> IO ()
createSndMsg db connId sndMsgData = do
createSndMsg db connId sndMsgData@SndMsgData {internalSndId, internalHash} = do
insertSndMsgBase_ db connId sndMsgData
insertSndMsgDetails_ db connId sndMsgData
updateHashSnd_ db connId sndMsgData
updateSndMsgHash db connId internalSndId internalHash
createSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO ()
createSndMsgDelivery db connId SndQueue {dbQueueId} msgId =
@@ -1861,28 +1868,34 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do
insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> Maybe C.KeyHash -> IO RcvQueue
insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
qId <- newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId')
-- to preserve ID if the queue already exists.
-- possibly, it can be done in one query.
currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId)
qId <- maybe (newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId')) pure currQId_
DB.execute
db
[sql|
INSERT INTO rcv_queues
(host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
(host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|]
((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, sndSecure, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId}
-- * createSndConn helpers
insertSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> Maybe C.KeyHash -> IO SndQueue
insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do
qId <- newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId')
-- to preserve ID if the queue already exists.
-- possibly, it can be done in one query.
currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId)
qId <- maybe (newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId')) pure currQId_
DB.execute
db
[sql|
INSERT OR REPLACE INTO snd_queues
(host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);
(host, port, snd_id, snd_secure, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|]
((host server, port server, sndId, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
((host server, port server, sndId, sndSecure, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId}
newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored
@@ -2004,7 +2017,7 @@ rcvQueueQuery :: Query
rcvQueueQuery =
[sql|
SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status,
q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_secure, q.status,
q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors,
q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
FROM rcv_queues q
@@ -2013,17 +2026,17 @@ rcvQueueQuery =
|]
toRcvQueue ::
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus)
:. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int)
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, SenderCanSecure)
:. (QueueStatus, DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int)
:. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) ->
RcvQueue
toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure) :. (status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
let server = SMPServer host port keyHash
smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_
clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
_ -> Nothing
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
getRcvQueueById db connId dbRcvId =
@@ -2044,7 +2057,7 @@ sndQueueQuery :: Query
sndQueueQuery =
[sql|
SELECT
c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id,
c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.snd_secure,
q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status,
q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version
FROM snd_queues q
@@ -2053,17 +2066,18 @@ sndQueueQuery =
|]
toSndQueue ::
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId)
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, SenderCanSecure)
:. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
:. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) ->
SndQueue
toSndQueue
( (userId, keyHash, connId, host, port, sndId)
:. (sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)
( (userId, keyHash, connId, host, port, sndId, sndSecure)
:. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status)
:. (dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion)
) =
let server = SMPServer host port keyHash
in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
sndPublicKey = fromMaybe (C.APublicAuthKey a (C.publicKey pk)) sndPubKey
in SndQueue {userId, connId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion}
getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue)
getSndQueueById db connId dbSndId =
@@ -2142,10 +2156,10 @@ insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, interna
]
DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, encryptedMsgHash)
updateHashRcv_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
updateHashRcv_ dbConn connId RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalHash, internalRcvId} =
updateRcvMsgHash :: DB.Connection -> ConnId -> AgentMsgId -> InternalRcvId -> MsgHash -> IO ()
updateRcvMsgHash db connId sndMsgId internalRcvId internalHash =
DB.executeNamed
dbConn
db
-- last_internal_rcv_msg_id equality check prevents race condition in case next id was reserved
[sql|
UPDATE connections
@@ -2221,10 +2235,10 @@ insertSndMsgDetails_ dbConn connId SndMsgData {..} =
":previous_msg_hash" := prevMsgHash
]
updateHashSnd_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
updateHashSnd_ dbConn connId SndMsgData {..} =
updateSndMsgHash :: DB.Connection -> ConnId -> InternalSndId -> MsgHash -> IO ()
updateSndMsgHash db connId internalSndId internalHash =
DB.executeNamed
dbConn
db
-- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved
[sql|
UPDATE connections
@@ -3017,6 +3031,20 @@ deleteDeletedSndChunkReplicasExpired db ttl = do
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
DB.execute db "DELETE FROM deleted_snd_chunk_replicas WHERE created_at < ?" (Only cutoffTs)
updateServersStats :: DB.Connection -> AgentPersistedServerStats -> IO ()
updateServersStats db stats = do
updatedAt <- getCurrentTime
DB.execute db "UPDATE servers_stats SET servers_stats = ?, updated_at = ? WHERE servers_stats_id = 1" (stats, updatedAt)
getServersStats :: DB.Connection -> IO (Either StoreError (UTCTime, Maybe AgentPersistedServerStats))
getServersStats db =
firstRow id SEServersStatsNotFound $
DB.query_ db "SELECT started_at, servers_stats FROM servers_stats WHERE servers_stats_id = 1"
resetServersStats :: DB.Connection -> UTCTime -> IO ()
resetServersStats db startedAt =
DB.execute db "UPDATE servers_stats SET servers_stats = NULL, started_at = ?, updated_at = ? WHERE servers_stats_id = 1" (startedAt, startedAt)
$(J.deriveJSON defaultJSON ''UpMigration)
$(J.deriveToJSON (sumTypeJSON $ dropPrefix "ME") ''MigrationError)
@@ -72,6 +72,8 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Transport.Client (TransportHost)
@@ -112,7 +114,9 @@ schemaMigrations =
("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect),
("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery),
("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem),
("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays)
("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays),
("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure),
("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats)
]
-- | The list of migrations in ascending order by date
@@ -0,0 +1,36 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20240624_snd_secure :: Query
m20240624_snd_secure =
[sql|
ALTER TABLE rcv_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0;
ALTER TABLE snd_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0;
PRAGMA writable_schema=1;
UPDATE sqlite_master
SET sql = replace(sql, 'sender_key BLOB NOT NULL,', 'sender_key BLOB,')
WHERE name = 'conn_confirmations' AND type = 'table';
PRAGMA writable_schema=0;
|]
down_m20240624_snd_secure :: Query
down_m20240624_snd_secure =
[sql|
ALTER TABLE rcv_queues DROP COLUMN snd_secure;
ALTER TABLE snd_queues DROP COLUMN snd_secure;
PRAGMA writable_schema=1;
UPDATE sqlite_master
SET sql = replace(sql, 'sender_key BLOB,', 'sender_key BLOB NOT NULL,')
WHERE name = 'conn_confirmations' AND type = 'table';
PRAGMA writable_schema=0;
|]
@@ -0,0 +1,29 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
-- servers_stats_id: dummy id, there should always only be one record with servers_stats_id = 1
-- servers_stats: overall accumulated stats, past and session, reset to null on stats reset
-- started_at: starting point of tracking stats, reset on stats reset
m20240702_servers_stats :: Query
m20240702_servers_stats =
[sql|
CREATE TABLE servers_stats(
servers_stats_id INTEGER PRIMARY KEY,
servers_stats TEXT,
started_at TEXT NOT NULL DEFAULT(datetime('now')),
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
INSERT INTO servers_stats (servers_stats_id) VALUES (1);
|]
down_m20240702_servers_stats :: Query
down_m20240702_servers_stats =
[sql|
DROP TABLE servers_stats;
|]
@@ -55,6 +55,7 @@ CREATE TABLE rcv_queues(
server_key_hash BLOB,
switch_status TEXT,
deleted INTEGER NOT NULL DEFAULT 0,
snd_secure INTEGER NOT NULL DEFAULT 0,
PRIMARY KEY(host, port, rcv_id),
FOREIGN KEY(host, port) REFERENCES servers
ON DELETE RESTRICT ON UPDATE CASCADE,
@@ -77,6 +78,7 @@ CREATE TABLE snd_queues(
replace_snd_queue_id INTEGER NULL,
server_key_hash BLOB,
switch_status TEXT,
snd_secure INTEGER NOT NULL DEFAULT 0,
PRIMARY KEY(host, port, snd_id),
FOREIGN KEY(host, port) REFERENCES servers
ON DELETE RESTRICT ON UPDATE CASCADE
@@ -132,7 +134,7 @@ CREATE TABLE conn_confirmations(
confirmation_id BLOB NOT NULL PRIMARY KEY,
conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
e2e_snd_pub_key BLOB NOT NULL,
sender_key BLOB NOT NULL,
sender_key BLOB,
ratchet_state BLOB NOT NULL,
sender_conn_info BLOB NOT NULL,
accepted INTEGER NOT NULL,
@@ -394,6 +396,13 @@ CREATE TABLE processed_ratchet_key_hashes(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE servers_stats(
servers_stats_id INTEGER PRIMARY KEY,
servers_stats TEXT,
started_at TEXT NOT NULL DEFAULT(datetime('now')),
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
@@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StrictData #-}
module Simplex.Messaging.Agent.TRcvQueues
( TRcvQueues (getRcvQueues, getConnections),
@@ -16,6 +17,7 @@ module Simplex.Messaging.Agent.TRcvQueues
where
import Control.Concurrent.STM
import Control.DeepSeq (NFData (..))
import Data.Foldable (foldl')
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
@@ -33,6 +35,8 @@ data TRcvQueues = TRcvQueues
getConnections :: TMap ConnId (NonEmpty (UserId, SMPServer, RecipientId))
}
instance NFData TRcvQueues where rnf TRcvQueues {} = ()
empty :: STM TRcvQueues
empty = TRcvQueues <$> TM.empty <*> TM.empty
+54 -27
View File
@@ -47,6 +47,8 @@ module Simplex.Messaging.Client
subscribeSMPQueueNotifications,
subscribeSMPQueuesNtfs,
secureSMPQueue,
secureSndSMPQueue,
proxySecureSndSMPQueue,
enableSMPQueueNotifications,
disableSMPQueueNotifications,
enableSMPQueuesNtfs,
@@ -58,7 +60,7 @@ module Simplex.Messaging.Client
deleteSMPQueues,
connectSMPProxiedRelay,
proxySMPMessage,
forwardSMPMessage,
forwardSMPTransmission,
getSMPQueueInfo,
sendProtocolCommand,
@@ -100,6 +102,7 @@ module Simplex.Messaging.Client
where
import Control.Applicative ((<|>))
import Control.Concurrent (ThreadId, forkFinally, killThread, mkWeakThreadId)
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
@@ -127,7 +130,7 @@ import Numeric.Natural
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.TMap (TMap)
@@ -138,13 +141,14 @@ import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tshow, whenM)
import Simplex.Messaging.Version
import System.Mem.Weak (Weak, deRefWeak)
import System.Timeout (timeout)
-- | 'SMPClient' is a handle used to send commands to a specific SMP server.
--
-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
data ProtocolClient v err msg = ProtocolClient
{ action :: Maybe (Async ()),
{ action :: Maybe (Weak ThreadId),
thParams :: THandleParams v 'TClient,
sessionTs :: UTCTime,
client_ :: PClient v err msg
@@ -236,10 +240,20 @@ data SocksMode
= -- | always use SOCKS proxy when enabled
SMAlways
| -- | use SOCKS proxy only for .onion hosts when no public host is available
-- This mode is used in SMP proxy to minimize SOCKS proxy usage.
-- This mode is used in SMP proxy and in notifications server to minimize SOCKS proxy usage.
SMOnion
deriving (Eq, Show)
instance StrEncoding SocksMode where
strEncode = \case
SMAlways -> "always"
SMOnion -> "onion"
strP =
A.takeTill (== ' ') >>= \case
"always" -> pure SMAlways
"onion" -> pure SMOnion
_ -> fail "Invalid Socks mode"
-- | network configuration for the client
data NetworkConfig = NetworkConfig
{ -- | use SOCKS5 proxy
@@ -475,15 +489,14 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
cVar <- newEmptyTMVarIO
let tcConfig = (transportClientConfig networkConfig useHost) {alpn = clientALPN}
username = proxyUsername transportSession
action <-
async $
runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar)
`finally` atomically (tryPutTMVar cVar $ Left PCENetworkError)
tId <-
runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar)
`forkFinally` \_ -> void (atomically . tryPutTMVar cVar $ Left PCENetworkError)
c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
case c_ of
Just (Right c') -> pure $ Right c' {action = Just action}
Just (Right c') -> mkWeakThreadId tId >>= \tId' -> pure $ Right c' {action = Just tId'}
Just (Left e) -> pure $ Left e
Nothing -> cancel action $> Left PCENetworkError
Nothing -> killThread tId $> Left PCENetworkError
useTransport :: (ServiceName, ATransport)
useTransport = case port srv of
@@ -589,7 +602,7 @@ proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (
-- | Disconnects client from the server and terminates client threads.
closeProtocolClient :: ProtocolClient v err msg -> IO ()
closeProtocolClient = mapM_ uninterruptibleCancel . action
closeProtocolClient = mapM_ (deRefWeak >=> mapM_ killThread) . action
{-# INLINE closeProtocolClient #-}
-- | SMP client error type.
@@ -654,9 +667,10 @@ createSMPQueue ::
RcvPublicDhKey ->
Maybe BasicAuth ->
SubscriptionMode ->
Bool ->
ExceptT SMPClientError IO QueueIdsKeys
createSMPQueue c (rKey, rpKey) dhKey auth subMode =
sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode) >>= \case
createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure =
sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode sndSecure) >>= \case
IDS qik -> pure qik
r -> throwE $ unexpectedResponse r
@@ -728,6 +742,15 @@ secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuth
secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
{-# INLINE secureSMPQueue #-}
-- | Secure the SMP queue via sender queue ID.
secureSndSMPQueue :: SMPClient -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey sId
{-# INLINE secureSndSMPQueue #-}
proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxySMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey)
{-# INLINE proxySecureSndSMPQueue #-}
-- | Enable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
@@ -768,6 +791,9 @@ sendSMPMessage c spKey sId flags msg =
OK -> pure ()
r -> throwE $ unexpectedResponse r
proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPMessage c proxiedRelay spKey sId flags msg = proxySMPCommand c proxiedRelay spKey sId (SEND flags msg)
-- | Acknowledge message delivery (server deletes the message).
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
@@ -807,7 +833,7 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t
PKEY sId vr (chain, key) ->
case supportedClientSMPRelayVRange `compatibleVersion` vr of
Nothing -> throwE $ transportErr TEVersion
Just (Compatible v) -> liftEitherWith (const $ transportErr $ TEHandshake IDENTITY) $ ProxiedRelay sId v <$> validateRelay chain key
Just (Compatible v) -> liftEitherWith (const $ transportErr $ TEHandshake IDENTITY) $ ProxiedRelay sId v proxyAuth <$> validateRelay chain key
r -> throwE $ unexpectedResponse r
| otherwise = throwE $ PCETransportError TEVersion
where
@@ -826,16 +852,17 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t
data ProxiedRelay = ProxiedRelay
{ prSessionId :: SessionId,
prVersion :: VersionSMP,
prBasicAuth :: Maybe BasicAuth, -- auth is included here to allow reconnecting via the same proxy after NO_SESSION error
prServerKey :: C.PublicKeyX25519
}
data ProxyClientError
= -- | protocol error response from proxy
ProxyProtocolError ErrorType
ProxyProtocolError {protocolErr :: ErrorType}
| -- | unexpexted response
ProxyUnexpectedResponse String
ProxyUnexpectedResponse {responseStr :: String}
| -- | error between proxy and server
ProxyResponseError ErrorType
ProxyResponseError {responseErr :: ErrorType}
deriving (Eq, Show, Exception)
instance StrEncoding ProxyClientError where
@@ -869,24 +896,24 @@ instance StrEncoding ProxyClientError where
-- 8) PFWD(SEND) -> WTF -> ProxyUnexpectedResponse - client/proxy protocol logic
-- 9) PFWD(SEND) -> ??? -> ProxyResponseError - client/proxy syntax
--
-- We report as proxySMPMessage error (ExceptT error) the errors of two kinds:
-- We report as proxySMPCommand error (ExceptT error) the errors of two kinds:
-- - protocol errors from the destination relay wrapped in PRES - to simplify processing of AUTH and QUOTA errors, in this case proxy is "transparent" for such errors (PCEProtocolError, PCEUnexpectedResponse, PCEResponseError)
-- - other response/transport/connection errors from the client connected to proxy itself
-- Other errors are reported in the function result as `Either ProxiedRelayError ()`, including
-- - protocol errors from the client connected to proxy in ProxyClientError (PCEProtocolError, PCEUnexpectedResponse, PCEResponseError)
-- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError
proxySMPMessage ::
-- This function proxies Sender commands that return OK or ERR
proxySMPCommand ::
SMPClient ->
-- proxy session from PKEY
ProxiedRelay ->
-- message to deliver
Maybe SndPrivateAuthKey ->
SenderId ->
MsgFlags ->
MsgBody ->
Command 'Sender ->
ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPMessage c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v serverKey) spKey sId flags msg = do
proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
-- prepare params
let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams
serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth}
@@ -894,14 +921,14 @@ proxySMPMessage c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
let cmdSecret = C.dh' serverKey cmdPrivKey
nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g
-- encode
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender (SEND flags msg))
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender command)
auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth
b <- case batchTransmissions (batch serverThParams) (blockSize serverThParams) [Right (auth, tToSend)] of
[] -> throwE $ PCETransportError TELargeMsg
TBError e _ : _ -> throwE $ PCETransportError e
TBTransmission s _ : _ -> pure s
TBTransmissions s _ _ : _ -> pure s
et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedMsgLength
et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength
-- proxy interaction errors are wrapped
let tOut = Just $ 2 * tcpTimeout
tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing sessionId (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
@@ -929,8 +956,8 @@ proxySMPMessage c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
-- sends RFWD :: EncFwdTransmission -> Command Sender
-- receives RRES :: EncFwdResponse -> BrokerMsg
-- proxy should send PRES to the client with EncResponse
forwardSMPMessage :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse
forwardSMPMessage c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do
forwardSMPTransmission :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse
forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do
-- prepare params
sessSecret <- case thAuth thParams of
Nothing -> throwE $ PCETransportError TENoServerAuth
@@ -1123,6 +1150,6 @@ $(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback)
$(J.deriveJSON defaultJSON ''NetworkConfig)
$(J.deriveJSON (enumJSON $ dropPrefix "Proxy") ''ProxyClientError)
$(J.deriveJSON (sumTypeJSON $ dropPrefix "Proxy") ''ProxyClientError)
$(J.deriveJSON defaultJSON ''TBQueueInfo)
+96 -100
View File
@@ -1,8 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
@@ -21,17 +20,15 @@ import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (bimap, first)
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (partitionEithers)
import Data.List (partition)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (listToMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text.Encoding
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
import Data.Tuple (swap)
@@ -56,8 +53,8 @@ type SMPClientVar = SessionVar (Either (SMPClientError, Maybe UTCTime) (OwnServe
data SMPClientAgentEvent
= CAConnected SMPServer
| CADisconnected SMPServer (Set SMPSub)
| CAResubscribed SMPServer (NonEmpty SMPSub)
| CASubError SMPServer (NonEmpty (SMPSub, SMPClientError))
| CASubscribed SMPServer SMPSubParty (NonEmpty QueueId)
| CASubError SMPServer SMPSubParty (NonEmpty (QueueId, SMPClientError))
data SMPSubParty = SPRecipient | SPNotifier
deriving (Eq, Ord, Show)
@@ -87,9 +84,9 @@ defaultSMPClientAgentConfig =
maxInterval = 10 * second
},
persistErrorInterval = 30, -- seconds
msgQSize = 256,
agentQSize = 256,
agentSubsBatchSize = 900,
msgQSize = 1024,
agentQSize = 1024,
agentSubsBatchSize = 1360,
ownServerDomains = []
}
where
@@ -171,7 +168,8 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
case r of
Right smp -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
let c = (isOwnServer ca srv, smp)
let !owned = isOwnServer ca srv
!c = (owned, smp)
atomically $ do
putTMVar (sessionVar v) (Right c)
TM.insert (sessionId $ thParams smp) c smpSessions
@@ -192,7 +190,7 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
isOwnServer :: SMPClientAgent -> SMPServer -> OwnServer
isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
let srv = strEncode $ L.head host
in any (\s -> s == srv || (B.cons '.' s) `B.isSuffixOf` srv) (ownServerDomains agentCfg)
in any (\s -> s == srv || B.cons '.' s `B.isSuffixOf` srv) (ownServerDomains agentCfg)
-- | Run an SMP client for SMPClientVar
connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
@@ -212,15 +210,9 @@ connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, random
where
updateSubs sVar = do
ss <- readTVar sVar
addPendingSubs sVar ss
addSubs_ (pendingSrvSubs ca) srv ss
pure ss
addPendingSubs sVar ss = do
let ps = pendingSrvSubs ca
TM.lookup srv ps >>= \case
Just ss' -> TM.union ss ss'
_ -> TM.insert srv sVar ps
serverDown :: Map SMPSub C.APrivateAuthKey -> IO ()
serverDown ss = unless (M.null ss) $ do
notify ca . CADisconnected srv $ M.keysSet ss
@@ -244,11 +236,11 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
runSubWorker =
withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do
pending <- atomically getPending
forM_ pending $ \cs -> whenM (readTVarIO active) $ do
void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv cs)
unless (null pending) $ whenM (readTVarIO active) $ do
void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv pending)
loop
ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
getPending = mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
getPending = maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca)
cleanup :: SessionVar (Async ()) -> STM ()
cleanup v = do
-- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar.
@@ -258,32 +250,22 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
reconnectSMPClient :: SMPClientAgent -> SMPServer -> Map SMPSub C.APrivateAuthKey -> ExceptT SMPClientError IO ()
reconnectSMPClient ca@SMPClientAgent {agentCfg} srv cs =
withSMP ca srv $ \smp -> do
subs' <- filterM (fmap not . atomically . hasSub (srvSubs ca) srv . fst) $ M.assocs cs
let (nSubs, rSubs) = partition (isNotifier . fst . fst) subs'
withSMP ca srv $ \smp -> liftIO $ do
currSubs <- atomically $ maybe (pure M.empty) readTVar =<< TM.lookup srv (srvSubs ca)
let (nSubs, rSubs) = foldr (groupSub currSubs) ([], []) $ M.assocs cs
subscribe_ smp SPNotifier nSubs
subscribe_ smp SPRecipient rSubs
where
isNotifier = \case
SPNotifier -> True
SPRecipient -> False
subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateAuthKey)] -> ExceptT SMPClientError IO ()
subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg)
groupSub :: Map SMPSub C.APrivateAuthKey -> (SMPSub, C.APrivateAuthKey) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)]) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)])
groupSub currSubs (s@(party, qId), k) (nSubs, rSubs)
| M.member s currSubs = (nSubs, rSubs)
| otherwise = case party of
SPNotifier -> (s' : nSubs, rSubs)
SPRecipient -> (nSubs, s' : rSubs)
where
subscribeBatch subs' = do
let subs'' :: (NonEmpty (QueueId, C.APrivateAuthKey)) = L.map (first snd) subs'
rs <- liftIO $ smpSubscribeQueues party ca smp srv subs''
let rs' :: (NonEmpty ((SMPSub, C.APrivateAuthKey), Either SMPClientError ())) =
L.zipWith (first . const) subs' rs
rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateAuthKey)] =
map (\(sub, r) -> bimap (fst sub,) (const sub) r) $ L.toList rs'
(errs, oks) = partitionEithers rs''
(tempErrs, finalErrs) = partition (temporaryClientError . snd) errs
mapM_ (atomically . addSubscription ca srv) oks
mapM_ (notify ca . CAResubscribed srv) $ L.nonEmpty $ map fst oks
mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs
mapM_ (notify ca . CASubError srv) $ L.nonEmpty finalErrs
mapM_ (throwE . snd) $ listToMaybe tempErrs
s' = (qId, k)
subscribe_ :: SMPClient -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> IO ()
subscribe_ smp party = mapM_ (smpSubscribeQueues party ca smp srv) . toChunks (agentSubsBatchSize agentCfg)
notify :: MonadIO m => SMPClientAgent -> SMPClientAgentEvent -> m ()
notify ca evt = atomically $ writeTBQueue (agentQ ca) evt
@@ -297,7 +279,8 @@ getConnectedSMPServerClient SMPClientAgent {smpClients} srv =
$>>= \case
(_, Right r) -> pure $ Just $ Right r
(v, Left (e, ts_)) ->
pure ts_ $>>= \ts -> -- proxy will create a new connection if ts_ is Nothing
pure ts_ $>>= \ts ->
-- proxy will create a new connection if ts_ is Nothing
ifM
((ts <) <$> liftIO getCurrentTime) -- error persistence interval period expired?
(Nothing <$ atomically (removeSessVar v srv smpClients)) -- proxy will create a new connection
@@ -334,86 +317,99 @@ withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPE
liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e
throwE e
subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO ()
subscribeQueue ca srv sub = do
atomically $ addPendingSubscription ca srv sub
withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleErr
where
subscribe_ smp = do
smpSubscribe smp sub
atomically $ addSubscription ca srv sub
handleErr e = do
atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
removePendingSubscription ca srv (fst sub)
throwE e
subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ()))
subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO ()
subscribeQueuesSMP = subscribeQueues_ SPRecipient
subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ()))
subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO ()
subscribeQueuesNtfs = subscribeQueues_ SPNotifier
subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
subscribeQueues_ party ca srv subs = do
atomically $ forM_ subs $ addPendingSubscription ca srv . first (party,)
atomically $ addPendingSubs ca srv party $ L.toList subs
runExceptT (getSMPServerClient' ca srv) >>= \case
Left e -> pure $ L.map ((,Left e) . fst) subs
Right smp -> smpSubscribeQueues party ca smp srv subs
Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that
smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO ()
smpSubscribeQueues party ca smp srv subs = do
rs <- L.zip subs <$> subscribe smp (L.map swap subs)
atomically $ forM rs $ \(sub, r) ->
(fst sub,) <$> case r of
Right () -> do
addSubscription ca srv $ first (party,) sub
pure $ Right ()
Left e -> do
when (e /= PCENetworkError && e /= PCEResponseTimeout) $
removePendingSubscription ca srv (party, fst sub)
pure $ Left e
rs <- subscribe smp $ L.map swap subs
rs' <-
atomically $
ifM
(activeClientSession ca smp srv)
(Just <$> processSubscriptions rs)
(pure Nothing)
case rs' of
Just (tempErrs, finalErrs, oks, _) -> do
notify_ CASubscribed $ map fst oks
notify_ CASubError finalErrs
when tempErrs $ reconnectClient ca srv
Nothing -> reconnectClient ca srv
where
processSubscriptions :: NonEmpty (Either SMPClientError ()) -> STM (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId])
processSubscriptions rs = do
pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca)
let acc@(_, _, oks, notPending) = foldr (groupSub pending) (False, [], [], []) (L.zip subs rs)
unless (null oks) $ addSubscriptions ca srv party oks
unless (null notPending) $ removePendingSubs ca srv party notPending
pure acc
groupSub :: Map SMPSub C.APrivateAuthKey -> ((QueueId, C.APrivateAuthKey), Either SMPClientError ()) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId]) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId])
groupSub pending (s@(qId, _), r) acc@(!tempErrs, finalErrs, oks, notPending) = case r of
Right ()
| M.member (party, qId) pending -> (tempErrs, finalErrs, s : oks, qId : notPending)
| otherwise -> acc
Left e
| temporaryClientError e -> (True, finalErrs, oks, notPending)
| otherwise -> (tempErrs, (qId, e) : finalErrs, oks, qId : notPending)
subscribe = case party of
SPRecipient -> subscribeSMPQueues
SPNotifier -> subscribeSMPQueuesNtfs
notify_ :: (SMPServer -> SMPSubParty -> NonEmpty a -> SMPClientAgentEvent) -> [a] -> IO ()
notify_ evt qs = mapM_ (notify ca . evt srv party) $ L.nonEmpty qs
activeClientSession :: SMPClientAgent -> SMPClient -> SMPServer -> STM Bool
activeClientSession ca smp srv = sameSess <$> tryReadSessVar srv (smpClients ca)
where
sessId = sessionId . thParams
sameSess = \case
Just (Right (_, smp')) -> sessId smp == sessId smp'
_ -> False
showServer :: SMPServer -> ByteString
showServer ProtocolServer {host, port} =
strEncode host <> B.pack (if null port then "" else ':' : port)
smpSubscribe :: SMPClient -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO ()
smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId
addSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM ()
addSubscriptions = addSubsList_ . srvSubs
{-# INLINE addSubscriptions #-}
addPendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM ()
addPendingSubs = addSubsList_ . pendingSrvSubs
{-# INLINE addPendingSubs #-}
addSubsList_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM ()
addSubsList_ subs srv party ss = addSubs_ subs srv ss'
where
subscribe_ = case party of
SPRecipient -> subscribeSMPQueue
SPNotifier -> subscribeSMPQueueNotifications
ss' = M.fromList $ map (first (party,)) ss
addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM ()
addSubscription ca srv sub = do
addSub_ (srvSubs ca) srv sub
removePendingSubscription ca srv $ fst sub
addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM ()
addPendingSubscription = addSub_ . pendingSrvSubs
addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM ()
addSub_ subs srv (s, key) =
addSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> Map SMPSub C.APrivateAuthKey -> STM ()
addSubs_ subs srv ss =
TM.lookup srv subs >>= \case
Just m -> TM.insert s key m
_ -> TM.singleton s key >>= \v -> TM.insert srv v subs
Just m -> TM.union ss m
_ -> newTVar ss >>= \v -> TM.insert srv v subs
removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
removeSubscription = removeSub_ . srvSubs
removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
removePendingSubscription = removeSub_ . pendingSrvSubs
{-# INLINE removeSubscription #-}
removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM ()
removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s)
getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateAuthKey)
getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s
removePendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
removePendingSubs = removeSubs_ . pendingSrvSubs
{-# INLINE removePendingSubs #-}
hasSub :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM Bool
hasSub subs srv s = maybe (pure False) (TM.member s) =<< TM.lookup srv subs
removeSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSubParty -> [QueueId] -> STM ()
removeSubs_ subs srv party qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` ss))
where
ss = S.fromList $ map (party,) qs
+11 -28
View File
@@ -188,33 +188,16 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
runSMPSubscriber :: SMPSubscriber -> M ()
runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} =
forever $ do
subs <- atomically (peekTQueue subscriberSubQ)
subs <- atomically $ readTQueue subscriberSubQ
let subs' = L.map (\(NtfSub sub) -> sub) subs
srv = server $ L.head subs
logSubStatus srv "subscribing" $ length subs
mapM_ (\NtfSubData {smpQueue} -> updateSubStatus smpQueue NSPending) subs'
rs <- liftIO $ subscribeQueues srv subs'
(subs'', oks, errs) <- foldM process ([], 0, []) rs
atomically $ do
void $ readTQueue subscriberSubQ
mapM_ (writeTQueue subscriberSubQ . L.map NtfSub) $ L.nonEmpty subs''
logSubStatus srv "retrying" $ length subs''
logSubStatus srv "subscribed" oks
logSubErrors srv errs
where
process :: ([NtfSubData], Int, [NtfSubStatus]) -> (NtfSubData, Either SMPClientError ()) -> M ([NtfSubData], Int, [NtfSubStatus])
process (subs, oks, errs) (sub@NtfSubData {smpQueue}, r) = case r of
Right _ -> updateSubStatus smpQueue NSActive $> (subs, oks + 1, errs)
Left e -> update <$> handleSubError smpQueue e
where
update = \case
Just err -> (subs, oks, err : errs) -- permanent error, log and don't retry subscription
Nothing -> (sub : subs, oks, errs) -- temporary error, retry subscription
liftIO $ subscribeQueues srv subs'
-- \| Subscribe to queues. The list of results can have a different order.
subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO (NonEmpty (NtfSubData, Either SMPClientError ()))
subscribeQueues srv subs =
L.zipWith (\s r -> (s, snd r)) subs <$> subscribeQueuesNtfs ca srv (L.map sub subs)
subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO ()
subscribeQueues srv subs = subscribeQueuesNtfs ca srv (L.map sub subs)
where
sub NtfSubData {smpQueue = SMPQueueNtf {notifierId}, notifierKey} = (notifierId, notifierKey)
@@ -239,7 +222,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
incNtfStat ntfReceived
Right SMP.END -> updateSubStatus smpQueue NSEnd
Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e
Right _ -> logError $ "SMP server unexpected response"
Right _ -> logError "SMP server unexpected response"
Left e -> logError $ "SMP client error: " <> tshow e
receiveAgent =
@@ -252,11 +235,11 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
forM_ subs $ \(_, ntfId) -> do
let smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSInactive
CAResubscribed srv subs -> do
forM_ subs $ \(_, ntfId) -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive
logSubStatus srv "resubscribed" $ length subs
CASubError srv errs ->
forM errs (\((_, ntfId), err) -> handleSubError (SMPQueueNtf srv ntfId) err)
CASubscribed srv _ subs -> do
forM_ subs $ \ntfId -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive
logSubStatus srv "subscribed" $ length subs
CASubError srv _ errs ->
forM errs (\(ntfId, err) -> handleSubError (SMPQueueNtf srv ntfId) err)
>>= logSubErrors srv . catMaybes . L.toList
logSubStatus srv event n =
@@ -382,7 +365,7 @@ send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO ()
send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
t <- atomically $ readTBQueue sndQ
void . liftIO $ tPut h [Right (Nothing, encodeTransmission params t)]
atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime
-- instance Show a => Show (TVar a) where
-- show x = unsafePerformIO $ show <$> readTVarIO x
@@ -7,6 +7,7 @@
module Simplex.Messaging.Notifications.Server.Main where
import Control.Monad ((<$!>))
import Data.Functor (($>))
import Data.Ini (lookupValue, readIniFile)
import Data.Maybe (fromMaybe)
@@ -14,6 +15,7 @@ import qualified Data.Text as T
import qualified Data.Text.IO as T
import Network.Socket (HostName)
import Options.Applicative
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig)
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Server (runNtfServer)
@@ -87,6 +89,14 @@ ntfServerCLI cfgPath logPath =
<> ("port: " <> T.pack defaultServerPort <> "\n")
<> "log_tls_errors: off\n"
<> "websockets: off\n\n\
\[SUBSCRIBER]\n\
\# Network configuration for notification server client.\n\
\# SOCKS proxy port for subscribing to SMP servers.\n\
\# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\
\# socks_proxy: localhost:9050\n\n\
\# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\
\# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\
\# socks_mode: onion\n\n\
\[INACTIVE_CLIENTS]\n\
\# TTL and interval to check inactive clients\n\
\disconnect: off\n"
@@ -115,7 +125,18 @@ ntfServerCLI cfgPath logPath =
clientQSize = 64,
subQSize = 512,
pushQSize = 1048,
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
smpAgentCfg =
defaultSMPClientAgentConfig
{ smpCfg =
(smpCfg defaultSMPClientAgentConfig)
{ networkConfig =
defaultNetworkConfig
{ socksProxy = either error id <$!> strDecodeIni "SUBSCRIBER" "socks_proxy" ini,
socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini
}
},
persistErrorInterval = 0 -- seconds
},
apnsConfig = defaultAPNSPushClientConfig,
subsBatchSize = 900,
inactiveClientExpiration =
+47 -14
View File
@@ -43,7 +43,7 @@ module Simplex.Messaging.Protocol
( -- * SMP protocol parameters
supportedSMPClientVRange,
maxMessageLength,
paddedProxiedMsgLength,
paddedProxiedTLength,
e2eEncConfirmationLength,
e2eEncMessageLength,
@@ -55,6 +55,7 @@ module Simplex.Messaging.Protocol
ProtocolEncoding (..),
Command (..),
SubscriptionMode (..),
SenderCanSecure,
Party (..),
Cmd (..),
DirectParty,
@@ -133,6 +134,7 @@ module Simplex.Messaging.Protocol
FwdTransmission (..),
MsgFlags (..),
initialSMPClientVersion,
currentSMPClientVersion,
userProtocol,
rcvMessageMeta,
noMsgFlags,
@@ -153,6 +155,7 @@ module Simplex.Messaging.Protocol
legacyServerP,
legacyStrEncodeServer,
srvHostnamesSMPClientVersion,
sndAuthKeySMPClientVersion,
sameSrvAddr,
sameSrvAddr',
noAuthSrv,
@@ -178,6 +181,7 @@ module Simplex.Messaging.Protocol
where
import Control.Applicative (optional, (<|>))
import Control.DeepSeq (NFData (..))
import Control.Exception (Exception)
import Control.Monad
import Control.Monad.Except
@@ -240,8 +244,11 @@ initialSMPClientVersion = VersionSMPC 1
srvHostnamesSMPClientVersion :: VersionSMPC
srvHostnamesSMPClientVersion = VersionSMPC 2
sndAuthKeySMPClientVersion :: VersionSMPC
sndAuthKeySMPClientVersion = VersionSMPC 3
currentSMPClientVersion :: VersionSMPC
currentSMPClientVersion = VersionSMPC 2
currentSMPClientVersion = VersionSMPC 3
supportedSMPClientVRange :: VersionRangeSMPC
supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClientVersion
@@ -252,8 +259,8 @@ maxMessageLength v
| v >= sendingProxySMPVersion = 16064 -- max 16067
| otherwise = 16088 -- 16064 - always use this size to determine allowed ranges
paddedProxiedMsgLength :: Int
paddedProxiedMsgLength = 16242 -- 16241 .. 16243
paddedProxiedTLength :: Int
paddedProxiedTLength = 16242 -- 16241 .. 16243
-- TODO v6.0 change to 16064
type MaxMessageLen = 16088
@@ -377,7 +384,7 @@ data Command (p :: Party) where
-- v6 of SMP servers only support signature algorithm for command authorization.
-- v7 of SMP servers additionally support additional layer of authenticated encryption.
-- RcvPublicAuthKey is defined as C.APublicKey - it can be either signature or DH public keys.
NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> Command Recipient
NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient
SUB :: Command Recipient
KEY :: SndPublicAuthKey -> Command Recipient
NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
@@ -390,6 +397,7 @@ data Command (p :: Party) where
DEL :: Command Recipient
QUE :: Command Recipient
-- SMP sender commands
SKEY :: SndPublicAuthKey -> Command Sender
-- SEND v1 has to be supported for encoding/decoding
-- SEND :: MsgBody -> Command Sender
SEND :: MsgFlags -> MsgBody -> Command Sender
@@ -432,6 +440,8 @@ instance Encoding SubscriptionMode where
'C' -> pure SMOnlyCreate
_ -> fail "bad SubscriptionMode"
type SenderCanSecure = Bool
newtype EncTransmission = EncTransmission ByteString
deriving (Show)
@@ -664,6 +674,7 @@ data CommandTag (p :: Party) where
OFF_ :: CommandTag Recipient
DEL_ :: CommandTag Recipient
QUE_ :: CommandTag Recipient
SKEY_ :: CommandTag Sender
SEND_ :: CommandTag Sender
PING_ :: CommandTag Sender
PRXY_ :: CommandTag ProxiedClient
@@ -712,6 +723,7 @@ instance PartyI p => Encoding (CommandTag p) where
OFF_ -> "OFF"
DEL_ -> "DEL"
QUE_ -> "QUE"
SKEY_ -> "SKEY"
SEND_ -> "SEND"
PING_ -> "PING"
PRXY_ -> "PRXY"
@@ -732,6 +744,7 @@ instance ProtocolMsgTag CmdTag where
"OFF" -> Just $ CT SRecipient OFF_
"DEL" -> Just $ CT SRecipient DEL_
"QUE" -> Just $ CT SRecipient QUE_
"SKEY" -> Just $ CT SSender SKEY_
"SEND" -> Just $ CT SSender SEND_
"PING" -> Just $ CT SSender PING_
"PRXY" -> Just $ CT SProxiedClient PRXY_
@@ -886,6 +899,8 @@ deriving instance Ord (SProtocolType p)
deriving instance Show (SProtocolType p)
instance NFData (SProtocolType p) where rnf spt = spt `seq` ()
data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)
instance Eq AProtocolType where
@@ -970,6 +985,8 @@ data ProtocolServer p = ProtocolServer
data AProtocolServer = forall p. ProtocolTypeI p => AProtocolServer (SProtocolType p) (ProtocolServer p)
instance NFData (ProtocolServer p) where rnf ProtocolServer {} = ()
instance ProtocolTypeI p => IsString (ProtocolServer p) where
fromString = parseString strDecode
@@ -1106,7 +1123,8 @@ instance FromJSON CorrId where
data QueueIdsKeys = QIK
{ rcvId :: RecipientId,
sndId :: SenderId,
rcvPublicDhKey :: RcvPublicDhKey
rcvPublicDhKey :: RcvPublicDhKey,
sndSecure :: SenderCanSecure
}
deriving (Eq, Show)
@@ -1277,7 +1295,8 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg -
instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
type Tag (Command p) = CommandTag p
encodeProtocol v = \case
NEW rKey dhKey auth_ subMode
NEW rKey dhKey auth_ subMode sndSecure
| v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, sndSecure)
| v >= subModeSMPVersion -> new <> auth <> e subMode
| v == basicAuthSMPVersion -> new <> auth
| otherwise -> new
@@ -1293,6 +1312,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
OFF -> e OFF_
DEL -> e DEL_
QUE -> e QUE_
SKEY k -> e (SKEY_, ' ', k)
SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg)
PING -> e PING_
NSUB -> e NSUB_
@@ -1318,6 +1338,9 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
SEND {}
| B.null entId -> Left $ CMD NO_ENTITY
| otherwise -> Right cmd
SKEY _
| isNothing auth || B.null entId -> Left $ CMD NO_AUTH
| otherwise -> Right cmd
PING -> noAuthCmd
PRXY {} -> noAuthCmd
PFWD {}
@@ -1344,9 +1367,10 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
CT SRecipient tag ->
Cmd SRecipient <$> case tag of
NEW_
| v >= subModeSMPVersion -> new <*> auth <*> smpP
| v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe
| otherwise -> new <*> pure Nothing <*> pure SMSubscribe
| v >= sndAuthKeySMPVersion -> new <*> smpP <*> smpP <*> smpP
| v >= subModeSMPVersion -> new <*> auth <*> smpP <*> pure False
| v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe <*> pure False
| otherwise -> new <*> pure Nothing <*> pure SMSubscribe <*> pure False
where
new = NEW <$> _smpP <*> smpP
auth = optional (A.char 'A' *> smpP)
@@ -1361,6 +1385,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
QUE_ -> pure QUE
CT SSender tag ->
Cmd SSender <$> case tag of
SKEY_ -> SKEY <$> _smpP
SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP)
PING_ -> pure PING
RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP)
@@ -1377,8 +1402,12 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
type Tag BrokerMsg = BrokerMsgTag
encodeProtocol _v = \case
IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
encodeProtocol v = \case
IDS (QIK rcvId sndId srvDh sndSecure)
| v >= sndAuthKeySMPVersion -> ids <> e sndSecure
| otherwise -> ids
where
ids = e (IDS_, ' ', rcvId, sndId, srvDh)
MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} ->
e (MSG_, ' ', msgId, Tail body)
NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
@@ -1395,13 +1424,17 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
e :: Encoding a => a -> ByteString
e = smpEncode
protocolP _v = \case
protocolP v = \case
MSG_ -> do
msgId <- _smpP
MSG . RcvMessage msgId <$> bodyP
where
bodyP = EncRcvMsgBody . unTail <$> smpP
IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP)
IDS_
| v >= sndAuthKeySMPVersion -> ids smpP
| otherwise -> ids $ pure False
where
ids p = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p)
NID_ -> NID <$> _smpP <*> smpP
NMSG_ -> NMSG <$> _smpP <*> smpP
PKEY_ -> PKEY <$> _smpP <*> smpP <*> ((,) <$> C.certChainP <*> (C.getSignedExact <$> smpP))
+325 -171
View File
@@ -6,7 +6,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
@@ -60,6 +59,7 @@ import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
@@ -70,7 +70,7 @@ import GHC.Stats (getRTSStats)
import GHC.TypeLits (KnownNat)
import Network.Socket (ServiceName, Socket, socketToHandle)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPMessage, smpProxyError, temporaryClientError)
import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPTransmission, smpProxyError, temporaryClientError)
import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
@@ -158,7 +158,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
forall s.
Server ->
String ->
(Server -> TQueue (QueueId, Client)) ->
(Server -> TQueue (QueueId, Client, Subscribed)) ->
(Server -> TMap QueueId Client) ->
(Client -> TMap QueueId s) ->
(s -> IO ()) ->
@@ -172,14 +172,16 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
where
updateSubscribers :: STM (Maybe (QueueId, Client))
updateSubscribers = do
(qId, clnt) <- readTQueue $ subQ s
let clientToBeNotified c' =
if sameClientId clnt c'
then pure Nothing
else do
(qId, clnt, subscribed) <- readTQueue $ subQ s
let updateSub
| subscribed = TM.lookupInsert qId clnt (subs s)
| otherwise = TM.lookupDelete qId (subs s)
clientToBeNotified c'
| sameClientId clnt c' = pure Nothing
| otherwise = do
yes <- readTVar $ connected c'
pure $ if yes then Just (qId, c') else Nothing
TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified
updateSub $>>= clientToBeNotified
endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s)
endPreviousSubscriptions (qId, c) = do
forkClient c (label <> ".endPreviousSubscriptions") $
@@ -193,8 +195,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
CAConnected srv -> logInfo $ "SMP server connected " <> showServer' srv
CADisconnected srv [] -> logInfo $ "SMP server disconnected " <> showServer' srv
CADisconnected srv subs -> logError $ "SMP server disconnected " <> showServer' srv <> " / subscriptions: " <> tshow (length subs)
CAResubscribed srv subs -> logError $ "SMP server resubscribed " <> showServer' srv <> " / subscriptions: " <> tshow (length subs)
CASubError srv errs -> logError $ "SMP server subscription errors " <> showServer' srv <> " / errors: " <> tshow (length errs)
CASubscribed srv _ subs -> logError $ "SMP server subscribed " <> showServer' srv <> " / subscriptions: " <> tshow (length subs)
CASubError srv _ errs -> logError $ "SMP server subscription errors " <> showServer' srv <> " / errors: " <> tshow (length errs)
where
showServer' = decodeLatin1 . strEncode . host
@@ -229,7 +231,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, qSub, qSubAuth, qSubDuplicate, qSubProhibited, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv} <- asks serverStats
ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, qSub, qSubNoMsg, qSubAuth, qSubDuplicate, qSubProhibited, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv} <- asks serverStats
let interval = 1000000 * logInterval
forever $ do
withFile statsFilePath AppendMode $ \h -> liftIO $ do
@@ -242,6 +244,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
qDeletedNew' <- atomically $ swapTVar qDeletedNew 0
qDeletedSecured' <- atomically $ swapTVar qDeletedSecured 0
qSub' <- atomically $ swapTVar qSub 0
qSubNoMsg' <- atomically $ swapTVar qSubNoMsg 0
qSubAuth' <- atomically $ swapTVar qSubAuth 0
qSubDuplicate' <- atomically $ swapTVar qSubDuplicate 0
qSubProhibited' <- atomically $ swapTVar qSubProhibited 0
@@ -250,11 +253,20 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
msgSentQuota' <- atomically $ swapTVar msgSentQuota 0
msgSentLarge' <- atomically $ swapTVar msgSentLarge 0
msgRecv' <- atomically $ swapTVar msgRecv 0
msgRecvGet' <- atomically $ swapTVar msgRecvGet 0
msgGet' <- atomically $ swapTVar msgGet 0
msgGetNoMsg' <- atomically $ swapTVar msgGetNoMsg 0
msgGetAuth' <- atomically $ swapTVar msgGetAuth 0
msgGetDuplicate' <- atomically $ swapTVar msgGetDuplicate 0
msgGetProhibited' <- atomically $ swapTVar msgGetProhibited 0
msgExpired' <- atomically $ swapTVar msgExpired 0
ps <- atomically $ periodStatCounts activeQueues ts
msgSentNtf' <- atomically $ swapTVar msgSentNtf 0
msgRecvNtf' <- atomically $ swapTVar msgRecvNtf 0
psNtf <- atomically $ periodStatCounts activeQueuesNtf ts
msgNtfs' <- atomically $ swapTVar (msgNtfs ss) 0
msgNtfNoSub' <- atomically $ swapTVar (msgNtfNoSub ss) 0
msgNtfLost' <- atomically $ swapTVar (msgNtfLost ss) 0
pRelays' <- atomically $ getResetProxyStatsData pRelays
pRelaysOwn' <- atomically $ getResetProxyStatsData pRelaysOwn
pMsgFwds' <- atomically $ getResetProxyStatsData pMsgFwds
@@ -296,7 +308,17 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
show qSubProhibited',
show msgSentAuth',
show msgSentQuota',
show msgSentLarge'
show msgSentLarge',
show msgNtfs',
show msgNtfNoSub',
show msgNtfLost',
show qSubNoMsg',
show msgRecvGet',
show msgGet',
show msgGetNoMsg',
show msgGetAuth',
show msgGetDuplicate',
show msgGetProhibited'
]
)
liftIO $ threadDelay' interval
@@ -371,7 +393,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
let age = systemSeconds now - systemSeconds createdAt
subscriptions' <- bshow . M.size <$> readTVarIO subscriptions
hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions']
CPStats -> withAdminRole $ do
CPStats -> withUserRole $ do
ss <- unliftIO u $ asks serverStats
let putStat :: Show a => ByteString -> (ServerStats -> TVar a) -> IO ()
putStat label var = readTVarIO (var ss) >>= \v -> B.hPutStr h $ label <> ": " <> bshow v <> "\n"
@@ -385,8 +407,15 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
putStat "qDeletedAll" qDeletedAll
putStat "qDeletedNew" qDeletedNew
putStat "qDeletedSecured" qDeletedSecured
readTVarIO (day $ activeQueues ss) >>= \v -> B.hPutStr h $ "dayMsgQueues" <> ": " <> bshow (S.size v) <> "\n"
putStat "msgSent" msgSent
putStat "msgRecv" msgRecv
putStat "msgRecvGet" msgRecvGet
putStat "msgGet" msgGet
putStat "msgGetNoMsg" msgGetNoMsg
putStat "msgGetAuth" msgGetAuth
putStat "msgGetDuplicate" msgGetDuplicate
putStat "msgGetProhibited" msgGetProhibited
putStat "msgSentNtf" msgSentNtf
putStat "msgRecvNtf" msgRecvNtf
putStat "qCount" qCount
@@ -408,7 +437,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
#else
hPutStrLn h "Not available on GHC 8.10"
#endif
CPSockets -> withAdminRole $ do
CPSockets -> withUserRole $ do
(accepted', closed', active') <- unliftIO u $ asks sockets
(accepted, closed, active) <- atomically $ (,,) <$> readTVar accepted' <*> readTVar closed' <*> readTVar active'
hPutStrLn h "Sockets: "
@@ -430,6 +459,55 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
#else
hPutStrLn h "Not available on GHC 8.10"
#endif
CPServerInfo -> readTVarIO role >>= \case
CPRNone -> do
logError "Unauthorized control port command"
hPutStrLn h "AUTH"
r -> do
#if MIN_VERSION_base(4,18,0)
threads <- liftIO listThreads
hPutStrLn h $ "Threads: " <> show (length threads)
#else
hPutStrLn h "Threads: not available on GHC 8.10"
#endif
Env {clients, server = Server {subscribers, notifiers}} <- unliftIO u ask
activeClients <- readTVarIO clients
hPutStrLn h $ "Clients: " <> show (IM.size activeClients)
when (r == CPRAdmin) $ do
(smpSubCnt, smpSubCntByGroup, smpClCnt) <- countClientSubs subscriptions countSMPSubs activeClients
(ntfSubCnt, _, ntfClCnt) <- countClientSubs ntfSubscriptions (\_ -> pure (0, 0, 0, 0)) activeClients
hPutStrLn h $ "SMP subscriptions (via clients, slow): " <> show smpSubCnt
hPutStrLn h $ "SMP subscriptions (by group: NoSub, SubPending, SubThread, ProhibitSub): " <> show smpSubCntByGroup
hPutStrLn h $ "SMP subscribed clients (via clients, slow): " <> show smpClCnt
hPutStrLn h $ "Ntf subscriptions (via clients, slow): " <> show ntfSubCnt
hPutStrLn h $ "Ntf subscribed clients (via clients, slow): " <> show ntfClCnt
activeSubs <- readTVarIO subscribers
activeNtfSubs <- readTVarIO notifiers
hPutStrLn h $ "SMP subscriptions: " <> show (M.size activeSubs)
hPutStrLn h $ "SMP subscribed clients: " <> show (countSubClients activeSubs)
hPutStrLn h $ "Ntf subscriptions: " <> show (M.size activeNtfSubs)
hPutStrLn h $ "Ntf subscribed clients: " <> show (countSubClients activeNtfSubs)
where
countClientSubs :: (Client -> TMap QueueId a) -> (M.Map QueueId a -> IO (Int, Int, Int, Int)) -> IM.IntMap Client -> IO (Int, (Int, Int, Int, Int), Int)
countClientSubs subSel countSubs = foldM addSubs (0, (0, 0, 0, 0), 0)
where
addSubs :: (Int, (Int, Int, Int, Int), Int) -> Client -> IO (Int, (Int, Int, Int, Int), Int)
addSubs (subCnt, (c1, c2, c3, c4), clCnt) cl = do
subs <- readTVarIO $ subSel cl
(c1', c2', c3', c4') <- countSubs subs
let cnt = M.size subs
cnts' = (c1 + c1', c2 + c2', c3 + c3', c4 + c4')
pure (subCnt + cnt, cnts', clCnt + if cnt == 0 then 0 else 1)
countSMPSubs :: M.Map QueueId Sub -> IO (Int, Int, Int, Int)
countSMPSubs = foldM countSubs (0, 0, 0, 0)
where
countSubs (c1, c2, c3, c4) Sub {subThread} =
readTVarIO subThread >>= \st -> pure $ case st of
NoSub -> (c1 + 1, c2, c3, c4)
SubPending -> (c1, c2 + 1, c3, c4)
SubThread _ -> (c1, c2, c3 + 1, c4)
ProhibitSub -> (c1, c2, c3, c4 + 1)
countSubClients = S.size . M.foldr' (S.insert . clientId) S.empty
CPDelete queueId' -> withUserRole $ unliftIO u $ do
st <- asks queueStore
ms <- asks msgStore
@@ -449,7 +527,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
hPutStrLn h "saving server state..."
unliftIO u $ saveServer True
hPutStrLn h "server state saved!"
CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, delete, save, help, quit"
CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, server-info, delete, save, help, quit"
CPQuit -> pure ()
CPSkip -> pure ()
where
@@ -487,19 +565,22 @@ runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessio
noSubscriptions c = atomically $ (&&) <$> TM.null (subscriptions c) <*> TM.null (ntfSubscriptions c)
clientDisconnected :: Client -> M ()
clientDisconnected c@Client {clientId, subscriptions, connected, sessionId, endThreads} = do
clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, connected, sessionId, endThreads} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disc"
subs <- atomically $ do
(subs, ntfSubs) <- atomically $ do
writeTVar connected False
swapTVar subscriptions M.empty
(,) <$> swapTVar subscriptions M.empty <*> swapTVar ntfSubscriptions M.empty
liftIO $ mapM_ cancelSub subs
srvSubs <- asks $ subscribers . server
atomically $ modifyTVar' srvSubs $ \cs ->
M.foldrWithKey (\sub _ -> M.update deleteCurrentClient sub) cs subs
Server {subscribers, notifiers} <- asks server
updateSubscribers subs subscribers
updateSubscribers ntfSubs notifiers
asks clients >>= atomically . (`modifyTVar'` IM.delete clientId)
tIds <- atomically $ swapTVar endThreads IM.empty
liftIO $ mapM_ (mapM_ killThread <=< deRefWeak) tIds
where
updateSubscribers subs srvSubs = do
atomically $ modifyTVar' srvSubs $ \cs ->
M.foldrWithKey (\sub _ -> M.update deleteCurrentClient sub) cs subs
deleteCurrentClient :: Client -> Maybe Client
deleteCurrentClient c'
| sameClientId c c' = Nothing
@@ -508,18 +589,18 @@ clientDisconnected c@Client {clientId, subscriptions, connected, sessionId, endT
sameClientId :: Client -> Client -> Bool
sameClientId Client {clientId} Client {clientId = cId'} = clientId == cId'
cancelSub :: TVar Sub -> IO ()
cancelSub sub =
readTVarIO sub >>= \case
Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
_ -> return ()
cancelSub :: Sub -> IO ()
cancelSub s =
readTVarIO (subThread s) >>= \case
SubThread t -> liftIO $ deRefWeak t >>= mapM_ killThread
_ -> pure ()
receive :: Transport c => THandleSMP c 'TServer -> Client -> M ()
receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
forever $ do
ts <- L.toList <$> liftIO (tGet h)
atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime
atomically . (writeTVar rcvActiveAt $!) =<< liftIO getSystemTime
stats <- asks serverStats
(errs, cmds) <- partitionEithers <$> mapM (cmdAction stats) ts
write sndQ errs
@@ -535,8 +616,9 @@ receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiv
VRVerified qr -> pure $ Right (qr, (corrId, entId, cmd))
VRFailed -> do
case cmd of
Cmd _ SEND {} -> atomically $ modifyTVar' (msgSentAuth stats) (+ 1)
Cmd _ SUB -> atomically $ modifyTVar' (qSubAuth stats) (+ 1)
Cmd _ SEND {} -> incStat $ msgSentAuth stats
Cmd _ SUB -> incStat $ qSubAuth stats
Cmd _ GET -> incStat $ msgGetAuth stats
_ -> pure ()
pure $ Left (corrId, entId, ERR AUTH)
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
@@ -575,7 +657,7 @@ tSend :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> NonEmpty (Tran
tSend th Client {sndActiveAt} ts = do
withMVar th $ \h@THandle {params} ->
void . tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts
atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime
disconnectTransport :: Transport c => THandle v c 'TServer -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
disconnectTransport THandle {connection, params = THandleParams {sessionId}} rcvActiveAt sndActiveAt expCfg noSubscriptions = do
@@ -601,9 +683,10 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
verifyTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult
verifyTransmission auth_ tAuth authorized queueId cmd =
case cmd of
Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verifiedWith` k
Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k
Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey q) <$> get SRecipient
-- SEND will be accepted without authorization before the queue is secured with KEY command
-- SEND will be accepted without authorization before the queue is secured with KEY or SKEY command
Cmd SSender (SKEY k) -> verifyQueue (\q -> Just q `verifiedWith` k) <$> get SSender
Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender
Cmd SSender PING -> pure $ VRVerified Nothing
Cmd SSender RFWD {} -> pure $ VRVerified Nothing
@@ -676,7 +759,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do
mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId
client :: THandleParams SMPVersion 'TServer -> Client -> Server -> M ()
client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, notifiers} = do
client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, subscribers, notifiers} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
forever $
atomically (readTBQueue rcvQ)
@@ -714,7 +797,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
let own = isOwnServer a srv
inc own pRequests
inc own $ if temporaryClientError e then pErrorsConnect else pErrorsOther
logError $ "Error connecting: " <> decodeLatin1 (strEncode $ host srv) <> " " <> tshow e
logWarn $ "Error connecting: " <> decodeLatin1 (strEncode $ host srv) <> " " <> tshow e
pure . ERR $ smpProxyError e
where
proxyResp smp =
@@ -735,7 +818,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
inc own pRequests
if v >= sendingProxySMPVersion
then forkProxiedCmd $ do
liftIO (runExceptT (forwardSMPMessage smp corrId fwdV pubKey encBlock) `catch` (pure . Left . PCEIOError)) >>= \case
liftIO (runExceptT (forwardSMPTransmission smp corrId fwdV pubKey encBlock) `catch` (pure . Left . PCEIOError)) >>= \case
Right r -> PRES r <$ inc own pSuccesses
Left e -> ERR (smpProxyError e) <$ case e of
PCEProtocolError {} -> inc own pSuccesses
@@ -762,13 +845,18 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
transportErr :: TransportError -> ErrorType
transportErr = PROXY . BROKER . TRANSPORT
mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> TVar Int) -> m ()
mkIncProxyStats ps psOwn = \own sel -> do
atomically $ modifyTVar' (sel ps) (+ 1)
when own $ atomically $ modifyTVar' (sel psOwn) (+ 1)
mkIncProxyStats ps psOwn own sel = do
incStat $ sel ps
when own $ incStat $ sel psOwn
processCommand :: (Maybe QueueRec, Transmission Cmd) -> M (Maybe (Transmission BrokerMsg))
processCommand (qr_, (corrId, queueId, cmd)) = case cmd of
Cmd SProxiedClient command -> processProxiedCmd (corrId, queueId, command)
Cmd SSender command -> Just <$> case command of
SKEY sKey -> (corrId,queueId,) <$> case qr_ of
Just QueueRec {sndSecure, recipientId}
| sndSecure -> secureQueue_ "SKEY" recipientId sKey
| otherwise -> pure $ ERR AUTH
Nothing -> pure $ ERR INTERNAL
SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
PING -> pure (corrId, "", PONG)
RFWD encBlock -> (corrId, "",) <$> processForwardedCommand encBlock
@@ -776,10 +864,10 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
Cmd SRecipient command -> do
st <- asks queueStore
Just <$> case command of
NEW rKey dhKey auth subMode ->
NEW rKey dhKey auth subMode sndSecure ->
ifM
allowNew
(createQueue st rKey dhKey subMode)
(createQueue st rKey dhKey subMode sndSecure)
(pure (corrId, queueId, ERR AUTH))
where
allowNew = do
@@ -788,18 +876,20 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
SUB -> withQueue (`subscribeQueue` queueId)
GET -> withQueue getMessage
ACK msgId -> withQueue (`acknowledgeMsg` msgId)
KEY sKey -> secureQueue_ st sKey
KEY sKey -> (corrId,queueId,) <$> case qr_ of
Just QueueRec {recipientId} -> secureQueue_ "KEY" recipientId sKey
Nothing -> pure $ ERR INTERNAL
NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
NDEL -> deleteQueueNotifier_ st
OFF -> suspendQueue_ st
DEL -> delQueueAndMsgs st
QUE -> withQueue getQueueInfo
where
createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> M (Transmission BrokerMsg)
createQueue st recipientKey dhKey subMode = time "NEW" $ do
createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg)
createQueue st recipientKey dhKey subMode sndSecure = time "NEW" $ do
(rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
let rcvDhSecret = C.dh' dhKey privDhKey
qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey}
qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}
qRec (recipientId, senderId) =
QueueRec
{ recipientId,
@@ -808,7 +898,8 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
rcvDhSecret,
senderKey = Nothing,
notifier = Nothing,
status = QueueActive
status = QueueActive,
sndSecure
}
(corrId,queueId,) <$> addQueueRetry 3 qik qRec
where
@@ -825,8 +916,8 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
Right _ -> do
withLog (`logCreateById` rId)
stats <- asks serverStats
atomically $ modifyTVar' (qCreated stats) (+ 1)
atomically $ modifyTVar' (qCount stats) (+ 1)
incStat $ qCreated stats
incStat $ qCount stats
case subMode of
SMOnlyCreate -> pure ()
SMSubscribe -> void $ subscribeQueue qr rId
@@ -843,12 +934,13 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
n <- asks $ queueIdBytes . config
liftM2 (,) (randomId n) (randomId n)
secureQueue_ :: QueueStore -> SndPublicAuthKey -> M (Transmission BrokerMsg)
secureQueue_ st sKey = time "KEY" $ do
withLog $ \s -> logSecureQueue s queueId sKey
secureQueue_ :: T.Text -> RecipientId -> SndPublicAuthKey -> M BrokerMsg
secureQueue_ name rId sKey = time name $ do
withLog $ \s -> logSecureQueue s rId sKey
st <- asks queueStore
stats <- asks serverStats
atomically $ modifyTVar' (qSecured stats) (+ 1)
atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
incStat $ qSecured stats
atomically $ either ERR (const OK) <$> secureQueue st rId sKey
addQueueNotifier_ :: QueueStore -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M (Transmission BrokerMsg)
addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do
@@ -871,7 +963,12 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
deleteQueueNotifier_ :: QueueStore -> M (Transmission BrokerMsg)
deleteQueueNotifier_ st = do
withLog (`logDeleteNotifier` queueId)
okResp <$> atomically (deleteQueueNotifier st queueId)
atomically (deleteQueueNotifier st queueId) >>= \case
Right () -> do
-- Possibly, the same should be done if the queue is suspended, but currently we do not use it
atomically $ writeTQueue ntfSubscribedQ (queueId, clnt, False)
pure ok
Left e -> pure $ err e
suspendQueue_ :: QueueStore -> M (Transmission BrokerMsg)
suspendQueue_ st = do
@@ -880,61 +977,69 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
subscribeQueue :: QueueRec -> RecipientId -> M (Transmission BrokerMsg)
subscribeQueue qr rId = do
stats <- asks serverStats
atomically (TM.lookup rId subscriptions) >>= \case
Nothing -> do
atomically $ modifyTVar' (qSub stats) (+ 1)
newSub >>= deliver
Just sub ->
readTVarIO sub >>= \case
Sub {subThread = ProhibitSub} -> do
Nothing -> newSub >>= deliver True
Just s@Sub {subThread} -> do
stats <- asks serverStats
readTVarIO subThread >>= \case
ProhibitSub -> do
-- cannot use SUB in the same connection where GET was used
atomically $ modifyTVar' (qSubProhibited stats) (+ 1)
incStat $ qSubProhibited stats
pure (corrId, rId, ERR $ CMD PROHIBITED)
s -> do
atomically $ modifyTVar' (qSubDuplicate stats) (+ 1)
atomically (tryTakeTMVar $ delivered s) >> deliver sub
_ -> do
incStat $ qSubDuplicate stats
atomically (tryTakeTMVar $ delivered s) >> deliver False s
where
newSub :: M (TVar Sub)
newSub :: M Sub
newSub = time "SUB newSub" . atomically $ do
writeTQueue subscribedQ (rId, clnt)
sub <- newTVar =<< newSubscription NoSub
writeTQueue subscribedQ (rId, clnt, True)
sub <- newSubscription NoSub
TM.insert rId sub subscriptions
pure sub
deliver :: TVar Sub -> M (Transmission BrokerMsg)
deliver sub = do
deliver :: Bool -> Sub -> M (Transmission BrokerMsg)
deliver inc sub = do
q <- getStoreMsgQueue "SUB" rId
msg_ <- atomically $ tryPeekMsg q
deliverMessage "SUB" qr rId sub q msg_
when inc $ do
stats <- asks serverStats
incStat $ (if isJust msg_ then qSub else qSubNoMsg) stats
deliverMessage "SUB" qr rId sub msg_
getMessage :: QueueRec -> M (Transmission BrokerMsg)
getMessage qr = time "GET" $ do
atomically (TM.lookup queueId subscriptions) >>= \case
Nothing ->
atomically newSub >>= getMessage_
Just sub ->
readTVarIO sub >>= \case
s@Sub {subThread = ProhibitSub} ->
atomically newSub >>= (`getMessage_` Nothing)
Just s@Sub {subThread} ->
readTVarIO subThread >>= \case
ProhibitSub ->
atomically (tryTakeTMVar $ delivered s)
>> getMessage_ s
>>= getMessage_ s
-- cannot use GET in the same connection where there is an active subscription
_ -> pure (corrId, queueId, ERR $ CMD PROHIBITED)
_ -> do
stats <- asks serverStats
incStat $ msgGetProhibited stats
pure (corrId, queueId, ERR $ CMD PROHIBITED)
where
newSub :: STM Sub
newSub = do
s <- newSubscription ProhibitSub
sub <- newTVar s
TM.insert queueId sub subscriptions
TM.insert queueId s subscriptions
pure s
getMessage_ :: Sub -> M (Transmission BrokerMsg)
getMessage_ s = do
getMessage_ :: Sub -> Maybe MsgId -> M (Transmission BrokerMsg)
getMessage_ s delivered_ = do
q <- getStoreMsgQueue "GET" queueId
atomically $
tryPeekMsg q >>= \case
Just msg ->
let encMsg = encryptMsg qr msg
in setDelivered s msg $> (corrId, queueId, MSG encMsg)
_ -> pure (corrId, queueId, OK)
stats <- asks serverStats
(statCnt, r) <-
atomically $
tryPeekMsg q >>= \case
Just msg ->
let encMsg = encryptMsg qr msg
cnt = if isJust delivered_ then msgGetDuplicate else msgGet
in setDelivered s msg $> (cnt, (corrId, queueId, MSG encMsg))
_ -> pure (msgGetNoMsg, (corrId, queueId, OK))
incStat $ statCnt stats
pure r
withQueue :: (QueueRec -> M (Transmission BrokerMsg)) -> M (Transmission BrokerMsg)
withQueue action = maybe (pure $ err AUTH) action qr_
@@ -942,7 +1047,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
subscribeNotifications :: M (Transmission BrokerMsg)
subscribeNotifications = time "NSUB" . atomically $ do
unlessM (TM.member queueId ntfSubscriptions) $ do
writeTQueue ntfSubscribedQ (queueId, clnt)
writeTQueue ntfSubscribedQ (queueId, clnt, True)
TM.insert queueId () ntfSubscriptions
pure ok
@@ -952,49 +1057,49 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
Nothing -> pure $ err NO_MSG
Just sub ->
atomically (getDelivered sub) >>= \case
Just s -> do
Just st -> do
q <- getStoreMsgQueue "ACK" queueId
case s of
Sub {subThread = ProhibitSub} -> do
case st of
ProhibitSub -> do
deletedMsg_ <- atomically $ tryDelMsg q msgId
mapM_ updateStats deletedMsg_
mapM_ (updateStats True) deletedMsg_
pure ok
_ -> do
(deletedMsg_, msg_) <- atomically $ tryDelPeekMsg q msgId
mapM_ updateStats deletedMsg_
deliverMessage "ACK" qr queueId sub q msg_
mapM_ (updateStats False) deletedMsg_
deliverMessage "ACK" qr queueId sub msg_
_ -> pure $ err NO_MSG
where
getDelivered :: TVar Sub -> STM (Maybe Sub)
getDelivered sub = do
s@Sub {delivered} <- readTVar sub
getDelivered :: Sub -> STM (Maybe SubscriptionThread)
getDelivered Sub {delivered, subThread} = do
tryTakeTMVar delivered $>>= \msgId' ->
if msgId == msgId' || B.null msgId
then pure $ Just s
then Just <$> readTVar subThread
else putTMVar delivered msgId' $> Nothing
updateStats :: Message -> M ()
updateStats = \case
updateStats :: Bool -> Message -> M ()
updateStats isGet = \case
MessageQuota {} -> pure ()
Message {msgFlags} -> do
stats <- asks serverStats
atomically $ modifyTVar' (msgRecv stats) (+ 1)
incStat $ msgRecv stats
when isGet $ incStat $ msgRecvGet stats
atomically $ modifyTVar' (msgCount stats) (subtract 1)
atomically $ updatePeriodStats (activeQueues stats) queueId
when (notification msgFlags) $ do
atomically $ modifyTVar' (msgRecvNtf stats) (+ 1)
incStat $ msgRecvNtf stats
atomically $ updatePeriodStats (activeQueuesNtf stats) queueId
sendMessage :: QueueRec -> MsgFlags -> MsgBody -> M (Transmission BrokerMsg)
sendMessage qr msgFlags msgBody
| B.length msgBody > maxMessageLength thVersion = do
stats <- asks serverStats
atomically $ modifyTVar' (msgSentLarge stats) (+ 1)
incStat $ msgSentLarge stats
pure $ err LARGE_MSG
| otherwise = do
stats <- asks serverStats
case status qr of
QueueOff -> do
atomically $ modifyTVar' (msgSentAuth stats) (+ 1)
incStat $ msgSentAuth stats
pure $ err AUTH
QueueActive ->
case C.maxLenBS msgBody of
@@ -1006,15 +1111,24 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
atomically . writeMsg q =<< mkMessage body
case msg_ of
Nothing -> do
atomically $ modifyTVar' (msgSentQuota stats) (+ 1)
incStat $ msgSentQuota stats
pure $ err QUOTA
Just msg -> time "SEND ok" $ do
Just (msg, wasEmpty) -> time "SEND ok" $ do
when wasEmpty $ tryDeliverMessage msg
when (notification msgFlags) $ do
atomically . trySendNotification msg =<< asks random
atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
forM_ (notifier qr) $ \ntf -> do
asks random >>= atomically . trySendNotification ntf msg >>= \case
Nothing -> do
incStat $ msgNtfNoSub stats
logWarn "No notification subscription"
Just False -> do
incStat $ msgNtfLost stats
logWarn "Dropped message notification"
Just True -> incStat $ msgNtfs stats
incStat $ msgSentNtf stats
atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
atomically $ modifyTVar' (msgSent stats) (+ 1)
atomically $ modifyTVar' (msgCount stats) (+ 1)
incStat $ msgSent stats
incStat $ msgCount stats
atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
pure ok
where
@@ -1023,28 +1137,76 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
mkMessage body = do
msgId <- randomId =<< asks (msgIdBytes . config)
msgTs <- liftIO getSystemTime
pure $ Message msgId msgTs msgFlags body
pure $! Message msgId msgTs msgFlags body
expireMessages :: MsgQueue -> M ()
expireMessages q = do
msgExp <- asks $ messageExpiration . config
old <- liftIO $ mapM expireBeforeEpoch msgExp
stats <- asks serverStats
deleted <- atomically $ sum <$> mapM (deleteExpiredMsgs q) old
atomically $ modifyTVar' (msgExpired stats) (+ deleted)
when (deleted > 0) $ do
stats <- asks serverStats
atomically $ modifyTVar' (msgExpired stats) (+ deleted)
trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
trySendNotification msg ntfNonceDrg =
forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
-- The condition for delivery of the message is:
-- - the queue was empty when the message was sent,
-- - there is subscribed recipient,
-- - no message was "delivered" that was not acknowledged.
-- If the send queue of the subscribed client is not full the message is put there in the same transaction.
-- If the queue is not full, then the thread is created where these checks are made:
-- - it is the same subscribed client (in case it was reconnected it would receive message via SUB command)
-- - nothing was delivered to this subscription (to avoid race conditions with the recipient).
tryDeliverMessage :: Message -> M ()
tryDeliverMessage msg = atomically deliverToSub >>= mapM_ forkDeliver
where
rId = recipientId qr
deliverToSub =
TM.lookup rId subscribers
$>>= \rc@Client {subscriptions = subs, sndQ = q} -> TM.lookup rId subs
$>>= \s@Sub {subThread, delivered} -> readTVar subThread >>= \case
NoSub ->
tryTakeTMVar delivered >>= \case
Just _ -> pure Nothing -- if a message was already delivered, should not deliver more
Nothing ->
ifM
(isFullTBQueue q)
(writeTVar subThread SubPending $> Just (rc, s))
(deliver q s $> Nothing)
_ -> pure Nothing
deliver q s = do
let encMsg = encryptMsg qr msg
writeTBQueue q [(CorrId "", rId, MSG encMsg)]
void $ setDelivered s msg
forkDeliver (rc@Client {sndQ = q}, s@Sub {subThread, delivered}) = do
t <- mkWeakThreadId =<< forkIO deliverThread
atomically . modifyTVar' subThread $ \case
-- this case is needed because deliverThread can exit before it
SubPending -> SubThread t
st -> st
where
deliverThread = do
labelMyThread $ B.unpack ("client $" <> encode sessionId) <> " deliver/SEND"
time "deliver" . atomically $
whenM (maybe False (sameClientId rc) <$> TM.lookup rId subscribers) $ do
tryTakeTMVar delivered >>= \case
Just _ -> pure () -- if a message was already delivered, should not deliver more
Nothing -> do
deliver q s
writeTVar subThread NoSub
writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
trySendNotification :: NtfCreds -> Message -> TVar ChaChaDRG -> STM (Maybe Bool)
trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg ntfNonceDrg =
mapM (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM Bool
writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
unlessM (isFullTBQueue q) $ case msg of
Message {msgId, msgTs} -> do
(nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg
writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
_ -> pure ()
ifM (isFullTBQueue q) (pure False) (sendNtf $> True)
where
sendNtf = case msg of
Message {msgId, msgTs} -> do
(nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg
writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
_ -> pure ()
mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg = do
@@ -1069,16 +1231,13 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
t :| [] -> pure $ tDecodeParseValidate clntTHParams t
_ -> throwE BLOCK
let clntThAuth = Just $ THAuthServer {serverPrivKey, sessSecret' = Just clientSecret}
-- process forwarded SEND
-- process forwarded command
r <-
lift (rejectOrVerify clntThAuth t') >>= \case
Left r -> pure r
Right t''@(_, (corrId', entId', cmd')) -> case cmd' of
Cmd SSender SEND {} ->
-- Left will not be returned by processCommand, as only SEND command is allowed
fromMaybe (corrId', entId', ERR INTERNAL) <$> lift (processCommand t'')
_ ->
pure (corrId', entId', ERR $ CMD PROHIBITED)
-- rejectOrVerify filters allowed commands, no need to repeat it here.
-- INTERNAL is used because processCommand never returns Nothing for sender commands (could be extracted for better types).
Right t''@(_, (corrId', entId', _)) -> fromMaybe (corrId', entId', ERR INTERNAL) <$> lift (processCommand t'')
-- encode response
r' <- case batchTransmissions (batch clntTHParams) (blockSize clntTHParams) [Right (Nothing, encodeTransmission clntTHParams r)] of
[] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right
@@ -1086,54 +1245,40 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
TBTransmission b' _ : _ -> pure b'
TBTransmissions b' _ _ : _ -> pure b'
-- encrypt to client
r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (C.reverseNonce clientNonce) r' paddedProxiedMsgLength
r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (C.reverseNonce clientNonce) r' paddedProxiedTLength
-- encrypt to proxy
let fr = FwdResponse {fwdCorrId, fwdResponse = r2}
r3 = EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr)
stats <- asks serverStats
atomically $ modifyTVar' (pMsgFwdsRecv stats) (+ 1)
incStat $ pMsgFwdsRecv stats
pure $ RRES r3
where
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
rejectOrVerify clntThAuth (tAuth, authorized, (corrId', entId', cmdOrError)) =
case cmdOrError of
Left e -> pure $ Left (corrId', entId', ERR e)
Right cmd'@(Cmd SSender SEND {}) -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId')) <$> clntThAuth) tAuth authorized entId' cmd'
Right cmd'
| allowed -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId')) <$> clntThAuth) tAuth authorized entId' cmd'
| otherwise -> pure $ Left (corrId', entId', ERR $ CMD PROHIBITED)
where
allowed = case cmd' of
Cmd SSender SEND {} -> True
Cmd SSender (SKEY _) -> True
_ -> False
verified = \case
VRVerified qr -> Right (qr, (corrId', entId', cmd'))
VRFailed -> Left (corrId', entId', ERR AUTH)
Right _ -> pure $ Left (corrId', entId', ERR $ CMD PROHIBITED)
deliverMessage :: T.Text -> QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> M (Transmission BrokerMsg)
deliverMessage name qr rId sub q msg_ = time (name <> " deliver") $ do
readTVarIO sub >>= \case
s@Sub {subThread = NoSub} ->
case msg_ of
Just msg ->
let encMsg = encryptMsg qr msg
in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg)
_ -> forkSub $> resp
_ -> pure resp
deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> M (Transmission BrokerMsg)
deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") . atomically $
readTVar subThread >>= \case
ProhibitSub -> pure resp
_ -> case msg_ of
Just msg ->
let encMsg = encryptMsg qr msg
in setDelivered s msg $> (corrId, rId, MSG encMsg)
_ -> pure resp
where
resp = (corrId, rId, OK)
forkSub :: M ()
forkSub = do
atomically . modifyTVar' sub $ \s -> s {subThread = SubPending}
t <- mkWeakThreadId =<< forkIO subscriber
atomically . modifyTVar' sub $ \case
s@Sub {subThread = SubPending} -> s {subThread = SubThread t}
s -> s
where
subscriber = do
labelMyThread $ B.unpack ("client $" <> encode sessionId) <> " subscriber/" <> T.unpack name
msg <- atomically $ peekMsg q
time "subscriber" . atomically $ do
let encMsg = encryptMsg qr msg
writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)]
s <- readTVar sub
void $ setDelivered s msg
writeTVar sub $! s {subThread = NoSub}
time :: T.Text -> M a -> M a
time name = timed name queueId
@@ -1149,7 +1294,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
msgTs' = messageTs msg
setDelivered :: Sub -> Message -> STM Bool
setDelivered s msg = tryPutTMVar (delivered s) (messageId msg)
setDelivered s msg = tryPutTMVar (delivered s) $! messageId msg
getStoreMsgQueue :: T.Text -> RecipientId -> M MsgQueue
getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do
@@ -1162,7 +1307,12 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
withLog (`logDeleteQueue` queueId)
ms <- asks msgStore
atomically (deleteQueue st queueId $>>= \q -> delMsgQueue ms queueId $> Right q) >>= \case
Right q -> updateDeletedStats q $> ok
Right q -> do
-- Possibly, the same should be done if the queue is suspended, but currently we do not use it
atomically $ writeTQueue subscribedQ (queueId, clnt, False)
atomically $ writeTQueue ntfSubscribedQ (queueId, clnt, False)
updateDeletedStats q
pure ok
Left e -> pure $ err e
getQueueInfo :: QueueRec -> M (Transmission BrokerMsg)
@@ -1175,16 +1325,16 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
pure QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg}
pure (corrId, queueId, INFO info)
where
mkQSub sub = do
Sub {subThread, delivered} <- readTVar sub
let qSubThread = case subThread of
mkQSub Sub {subThread, delivered} = do
st <- readTVar subThread
let qSubThread = case st of
NoSub -> QNoSub
SubPending -> QSubPending
SubThread _ -> QSubThread
ProhibitSub -> QProhibitSub
qDelivered <- decodeLatin1 . encode <$$> tryReadTMVar delivered
pure QSub {qSubThread, qDelivered}
ok :: Transmission BrokerMsg
ok = (corrId, queueId, OK)
@@ -1198,9 +1348,13 @@ updateDeletedStats :: QueueRec -> M ()
updateDeletedStats q = do
stats <- asks serverStats
let delSel = if isNothing (senderKey q) then qDeletedNew else qDeletedSecured
atomically $ modifyTVar' (delSel stats) (+ 1)
atomically $ modifyTVar' (qDeletedAll stats) (+ 1)
atomically $ modifyTVar' (qCount stats) (subtract 1)
incStat $ delSel stats
incStat $ qDeletedAll stats
incStat $ qCount stats
incStat :: MonadIO m => TVar Int -> m ()
incStat v = atomically $ modifyTVar' v (+ 1)
{-# INLINE incStat #-}
withLog :: (StoreLog 'WriteMode -> IO a) -> M ()
withLog action = do
+4
View File
@@ -9,6 +9,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BasicAuth)
data CPClientRole = CPRNone | CPRUser | CPRAdmin
deriving (Eq)
data ControlProtocol
= CPAuth BasicAuth
@@ -20,6 +21,7 @@ data ControlProtocol
| CPThreads
| CPSockets
| CPSocketThreads
| CPServerInfo
| CPDelete ByteString
| CPSave
| CPHelp
@@ -37,6 +39,7 @@ instance StrEncoding ControlProtocol where
CPThreads -> "threads"
CPSockets -> "sockets"
CPSocketThreads -> "socket-threads"
CPServerInfo -> "server-info"
CPDelete bs -> "delete " <> strEncode bs
CPSave -> "save"
CPHelp -> "help"
@@ -53,6 +56,7 @@ instance StrEncoding ControlProtocol where
"threads" -> pure CPThreads
"sockets" -> pure CPSockets
"socket-threads" -> pure CPSocketThreads
"server-info" -> pure CPServerInfo
"delete" -> CPDelete <$> (A.space *> strP)
"save" -> pure CPSave
"help" -> pure CPHelp
+8 -6
View File
@@ -47,7 +47,6 @@ data ServerConfig = ServerConfig
{ transports :: [(ServiceName, ATransport)],
smpHandshakeTimeout :: Int,
tbqSize :: Natural,
-- serverTbqSize :: Natural,
msgQueueQuota :: Int,
queueIdBytes :: Int,
msgIdBytes :: Int,
@@ -129,10 +128,12 @@ data Env = Env
proxyAgent :: ProxyAgent -- senders served on this proxy
}
type Subscribed = Bool
data Server = Server
{ subscribedQ :: TQueue (RecipientId, Client),
{ subscribedQ :: TQueue (RecipientId, Client, Subscribed),
subscribers :: TMap RecipientId Client,
ntfSubscribedQ :: TQueue (NotifierId, Client),
ntfSubscribedQ :: TQueue (NotifierId, Client, Subscribed),
notifiers :: TMap NotifierId Client,
savingLock :: Lock
}
@@ -145,7 +146,7 @@ type ClientId = Int
data Client = Client
{ clientId :: ClientId,
subscriptions :: TMap RecipientId (TVar Sub),
subscriptions :: TMap RecipientId Sub,
ntfSubscriptions :: TMap NotifierId (),
rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
@@ -164,7 +165,7 @@ data Client = Client
data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub
data Sub = Sub
{ subThread :: SubscriptionThread,
{ subThread :: TVar SubscriptionThread,
delivered :: TMVar MsgId
}
@@ -194,8 +195,9 @@ newClient nextClientId qSize thVersion sessionId createdAt = do
return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, msgQ, procThreads, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt}
newSubscription :: SubscriptionThread -> STM Sub
newSubscription subThread = do
newSubscription st = do
delivered <- newEmptyTMVar
subThread <- newTVar st
return Sub {subThread, delivered}
newEnv :: ServerConfig -> IO Env
+1 -7
View File
@@ -255,7 +255,6 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
{ transports = iniTransports ini,
smpHandshakeTimeout = 120000000,
tbqSize = 64,
-- serverTbqSize = 1024,
msgQueueQuota = 128,
queueIdBytes = 24,
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
@@ -306,7 +305,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
networkConfig =
defaultNetworkConfig
{ socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,
socksMode = either (const SMOnion) textToSocksMode $ lookupValue "PROXY" "socks_mode" ini,
socksMode = maybe SMOnion (either error id) $! strDecodeIni "PROXY" "socks_mode" ini,
hostMode = either (const HMPublic) textToHostMode $ lookupValue "PROXY" "host_mode" ini,
requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini
}
@@ -318,11 +317,6 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini,
information = serverPublicInfo ini
}
textToSocksMode :: Text -> SocksMode
textToSocksMode = \case
"always" -> SMAlways
"onion" -> SMOnion
s -> error . T.unpack $ "Invalid socks_mode: " <> s
textToHostMode :: Text -> HostMode
textToHostMode = \case
"public" -> HMPublic
+5 -4
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -74,8 +75,8 @@ snapshotMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (snapshotTQueue .
mapM_ (writeTQueue q) msgs
pure msgs
writeMsg :: MsgQueue -> Message -> STM (Maybe Message)
writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} msg = do
writeMsg :: MsgQueue -> Message -> STM (Maybe (Message, Bool))
writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = do
canWrt <- readTVar canWrite
empty <- isEmptyTQueue q
if canWrt || empty
@@ -84,8 +85,8 @@ writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} msg = do
writeTVar canWrite $! canWrt'
modifyTVar' size (+ 1)
if canWrt'
then writeTQueue q msg $> Just msg
else writeTQueue q msgQuota $> Nothing
then writeTQueue q msg $> Just (msg, empty)
else (writeTQueue q $! msgQuota) $> Nothing
else pure Nothing
where
msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
@@ -14,6 +14,7 @@ data QueueRec = QueueRec
rcvDhSecret :: !RcvDhSecret,
senderId :: !SenderId,
senderKey :: !(Maybe SndPublicAuthKey),
sndSecure :: !SenderCanSecure,
notifier :: !(Maybe NtfCreds),
status :: !ServerQueueStatus
}
@@ -1,3 +1,4 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
@@ -69,7 +70,7 @@ secureQueue QueueStore {queues} rId sKey =
readTVar qVar >>= \q -> case senderKey q of
Just k -> pure $ if sKey == k then Just q else Nothing
_ ->
let q' = q {senderKey = Just sKey}
let !q' = q {senderKey = Just sKey}
in writeTVar qVar q' $> Just q'
addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec)
+194 -7
View File
@@ -27,6 +27,7 @@ data ServerStats = ServerStats
qDeletedNew :: TVar Int,
qDeletedSecured :: TVar Int,
qSub :: TVar Int,
qSubNoMsg :: TVar Int,
qSubAuth :: TVar Int,
qSubDuplicate :: TVar Int,
qSubProhibited :: TVar Int,
@@ -35,11 +36,20 @@ data ServerStats = ServerStats
msgSentQuota :: TVar Int,
msgSentLarge :: TVar Int,
msgRecv :: TVar Int,
msgRecvGet :: TVar Int,
msgGet :: TVar Int,
msgGetNoMsg :: TVar Int,
msgGetAuth :: TVar Int,
msgGetDuplicate :: TVar Int,
msgGetProhibited :: TVar Int,
msgExpired :: TVar Int,
activeQueues :: PeriodStats RecipientId,
msgSentNtf :: TVar Int,
msgRecvNtf :: TVar Int,
msgSentNtf :: TVar Int, -- sent messages with NTF flag
msgRecvNtf :: TVar Int, -- received messages with NTF flag
activeQueuesNtf :: PeriodStats RecipientId,
msgNtfs :: TVar Int, -- messages notications delivered to NTF server (<= msgSentNtf)
msgNtfNoSub :: TVar Int, -- no subscriber to notifications (e.g., NTF server not connected)
msgNtfLost :: TVar Int, -- notification is lost because NTF delivery queue is full
pRelays :: ProxyStats,
pRelaysOwn :: ProxyStats,
pMsgFwds :: ProxyStats,
@@ -57,6 +67,7 @@ data ServerStatsData = ServerStatsData
_qDeletedNew :: Int,
_qDeletedSecured :: Int,
_qSub :: Int,
_qSubNoMsg :: Int,
_qSubAuth :: Int,
_qSubDuplicate :: Int,
_qSubProhibited :: Int,
@@ -65,11 +76,20 @@ data ServerStatsData = ServerStatsData
_msgSentQuota :: Int,
_msgSentLarge :: Int,
_msgRecv :: Int,
_msgRecvGet :: Int,
_msgGet :: Int,
_msgGetNoMsg :: Int,
_msgGetAuth :: Int,
_msgGetDuplicate :: Int,
_msgGetProhibited :: Int,
_msgExpired :: Int,
_activeQueues :: PeriodStatsData RecipientId,
_msgSentNtf :: Int,
_msgRecvNtf :: Int,
_activeQueuesNtf :: PeriodStatsData RecipientId,
_msgNtfs :: Int,
_msgNtfNoSub :: Int,
_msgNtfLost :: Int,
_pRelays :: ProxyStatsData,
_pRelaysOwn :: ProxyStatsData,
_pMsgFwds :: ProxyStatsData,
@@ -89,6 +109,7 @@ newServerStats ts = do
qDeletedNew <- newTVar 0
qDeletedSecured <- newTVar 0
qSub <- newTVar 0
qSubNoMsg <- newTVar 0
qSubAuth <- newTVar 0
qSubDuplicate <- newTVar 0
qSubProhibited <- newTVar 0
@@ -97,11 +118,20 @@ newServerStats ts = do
msgSentQuota <- newTVar 0
msgSentLarge <- newTVar 0
msgRecv <- newTVar 0
msgRecvGet <- newTVar 0
msgGet <- newTVar 0
msgGetNoMsg <- newTVar 0
msgGetAuth <- newTVar 0
msgGetDuplicate <- newTVar 0
msgGetProhibited <- newTVar 0
msgExpired <- newTVar 0
activeQueues <- newPeriodStats
msgSentNtf <- newTVar 0
msgRecvNtf <- newTVar 0
activeQueuesNtf <- newPeriodStats
msgNtfs <- newTVar 0
msgNtfNoSub <- newTVar 0
msgNtfLost <- newTVar 0
pRelays <- newProxyStats
pRelaysOwn <- newProxyStats
pMsgFwds <- newProxyStats
@@ -109,7 +139,46 @@ newServerStats ts = do
pMsgFwdsRecv <- newTVar 0
qCount <- newTVar 0
msgCount <- newTVar 0
pure ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, qSub, qSubAuth, qSubDuplicate, qSubProhibited, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv, qCount, msgCount}
pure
ServerStats
{ fromTime,
qCreated,
qSecured,
qDeletedAll,
qDeletedNew,
qDeletedSecured,
qSub,
qSubNoMsg,
qSubAuth,
qSubDuplicate,
qSubProhibited,
msgSent,
msgSentAuth,
msgSentQuota,
msgSentLarge,
msgRecv,
msgRecvGet,
msgGet,
msgGetNoMsg,
msgGetAuth,
msgGetDuplicate,
msgGetProhibited,
msgExpired,
activeQueues,
msgSentNtf,
msgRecvNtf,
activeQueuesNtf,
msgNtfs,
msgNtfNoSub,
msgNtfLost,
pRelays,
pRelaysOwn,
pMsgFwds,
pMsgFwdsOwn,
pMsgFwdsRecv,
qCount,
msgCount
}
getServerStatsData :: ServerStats -> STM ServerStatsData
getServerStatsData s = do
@@ -120,19 +189,29 @@ getServerStatsData s = do
_qDeletedNew <- readTVar $ qDeletedNew s
_qDeletedSecured <- readTVar $ qDeletedSecured s
_qSub <- readTVar $ qSub s
_qSubNoMsg <- readTVar $ qSubNoMsg s
_qSubAuth <- readTVar $ qSubAuth s
_qSubDuplicate <- readTVar $ qSubDuplicate s
_qSubDuplicate <- readTVar $ qSubDuplicate s
_qSubProhibited <- readTVar $ qSubProhibited s
_msgSent <- readTVar $ msgSent s
_msgSentAuth <- readTVar $ msgSentAuth s
_msgSentQuota <- readTVar $ msgSentQuota s
_msgSentLarge <- readTVar $ msgSentLarge s
_msgRecv <- readTVar $ msgRecv s
_msgRecvGet <- readTVar $ msgRecvGet s
_msgGet <- readTVar $ msgGet s
_msgGetNoMsg <- readTVar $ msgGetNoMsg s
_msgGetAuth <- readTVar $ msgGetAuth s
_msgGetDuplicate <- readTVar $ msgGetDuplicate s
_msgGetProhibited <- readTVar $ msgGetProhibited s
_msgExpired <- readTVar $ msgExpired s
_activeQueues <- getPeriodStatsData $ activeQueues s
_msgSentNtf <- readTVar $ msgSentNtf s
_msgRecvNtf <- readTVar $ msgRecvNtf s
_activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
_msgNtfs <- readTVar $ msgNtfs s
_msgNtfNoSub <- readTVar $ msgNtfNoSub s
_msgNtfLost <- readTVar $ msgNtfLost s
_pRelays <- getProxyStatsData $ pRelays s
_pRelaysOwn <- getProxyStatsData $ pRelaysOwn s
_pMsgFwds <- getProxyStatsData $ pMsgFwds s
@@ -140,7 +219,46 @@ getServerStatsData s = do
_pMsgFwdsRecv <- readTVar $ pMsgFwdsRecv s
_qCount <- readTVar $ qCount s
_msgCount <- readTVar $ msgCount s
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _qSub, _qSubAuth, _qSubDuplicate, _qSubProhibited, _msgSent, _msgSentAuth, _msgSentQuota, _msgSentLarge, _msgRecv, _msgExpired, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _pRelays, _pRelaysOwn, _pMsgFwds, _pMsgFwdsOwn, _pMsgFwdsRecv, _qCount, _msgCount}
pure
ServerStatsData
{ _fromTime,
_qCreated,
_qSecured,
_qDeletedAll,
_qDeletedNew,
_qDeletedSecured,
_qSub,
_qSubNoMsg,
_qSubAuth,
_qSubDuplicate,
_qSubProhibited,
_msgSent,
_msgSentAuth,
_msgSentQuota,
_msgSentLarge,
_msgRecv,
_msgRecvGet,
_msgGet,
_msgGetNoMsg,
_msgGetAuth,
_msgGetDuplicate,
_msgGetProhibited,
_msgExpired,
_activeQueues,
_msgSentNtf,
_msgRecvNtf,
_activeQueuesNtf,
_msgNtfs,
_msgNtfNoSub,
_msgNtfLost,
_pRelays,
_pRelaysOwn,
_pMsgFwds,
_pMsgFwdsOwn,
_pMsgFwdsRecv,
_qCount,
_msgCount
}
setServerStats :: ServerStats -> ServerStatsData -> STM ()
setServerStats s d = do
@@ -151,7 +269,8 @@ setServerStats s d = do
writeTVar (qDeletedNew s) $! _qDeletedNew d
writeTVar (qDeletedSecured s) $! _qDeletedSecured d
writeTVar (qSub s) $! _qSub d
writeTVar (qSubAuth s) $! _qSubAuth d
writeTVar (qSubNoMsg s) $! _qSubNoMsg d
writeTVar (qSubAuth s) $! _qSubAuth d
writeTVar (qSubDuplicate s) $! _qSubDuplicate d
writeTVar (qSubProhibited s) $! _qSubProhibited d
writeTVar (msgSent s) $! _msgSent d
@@ -159,11 +278,20 @@ setServerStats s d = do
writeTVar (msgSentQuota s) $! _msgSentQuota d
writeTVar (msgSentLarge s) $! _msgSentLarge d
writeTVar (msgRecv s) $! _msgRecv d
writeTVar (msgRecvGet s) $! _msgRecvGet d
writeTVar (msgGet s) $! _msgGet d
writeTVar (msgGetNoMsg s) $! _msgGetNoMsg d
writeTVar (msgGetAuth s) $! _msgGetAuth d
writeTVar (msgGetDuplicate s) $! _msgGetDuplicate d
writeTVar (msgGetProhibited s) $! _msgGetProhibited d
writeTVar (msgExpired s) $! _msgExpired d
setPeriodStats (activeQueues s) (_activeQueues d)
writeTVar (msgSentNtf s) $! _msgSentNtf d
writeTVar (msgRecvNtf s) $! _msgRecvNtf d
setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
writeTVar (msgNtfs s) $! _msgNtfs d
writeTVar (msgNtfNoSub s) $! _msgNtfNoSub d
writeTVar (msgNtfLost s) $! _msgNtfLost d
setProxyStats (pRelays s) $! _pRelays d
setProxyStats (pRelaysOwn s) $! _pRelaysOwn d
setProxyStats (pMsgFwds s) $! _pMsgFwds d
@@ -183,6 +311,7 @@ instance StrEncoding ServerStatsData where
"qDeletedSecured=" <> strEncode (_qDeletedSecured d),
"qCount=" <> strEncode (_qCount d),
"qSub=" <> strEncode (_qSub d),
"qSubNoMsg=" <> strEncode (_qSubNoMsg d),
"qSubAuth=" <> strEncode (_qSubAuth d),
"qSubDuplicate=" <> strEncode (_qSubDuplicate d),
"qSubProhibited=" <> strEncode (_qSubProhibited d),
@@ -191,9 +320,18 @@ instance StrEncoding ServerStatsData where
"msgSentQuota=" <> strEncode (_msgSentQuota d),
"msgSentLarge=" <> strEncode (_msgSentLarge d),
"msgRecv=" <> strEncode (_msgRecv d),
"msgRecvGet=" <> strEncode (_msgRecvGet d),
"msgGet=" <> strEncode (_msgGet d),
"msgGetNoMsg=" <> strEncode (_msgGetNoMsg d),
"msgGetAuth=" <> strEncode (_msgGetAuth d),
"msgGetDuplicate=" <> strEncode (_msgGetDuplicate d),
"msgGetProhibited=" <> strEncode (_msgGetProhibited d),
"msgExpired=" <> strEncode (_msgExpired d),
"msgSentNtf=" <> strEncode (_msgSentNtf d),
"msgRecvNtf=" <> strEncode (_msgRecvNtf d),
"msgNtfs=" <> strEncode (_msgNtfs d),
"msgNtfNoSub=" <> strEncode (_msgNtfNoSub d),
"msgNtfLost=" <> strEncode (_msgNtfLost d),
"activeQueues:",
strEncode (_activeQueues d),
"activeQueuesNtf:",
@@ -217,6 +355,7 @@ instance StrEncoding ServerStatsData where
<|> ((,,) <$> ("qDeletedAll=" *> strP <* A.endOfLine) <*> ("qDeletedNew=" *> strP <* A.endOfLine) <*> ("qDeletedSecured=" *> strP <* A.endOfLine))
_qCount <- opt "qCount="
_qSub <- opt "qSub="
_qSubNoMsg <- opt "qSubNoMsg="
_qSubAuth <- opt "qSubAuth="
_qSubDuplicate <- opt "qSubDuplicate="
_qSubProhibited <- opt "qSubProhibited="
@@ -225,9 +364,18 @@ instance StrEncoding ServerStatsData where
_msgSentQuota <- opt "msgSentQuota="
_msgSentLarge <- opt "msgSentLarge="
_msgRecv <- "msgRecv=" *> strP <* A.endOfLine
_msgRecvGet <- opt "msgRecvGet="
_msgGet <- opt "msgGet="
_msgGetNoMsg <- opt "msgGetNoMsg="
_msgGetAuth <- opt "msgGetAuth="
_msgGetDuplicate <- opt "msgGetDuplicate="
_msgGetProhibited <- opt "msgGetProhibited="
_msgExpired <- opt "msgExpired="
_msgSentNtf <- opt "msgSentNtf="
_msgRecvNtf <- opt "msgRecvNtf="
_msgNtfs <- opt "msgNtfs="
_msgNtfNoSub <- opt "msgNtfNoSub="
_msgNtfLost <- opt "msgNtfLost="
_activeQueues <-
optional ("activeQueues:" <* A.endOfLine) >>= \case
Just _ -> strP <* optional A.endOfLine
@@ -245,7 +393,46 @@ instance StrEncoding ServerStatsData where
_pMsgFwds <- proxyStatsP "pMsgFwds:"
_pMsgFwdsOwn <- proxyStatsP "pMsgFwdsOwn:"
_pMsgFwdsRecv <- opt "pMsgFwdsRecv="
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _qSub, _qSubAuth, _qSubDuplicate, _qSubProhibited, _msgSent, _msgSentAuth, _msgSentQuota, _msgSentLarge, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _pRelays, _pRelaysOwn, _pMsgFwds, _pMsgFwdsOwn, _pMsgFwdsRecv, _qCount, _msgCount = 0}
pure
ServerStatsData
{ _fromTime,
_qCreated,
_qSecured,
_qDeletedAll,
_qDeletedNew,
_qDeletedSecured,
_qSub,
_qSubNoMsg,
_qSubAuth,
_qSubDuplicate,
_qSubProhibited,
_msgSent,
_msgSentAuth,
_msgSentQuota,
_msgSentLarge,
_msgRecv,
_msgRecvGet,
_msgGet,
_msgGetNoMsg,
_msgGetAuth,
_msgGetDuplicate,
_msgGetProhibited,
_msgExpired,
_msgSentNtf,
_msgRecvNtf,
_msgNtfs,
_msgNtfNoSub,
_msgNtfLost,
_activeQueues,
_activeQueuesNtf,
_pRelays,
_pRelaysOwn,
_pMsgFwds,
_pMsgFwdsOwn,
_pMsgFwdsRecv,
_qCount,
_msgCount = 0
}
where
opt s = A.string s *> strP <* A.endOfLine <|> pure 0
proxyStatsP key =
+5 -2
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
@@ -53,7 +54,7 @@ data StoreLogRecord
| DeleteNotifier QueueId
instance StrEncoding QueueRec where
strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier} =
strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier} =
B.unwords
[ "rid=" <> strEncode recipientId,
"rk=" <> strEncode recipientKey,
@@ -61,6 +62,7 @@ instance StrEncoding QueueRec where
"sid=" <> strEncode senderId,
"sk=" <> strEncode senderKey
]
<> if sndSecure then " sndSecure=" <> strEncode sndSecure else ""
<> maybe "" notifierStr notifier
where
notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds
@@ -71,8 +73,9 @@ instance StrEncoding QueueRec where
rcvDhSecret <- "rdh=" *> strP_
senderId <- "sid=" *> strP_
senderKey <- "sk=" *> strP
sndSecure <- (" sndSecure=" *> strP) <|> pure False
notifier <- optional $ " notifier=" *> strP
pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier, status = QueueActive}
pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive}
instance StrEncoding StoreLogRecord where
strEncode = \case
+14 -6
View File
@@ -46,6 +46,7 @@ module Simplex.Messaging.Transport
subModeSMPVersion,
authCmdsSMPVersion,
sendingProxySMPVersion,
sndAuthKeySMPVersion,
simplexMQVersion,
smpBlockSize,
TransportConfig (..),
@@ -83,7 +84,7 @@ module Simplex.Messaging.Transport
where
import Control.Applicative (optional)
import Control.Monad (forM)
import Control.Monad (forM, (<$!>))
import Control.Monad.Except
import Control.Monad.Trans.Except (throwE)
import qualified Data.Aeson.TH as J
@@ -156,14 +157,17 @@ authCmdsSMPVersion = VersionSMP 7
sendingProxySMPVersion :: VersionSMP
sendingProxySMPVersion = VersionSMP 8
sndAuthKeySMPVersion :: VersionSMP
sndAuthKeySMPVersion = VersionSMP 9
currentClientSMPRelayVersion :: VersionSMP
currentClientSMPRelayVersion = VersionSMP 8
currentClientSMPRelayVersion = VersionSMP 9
legacyServerSMPRelayVersion :: VersionSMP
legacyServerSMPRelayVersion = VersionSMP 6
currentServerSMPRelayVersion :: VersionSMP
currentServerSMPRelayVersion = VersionSMP 8
currentServerSMPRelayVersion = VersionSMP 9
-- Max SMP protocol version to be used in e2e encrypted
-- connection between client and server, as defined by SMP proxy.
@@ -171,7 +175,7 @@ currentServerSMPRelayVersion = VersionSMP 8
-- to prevent client version fingerprinting by the
-- destination relays when clients upgrade at different times.
proxiedSMPRelayVersion :: VersionSMP
proxiedSMPRelayVersion = VersionSMP 8
proxiedSMPRelayVersion = VersionSMP 9
-- minimal supported protocol version is 4
-- TODO remove code that supports sending commands without batching
@@ -540,12 +544,12 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do
smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer
smpTHandleServer th v vr pk k_ =
let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$> k_}
let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_}
in smpTHandle_ th v vr (Just thAuth)
smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleSMP c 'TClient
smpTHandleClient th v vr pk_ ck_ =
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = C.dh' k <$> pk_}) <$> ck_
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = forceCertChain ck, sessSecret = C.dh' k <$!> pk_}) <$!> ck_
in smpTHandle_ th v vr thAuth
smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> THandleSMP c p
@@ -554,6 +558,10 @@ smpTHandle_ th@THandle {params} v vr thAuth =
let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion}
in (th :: THandleSMP c p) {params = params'}
{-# INLINE forceCertChain #-}
forceCertChain :: (X.CertificateChain, X.SignedExact T.PubKey) -> (X.CertificateChain, X.SignedExact T.PubKey)
forceCertChain cert@(X.CertificateChain cc, signedKey) = length (show cc) `seq` show signedKey `seq` cert
-- This function is only used with v >= 8, so currently it's a simple record update.
-- It may require some parameters update in the future, to be consistent with smpTHandle_.
smpTHParamsSetVersion :: VersionSMP -> THandleParams SMPVersion p -> THandleParams SMPVersion p
+10 -1
View File
@@ -8,16 +8,19 @@ import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Except
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64)
import Data.List (groupBy, sortOn)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Time (NominalDiffTime)
import GHC.Conc (labelThread, myThreadId, threadDelay)
import UnliftIO
@@ -170,3 +173,9 @@ diffToMilliseconds diff = fromIntegral ((truncate $ diff * 1000) :: Integer)
labelMyThread :: MonadIO m => String -> m ()
labelMyThread label = liftIO $ myThreadId >>= (`labelThread` label)
encodeJSON :: ToJSON a => a -> Text
encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode
decodeJSON :: FromJSON a => Text -> Maybe a
decodeJSON = J.decode . LB.fromStrict . encodeUtf8
+175 -121
View File
@@ -7,7 +7,12 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module AgentTests.ConnectionRequestTests where
module AgentTests.ConnectionRequestTests
( connectionRequestTests,
connReqData,
queueAddr,
testE2ERatchetParams12,
) where
import Data.ByteString (ByteString)
import Network.HTTP.Types (urlEncode)
@@ -15,179 +20,228 @@ import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtocolServer (..), pattern VersionSMPC, supportedSMPClientVRange)
import Simplex.Messaging.Protocol (ProtocolServer (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC)
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
import Simplex.Messaging.Version
import Test.Hspec
uri :: String
uri = "smp.simplex.im"
srv :: SMPServer
srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251")
srv = SMPServer "smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" "5223" (C.KeyHash "\215m\248\251")
srv1 :: SMPServer
srv1 = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251")
queueAddr :: SMPQueueAddress
queueAddr =
SMPQueueAddress
{ smpServer = srv,
senderId = "\223\142z\251",
dhPublicKey = testDhKey
dhPublicKey = testDhKey,
sndSecure = False
}
queueAddrSK :: SMPQueueAddress
queueAddrSK = queueAddr {sndSecure = True}
queueAddr1 :: SMPQueueAddress
queueAddr1 = queueAddr {smpServer = srv1}
queueAddrNoPort :: SMPQueueAddress
queueAddrNoPort = queueAddr {smpServer = srv {port = ""}}
queueAddrNoPort1 :: SMPQueueAddress
queueAddrNoPort1 = queueAddr {smpServer = srv1 {port = ""}}
-- current version range includes version 1 and it uses legacy encoding
queue :: SMPQueueUri
queue = SMPQueueUri supportedSMPClientVRange queueAddr
queueSK :: SMPQueueUri
queueSK = SMPQueueUri supportedSMPClientVRange queueAddrSK
queueStr :: ByteString
queueStr = "smp://[email protected]:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion"
queueStrSK :: ByteString
queueStrSK = "smp://[email protected]:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr <> "&k=s" <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion"
queue1 :: SMPQueueUri
queue1 = SMPQueueUri supportedSMPClientVRange queueAddr1
queue1Str :: ByteString
queue1Str = "smp://[email protected]:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr
queueV1 :: SMPQueueUri
queueV1 = SMPQueueUri (mkVersionRange (VersionSMPC 1) (VersionSMPC 1)) queueAddr
queueV1NoPort :: SMPQueueUri
queueV1NoPort = (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort}
-- version range 2-3 uses new encoding
-- it is fixed/changed in v5.8.2.
queueNew :: SMPQueueUri
queueNew = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr
queueNewStr :: ByteString
queueNewStr = "smp://[email protected],jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr
queueNewStr' :: ByteString
queueNewStr' = "smp://[email protected],jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-3&dh=" <> testDhKeyStr
queueNewNoPort :: SMPQueueUri
queueNewNoPort = (queueNew :: SMPQueueUri) {queueAddress = queueAddrNoPort}
queueNew1 :: SMPQueueUri
queueNew1 = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr1
queueNew1Str :: ByteString
queueNew1Str = "smp://[email protected]:5223/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr
queueNew1NoPort :: SMPQueueUri
queueNew1NoPort = (queueNew1 :: SMPQueueUri) {queueAddress = queueAddrNoPort1}
testDhKey :: C.PublicKeyX25519
testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
testDhKeyStr :: ByteString
testDhKeyStr = strEncode testDhKey
testDhKeyStrUri :: ByteString
testDhKeyStrUri = urlEncode True testDhKeyStr
connReqData :: ConnReqUriData
connReqData =
ConnReqUriData
{ crScheme = SSSimplex,
crAgentVRange = mkVersionRange (VersionSMPA 2) (VersionSMPA 2),
crSmpQueues = [queueV1],
crAgentVRange = supportedSMPAgentVRange,
crSmpQueues = [queue],
crClientData = Nothing
}
connReqDataSK :: ConnReqUriData
connReqDataSK = connReqData {crSmpQueues = [queueSK]}
connReqData1 :: ConnReqUriData
connReqData1 = connReqData {crSmpQueues = [queue1]}
connReqDataV1 :: ConnReqUriData
connReqDataV1 = connReqData {crAgentVRange = mkVersionRange (VersionSMPA 1) (VersionSMPA 1)}
connReqDataV2 :: ConnReqUriData
connReqDataV2 = connReqData {crAgentVRange = mkVersionRange (VersionSMPA 2) (VersionSMPA 2)}
connReqDataNew :: ConnReqUriData
connReqDataNew = connReqData {crSmpQueues = [queueNew]}
connReqDataNew1 :: ConnReqUriData
connReqDataNew1 = connReqData {crSmpQueues = [queueNew1]}
testDhPubKey :: C.PublicKeyX448
testDhPubKey = "MEIwBQYDK2VvAzkAmKuSYeQ/m0SixPDS8Wq8VBaTS1cW+Lp0n0h4Diu+kUpR+qXx4SDJ32YGEFoGFGSbGPry5Ychr6U="
testE2ERatchetParams :: RcvE2ERatchetParamsUri 'C.X448
testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange (VersionE2E 1) (VersionE2E 1)) testDhPubKey testDhPubKey Nothing
testE2ERatchetParamsStrUri :: ByteString
testE2ERatchetParamsStrUri = "v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
testE2ERatchetParams12 :: RcvE2ERatchetParamsUri 'C.X448
testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey Nothing
connectionRequest :: AConnectionRequestUri
connectionRequest =
ACR SCMInvitation $
CRInvitationUri connReqData testE2ERatchetParams
connectionRequest = ACR SCMInvitation $ CRInvitationUri connReqData testE2ERatchetParams
connectionRequestSK :: AConnectionRequestUri
connectionRequestSK = ACR SCMInvitation $ CRInvitationUri connReqDataSK testE2ERatchetParams
connectionRequestV1 :: AConnectionRequestUri
connectionRequestV1 = ACR SCMInvitation $ CRInvitationUri connReqDataV1 testE2ERatchetParams
connectionRequest1 :: AConnectionRequestUri
connectionRequest1 = ACR SCMInvitation $ CRInvitationUri connReqData1 testE2ERatchetParams
connectionRequestNew :: AConnectionRequestUri
connectionRequestNew = ACR SCMInvitation $ CRInvitationUri connReqDataNew testE2ERatchetParams
connectionRequestNew1 :: AConnectionRequestUri
connectionRequestNew1 = ACR SCMInvitation $ CRInvitationUri connReqDataNew1 testE2ERatchetParams
contactAddress :: AConnectionRequestUri
contactAddress = ACR SCMContact $ CRContactUri connReqData
connectionRequestCurrentRange :: AConnectionRequestUri
connectionRequestCurrentRange =
ACR SCMInvitation $
CRInvitationUri
connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]}
testE2ERatchetParams12
contactAddressV2 :: AConnectionRequestUri
contactAddressV2 = ACR SCMContact $ CRContactUri connReqDataV2
contactAddressNew :: AConnectionRequestUri
contactAddressNew = ACR SCMContact $ CRContactUri connReqDataNew
connectionRequest2queues :: AConnectionRequestUri
connectionRequest2queues = ACR SCMInvitation $ CRInvitationUri connReqData {crSmpQueues = [queue, queue]} testE2ERatchetParams
connectionRequest2queuesNew :: AConnectionRequestUri
connectionRequest2queuesNew = ACR SCMInvitation $ CRInvitationUri connReqDataNew {crSmpQueues = [queueNew, queueNew]} testE2ERatchetParams
contactAddress2queues :: AConnectionRequestUri
contactAddress2queues = ACR SCMContact $ CRContactUri connReqData {crSmpQueues = [queue, queue]}
contactAddress2queuesNew :: AConnectionRequestUri
contactAddress2queuesNew = ACR SCMContact $ CRContactUri connReqDataNew {crSmpQueues = [queueNew, queueNew]}
connectionRequestClientDataEmpty :: AConnectionRequestUri
connectionRequestClientDataEmpty =
ACR SCMInvitation $
CRInvitationUri connReqData {crClientData = Just "{}"} testE2ERatchetParams
connectionRequestClientDataEmpty = ACR SCMInvitation $ CRInvitationUri connReqData {crClientData = Just "{}"} testE2ERatchetParams
connectionRequestClientData :: AConnectionRequestUri
connectionRequestClientData =
ACR SCMInvitation $
CRInvitationUri connReqData {crClientData = Just "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}"} testE2ERatchetParams
contactAddressClientData :: AConnectionRequestUri
contactAddressClientData = ACR SCMContact $ CRContactUri connReqData {crClientData = Just "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}"}
url :: ByteString -> ByteString
url = urlEncode True
(==#) :: (StrEncoding a, HasCallStack) => a -> ByteString -> Expectation
a ==# s = strEncode a `shouldBe` s
(#==) :: (StrEncoding a, Eq a, Show a, HasCallStack) => a -> ByteString -> Expectation
a #== s = strDecode s `shouldBe` Right a
(#==#) :: (StrEncoding a, Eq a, Show a, HasCallStack) => a -> ByteString -> Expectation
a #==# s = do
a ==# s
a #== s
connectionRequestTests :: Spec
connectionRequestTests =
describe "connection request parsing / serializing" $ do
it "should serialize SMP queue URIs" $ do
strEncode (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort}
`shouldBe` "smp://[email protected]/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri
strEncode queue {clientVRange = mkVersionRange (VersionSMPC 1) (VersionSMPC 2)}
`shouldBe` "smp://[email protected]:5223/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri
it "should parse SMP queue URIs" $ do
strDecode ("smp://[email protected]/3456-w==#/?v=1-2&dh=" <> testDhKeyStr)
`shouldBe` Right (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort}
strDecode ("smp://[email protected]/3456-w==#" <> testDhKeyStr)
`shouldBe` Right (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort}
strDecode ("smp://[email protected]:5223/3456-w==#" <> testDhKeyStr)
`shouldBe` Right queueV1
strDecode ("smp://[email protected]:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-2&extra_param=abc")
`shouldBe` Right queue
strDecode ("smp://[email protected]:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr)
`shouldBe` Right queueV1
strDecode ("smp://[email protected]:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc")
`shouldBe` Right queueV1
it "should serialize connection requests" $ do
strEncode connectionRequest
`shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
strEncode connectionRequestCurrentRange
`shouldBe` "simplex:/invitation#/?v=2-5&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
strEncode connectionRequestClientDataEmpty
`shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&data=%7B%7D"
strEncode connectionRequestClientData
`shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D"
it "should parse connection requests" $ do
strDecode
( "https://simplex.chat/contact#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
<> testDhKeyStrUri
<> "&v=1" -- adjusted to v2
)
`shouldBe` Right contactAddress
strDecode
( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
<> testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&v=2"
)
`shouldBe` Right connectionRequest
strDecode
( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&v=2"
)
`shouldBe` Right connectionRequest
strDecode
( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> testDhKeyStrUri
<> "&e2e=v%3D1-1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&v=2-2"
)
`shouldBe` Right connectionRequest
strDecode
( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26extra_param%3Dabc%26dh%3D"
<> testDhKeyStrUri
<> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> testDhKeyStrUri
<> "&e2e=extra_key%3Dnew%26v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&some_new_param=abc"
<> "&v=2-5"
)
`shouldBe` Right connectionRequestCurrentRange
strDecode
( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&data=%7B%7D"
<> "&v=2-2"
)
`shouldBe` Right connectionRequestClientDataEmpty
strDecode
( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D"
<> "&v=2"
)
`shouldBe` Right connectionRequestClientData
it "should serialize and parse SMP queue URIs" $ do
queue #==# queueStr
queue #== ("smp://[email protected]:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-3&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion")
queueSK #==# queueStrSK
queue1 #==# queue1Str
queueNew #==# queueNewStr
queueNew #== queueNewStr'
queueNew1 #==# queueNew1Str
queueNewNoPort #==# ("smp://[email protected],jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr)
queueNew1NoPort #==# ("smp://[email protected]/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr)
queueV1 #==# ("smp://[email protected]:5223/3456-w==#/?v=1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion")
queueV1 #== ("smp://[email protected],jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#" <> testDhKeyStr)
queueV1 #== ("smp://[email protected]:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion")
queueV1 #== ("smp://[email protected]:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion")
queueV1NoPort #==# ("smp://[email protected]/3456-w==#/?v=1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion")
queueV1NoPort #== ("smp://[email protected]/3456-w==#/?v=1-1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion")
queueV1NoPort #== ("smp://[email protected],jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#" <> testDhKeyStr)
it "should serialize and parse connection invitations and contact addresses" $ do
connectionRequest #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
connectionRequest #== ("https://simplex.chat/invitation#/?v=2-7&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
connectionRequestSK #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStrSK <> "&e2e=" <> testE2ERatchetParamsStrUri)
connectionRequest1 #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queue1Str <> "&e2e=" <> testE2ERatchetParamsStrUri)
connectionRequest2queues #==# ("simplex:/invitation#/?v=2-7&smp=" <> url (queueStr <> ";" <> queueStr) <> "&e2e=" <> testE2ERatchetParamsStrUri)
connectionRequestNew #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueNewStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
connectionRequestNew1 #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueNew1Str <> "&e2e=" <> testE2ERatchetParamsStrUri)
connectionRequest2queuesNew #==# ("simplex:/invitation#/?v=2-7&smp=" <> url (queueNewStr <> ";" <> queueNewStr) <> "&e2e=" <> testE2ERatchetParamsStrUri)
connectionRequestV1 #== ("https://simplex.chat/invitation#/?v=1&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri)
connectionRequestClientDataEmpty #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri <> "&data=" <> url "{}")
contactAddress #==# ("simplex:/contact#/?v=2-7&smp=" <> url queueStr)
contactAddress #== ("https://simplex.chat/contact#/?v=2-7&smp=" <> url queueStr)
contactAddress2queues #==# ("simplex:/contact#/?v=2-7&smp=" <> url (queueStr <> ";" <> queueStr))
contactAddressNew #==# ("simplex:/contact#/?v=2-7&smp=" <> url queueNewStr)
contactAddress2queuesNew #==# ("simplex:/contact#/?v=2-7&smp=" <> url (queueNewStr <> ";" <> queueNewStr))
contactAddressV2 #==# ("simplex:/contact#/?v=2&smp=" <> url queueStr)
contactAddressV2 #== ("https://simplex.chat/contact#/?v=1&smp=" <> url queueStr) -- adjusted to v2
contactAddressV2 #== ("https://simplex.chat/contact#/?v=1-2&smp=" <> url queueStr) -- adjusted to v2
contactAddressV2 #== ("https://simplex.chat/contact#/?v=2-2&smp=" <> url queueStr)
contactAddressClientData #==# ("simplex:/contact#/?v=2-7&smp=" <> url queueStr <> "&data=" <> url "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}")
File diff suppressed because it is too large Load Diff
+189 -62
View File
@@ -5,6 +5,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
@@ -12,9 +13,9 @@ module AgentTests.NotificationTests where
-- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
import AgentTests.FunctionalAPITests
( agentCfgV7,
( agentCfgVPrevPQ,
createConnection,
exchangeGreetingsMsgId,
exchangeGreetings,
get,
joinConnection,
makeConnection,
@@ -49,20 +50,22 @@ import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Text.Encoding (encodeUtf8)
import Database.SQLite.Simple.QQ (sql)
import NtfClient
import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2)
import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn)
import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn)
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT)
import Simplex.Messaging.Agent.Store.SQLite (closeSQLiteStore, getSavedNtfToken, reopenSQLiteStore)
import Simplex.Messaging.Agent.Store.SQLite (closeSQLiteStore, getSavedNtfToken, reopenSQLiteStore, withTransaction)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Types (NtfToken (..))
import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..))
import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
@@ -70,7 +73,6 @@ import Simplex.Messaging.Transport (ATransport)
import System.Directory (doesFileExist, removeFile)
import Test.Hspec
import UnliftIO
import Util
removeFileIfExists :: FilePath -> IO ()
removeFileIfExists filePath = do
@@ -89,9 +91,21 @@ notificationTests t = do
it "should allow the second registration with different credentials and delete the first after verification" $
withAPNSMockServer $ \apns ->
withNtfServer t $ testNtfTokenSecondRegistration apns
it "should re-register token when notification server is restarted" $
it "should verify token after notification server is restarted" $
withAPNSMockServer $ \apns ->
testNtfTokenServerRestart t apns
it "should re-verify token after notification server is restarted" $
withAPNSMockServer $ \apns ->
testNtfTokenServerRestartReverify t apns
it "should re-verify token after notification server is restarted when first request timed-out" $
withAPNSMockServer $ \apns ->
testNtfTokenServerRestartReverifyTimeout t apns
it "should re-register token when notification server is restarted" $
withAPNSMockServer $ \apns ->
testNtfTokenServerRestartReregister t apns
it "should re-register token when notification server is restarted when first request timed-out" $
withAPNSMockServer $ \apns ->
testNtfTokenServerRestartReregisterTimeout t apns
it "should work with multiple configured servers" $
withAPNSMockServer $ \apns ->
testNtfTokenMultipleServers t apns
@@ -144,28 +158,26 @@ notificationTests t = do
withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf ->
testNotificationsNewToken apns ntf
testNtfMatrix :: ATransport -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> Spec
testNtfMatrix :: HasCallStack => ATransport -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec
testNtfMatrix t runTest = do
describe "next and current" $ do
it "next servers: SMP v7, NTF v2; next clients: v7/v2" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfgV7 agentCfgV7 runTest
it "next servers: SMP v7, NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfg runTest
it "curr servers: SMP v6, NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfg agentCfg agentCfg runTest
skip "this case cannot be supported - see RFC" $
it "servers: SMP v6, NTF v1; clients: v7/v2 (not supported)" $
runNtfTestCfg t cfg ntfServerCfg agentCfgV7 agentCfgV7 runTest
-- servers can be migrated in any order
it "servers: next SMP v7, curr NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfg agentCfg agentCfg runTest
it "servers: curr SMP v6, next NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfgV2 agentCfg agentCfg runTest
-- clients can be partially migrated
it "servers: next SMP v7, curr NTF v2; clients: next/curr" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfgV7 agentCfg runTest
it "servers: next SMP v7, curr NTF v2; clients: curr/new" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfgV7 runTest
it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest
it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "prev servers; curr clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest
-- servers can be upgraded in any order
it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
-- one of two clients can be upgraded
it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfg agentCfgVPrevPQ runTest
it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfg runTest
runNtfTestCfg :: ATransport -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest = do
runNtfTestCfg :: HasCallStack => ATransport -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg t baseId smpCfg ntfCfg aCfg bCfg runTest = do
withSmpServerConfigOn t smpCfg testPort $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t)]} $ \_ ->
withAgentClientsCfg2 aCfg bCfg $ runTest apns
withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId
threadDelay 100000
testNotificationToken :: APNSMockServer -> IO ()
@@ -254,7 +266,7 @@ testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
withNtfServer t . runRight $ do
withNtfServerStoreLog t $ \_ -> runRight $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
@@ -265,16 +277,131 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
-- so that repeat verification happens without restarting the clients, when notification arrives
withNtfServer t . runRight_ $ do
withNtfServerStoreLog t $ \_ -> runRight_ $ do
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
Left (NTF _ AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
verifyNtfToken a' tkn nonce verification
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReverify :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverify t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a -> do
ntfData <- withNtfServerStoreLog t $ \_ -> runRight $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
verification' <- ntfData' .-> "verification"
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
liftIO $ sendApnsResponse' APNSRespOk
verifyNtfToken a' tkn nonce' verification'
liftIO $ sendApnsResponse APNSRespOk
pure ntfData
runRight_ $ do
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
Left (BROKER _ NETWORK) <- tryE $ verifyNtfToken a tkn nonce verification
pure ()
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
-- so that repeat verification happens without restarting the clients, when notification arrives
withNtfServerStoreLog t $ \_ -> runRight_ $ do
NTActive <- registerNtfToken a' tkn NMPeriodic
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReverifyTimeout :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverifyTimeout t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
(nonce, verification) <- withNtfServerStoreLog t $ \_ -> runRight $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
verifyNtfToken a tkn nonce verification
pure (nonce, verification)
-- this emulates the situation when server verified token but the client did not receive the response
Just NtfToken {ntfTknStatus = NTActive, ntfTknAction = Just NTACheck, ntfDhSecret = Just dhSecret} <- withTransaction store getSavedNtfToken
Right code <- pure $ NtfRegCode <$> C.cbDecrypt dhSecret nonce verification
withTransaction store $ \db ->
DB.execute
db
[sql|
UPDATE ntf_tokens
SET tkn_status = ?, tkn_action = ?
WHERE provider = ? AND device_token = ?
|]
(NTConfirmed, Just (NTAVerify code), PPApnsTest, "abcd" :: ByteString)
Just NtfToken {ntfTknStatus = NTConfirmed, ntfTknAction = Just (NTAVerify _)} <- withTransaction store getSavedNtfToken
pure ()
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
-- so that repeat verification happens without restarting the clients, when notification arrives
withNtfServerStoreLog t $ \_ -> runRight_ $ do
NTActive <- registerNtfToken a' tkn NMPeriodic
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReregister :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregister t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a ->
withNtfServerStoreLog t $ \_ -> runRight $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
-- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, and client might have lost verification notification.
-- so that repeat registration happens when client is restarted.
withNtfServerStoreLog t $ \_ -> runRight_ $ do
NTRegistered <- registerNtfToken a' tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
verifyNtfToken a' tkn nonce verification
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReregisterTimeout :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregisterTimeout t APNSMockServer {apnsQ} = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
withNtfServerStoreLog t $ \_ -> runRight $ do
NTRegistered <- registerNtfToken a tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
-- this emulates the situation when server registered token but the client did not receive the response
withTransaction store $ \db ->
DB.execute
db
[sql|
UPDATE ntf_tokens
SET tkn_id = NULL, tkn_dh_secret = NULL, tkn_status = ?, tkn_action = ?
WHERE provider = ? AND device_token = ?
|]
(NTNew, Just NTARegister, PPApnsTest, "abcd" :: ByteString)
Just NtfToken {ntfTokenId = Nothing, ntfTknStatus = NTNew, ntfTknAction = Just NTARegister} <- withTransaction store getSavedNtfToken
pure ()
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, and client might have lost verification notification.
-- so that repeat registration happens when client is restarted.
withNtfServerStoreLog t $ \_ -> runRight_ $ do
NTRegistered <- registerNtfToken a' tkn NMPeriodic
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
verifyNtfToken a' tkn nonce verification
NTActive <- checkNtfToken a' tkn
pure ()
@@ -345,12 +472,12 @@ testRunNTFServerTests t srv =
withAgent 1 agentCfg initAgentServers testDB $ \a ->
testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
(bobId, aliceId, nonce, message) <- runRight $ do
-- establish connection
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
(aliceId, _sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
("", _, CONF confId _ "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -377,38 +504,37 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen
-- alice client already has subscription for the connection
Left (CMD PROHIBITED _) <- runExceptT $ getNotificationMessage alice nonce message
threadDelay 200000
threadDelay 500000
suspendAgent alice 0
closeSQLiteStore store
threadDelay 200000
threadDelay 1000000
-- aliceNtf client doesn't have subscription and is allowed to get notification message
withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do
(_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
pure ()
threadDelay 200000
threadDelay 1000000
reopenSQLiteStore store
foregroundAgent alice
threadDelay 200000
threadDelay 500000
runRight_ $ do
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId (baseId + 1) Nothing
-- delete notification subscription
toggleConnectionNtfs alice bobId False
liftIO $ threadDelay 250000
liftIO $ threadDelay 500000
-- send message
2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT $ baseId + 2)
-- no notifications should follow
noNotification apnsQ
where
baseId = 3
msgId = subtract baseId
testNotificationSubscriptionNewConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob =
testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} baseId alice bob =
runRight_ $ do
-- alice registers notification token
DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -418,7 +544,7 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob =
liftIO $ threadDelay 50000
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
liftIO $ threadDelay 1000000
aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
(aliceId, _sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
liftIO $ threadDelay 750000
void $ messageNotificationData alice apnsQ
("", _, CONF confId _ "bob's connInfo") <- get alice
@@ -426,9 +552,9 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob =
allowConnection alice bobId confId "alice's connInfo"
void $ messageNotificationData bob apnsQ
get bob ##> ("", aliceId, INFO "alice's connInfo")
void $ messageNotificationData alice apnsQ
when (baseId == 3) $ void $ messageNotificationData alice apnsQ
get alice ##> ("", bobId, CON)
void $ messageNotificationData bob apnsQ
when (baseId == 3) $ void $ messageNotificationData bob apnsQ
get bob ##> ("", aliceId, CON)
-- bob sends message
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
@@ -445,7 +571,6 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob =
-- no unexpected notifications should follow
noNotification apnsQ
where
baseId = 3
msgId = subtract baseId
registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken
@@ -466,7 +591,8 @@ testChangeNotificationsMode APNSMockServer {apnsQ} =
withAgentClients2 $ \alice bob -> runRight_ $ do
-- establish connection
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
(aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
liftIO $ sqSecured `shouldBe` True
("", _, CONF confId _ "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -520,7 +646,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} =
-- no notifications should follow
noNotification apnsQ
where
baseId = 3
baseId = 1
msgId = subtract baseId
testChangeToken :: APNSMockServer -> IO ()
@@ -528,7 +654,8 @@ testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers t
(aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do
-- establish connection
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
(aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
liftIO $ sqSecured `shouldBe` True
("", _, CONF confId _ "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get bob ##> ("", aliceId, INFO "alice's connInfo")
@@ -559,7 +686,7 @@ testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers t
-- no notifications should follow
noNotification apnsQ
where
baseId = 3
baseId = 1
msgId = subtract baseId
testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
@@ -568,11 +695,11 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice
(aliceId, bobId) <- makeConnection alice bob
_ <- registerTestToken alice "abcd" NMInstant apnsQ
liftIO $ threadDelay 250000
4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT 4)
2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT 2)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId 4 Nothing
ackMessage alice bobId 2 Nothing
liftIO $ killThread threadId
pure (aliceId, bobId)
@@ -580,8 +707,8 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice
withNtfServerStoreLog t $ \threadId -> runRight_ $ do
liftIO $ threadDelay 250000
5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT 5)
3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT 3)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
liftIO $ killThread threadId
@@ -592,11 +719,11 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alic
(aliceId, bobId) <- makeConnection alice bob
_ <- registerTestToken alice "abcd" NMInstant apnsQ
liftIO $ threadDelay 250000
4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT 4)
2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT 2)
void $ messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId 4 Nothing
ackMessage alice bobId 2 Nothing
liftIO $ killThread threadId
pure (aliceId, bobId)
@@ -608,8 +735,8 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alic
nGet alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False
nGet bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False
liftIO $ threadDelay 1000000
5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT 5)
3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
get bob ##> ("", aliceId, SENT 3)
_ <- messageNotificationData alice apnsQ
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
liftIO $ killThread threadId
@@ -664,7 +791,7 @@ testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
testSwitchNotifications servers APNSMockServer {apnsQ} =
withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do
(aId, bId) <- makeConnection a b
exchangeGreetingsMsgId 4 a bId b aId
exchangeGreetings a bId b aId
_ <- registerTestToken a "abcd" NMInstant apnsQ
liftIO $ threadDelay 250000
let testMessage msg = do
@@ -739,7 +866,7 @@ messageNotification apnsQ = do
pure (nonce, message)
_ -> error "bad notification"
messageNotificationData :: AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData
messageNotificationData :: HasCallStack => AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData
messageNotificationData c apnsQ = do
(nonce, message) <- messageNotification apnsQ
NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c
+9 -2
View File
@@ -197,6 +197,9 @@ cData1 =
testPrivateAuthKey :: C.APrivateAuthKey
testPrivateAuthKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
testPublicAuthKey :: C.APublicAuthKey
testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe")
testPrivDhKey :: C.PrivateKeyX25519
testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk"
@@ -218,6 +221,7 @@ rcvQueue1 =
e2ePrivKey = testPrivDhKey,
e2eDhSecret = Nothing,
sndId = "2345",
sndSecure = True,
status = New,
dbQueueId = DBNewQueue,
primary = True,
@@ -235,7 +239,8 @@ sndQueue1 =
connId = "conn1",
server = smpServer1,
sndId = "3456",
sndPublicKey = Nothing,
sndSecure = True,
sndPublicKey = testPublicAuthKey,
sndPrivateKey = testPrivateAuthKey,
e2ePubKey = Nothing,
e2eDhSecret = testDhSecret,
@@ -379,7 +384,8 @@ testUpgradeRcvConnToDuplex =
connId = "conn1",
server = SMPServer "smp.simplex.im" "5223" testKeyHash,
sndId = "2345",
sndPublicKey = Nothing,
sndSecure = True,
sndPublicKey = testPublicAuthKey,
sndPrivateKey = testPrivateAuthKey,
e2ePubKey = Nothing,
e2eDhSecret = testDhSecret,
@@ -412,6 +418,7 @@ testUpgradeSndConnToDuplex =
e2ePrivKey = testPrivDhKey,
e2eDhSecret = Nothing,
sndId = "4567",
sndSecure = True,
status = New,
dbQueueId = DBNewQueue,
rcvSwchStatus = Nothing,
+1
View File
@@ -183,6 +183,7 @@ dummyRQ userId server connId =
e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk",
e2eDhSecret = Nothing,
sndId = "",
sndSecure = True,
status = New,
dbQueueId = DBQueueId 0,
primary = True,
+8 -9
View File
@@ -28,7 +28,7 @@ import Network.HTTP.Types (Status)
import qualified Network.HTTP.Types as N
import qualified Network.HTTP2.Server as H
import Network.Socket
import SMPClient (serverBracket)
import SMPClient (prevRange, serverBracket)
import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig)
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
@@ -36,7 +36,6 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Notifications.Protocol (NtfResponse)
import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
import Simplex.Messaging.Notifications.Server.Env
import qualified Simplex.Messaging.Notifications.Server.Env as Env
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
import Simplex.Messaging.Notifications.Transport
@@ -47,7 +46,6 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams)
import Simplex.Messaging.Transport.HTTP2.Server
import Simplex.Messaging.Transport.Server
import qualified Simplex.Messaging.Transport.Server as Server
import Simplex.Messaging.Version (mkVersionRange)
import Test.Hspec
import UnliftIO.Async
import UnliftIO.Concurrent
@@ -108,18 +106,19 @@ ntfServerCfg =
serverStatsLogFile = "tests/ntf-server-stats.daily.log",
serverStatsBackupFile = Nothing,
ntfServerVRange = supportedServerNTFVRange,
transportConfig = defaultTransportServerConfig
transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes}
}
ntfServerCfgV2 :: NtfServerConfig
ntfServerCfgV2 =
ntfServerCfgVPrev :: NtfServerConfig
ntfServerCfgVPrev =
ntfServerCfg
{ ntfServerVRange = mkVersionRange initialNTFVersion authBatchCmdsNTFVersion,
smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}},
Env.transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes}
{ ntfServerVRange = prevRange $ ntfServerVRange ntfServerCfg,
smpAgentCfg = smpAgentCfg' {smpCfg = smpCfg' {serverVRange = prevRange serverVRange'}}
}
where
smpAgentCfg' = smpAgentCfg ntfServerCfg
smpCfg' = smpCfg smpAgentCfg'
serverVRange' = serverVRange smpCfg'
withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t)]}
+16 -9
View File
@@ -11,16 +11,17 @@
module SMPAgentClient where
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import NtfClient (ntfTestPort)
import SMPClient (proxyVRange, testPort)
import SMPClient (proxyVRangeV8, testPort)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback, SMPProxyMode, defaultNetworkConfig, defaultSMPClientConfig)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer)
import Simplex.Messaging.Transport
import XFTPClient (testXFTPServer)
@@ -48,14 +49,14 @@ testNtfServer2 = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6
initAgentServers :: InitialAgentServers
initAgentServers =
InitialAgentServers
{ smp = userServers [noAuthSrv testSMPServer],
{ smp = userServers [testSMPServer],
ntf = [testNtfServer],
xftp = userServers [noAuthSrv testXFTPServer],
xftp = userServers [testXFTPServer],
netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000}
}
initAgentServers2 :: InitialAgentServers
initAgentServers2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer, noAuthSrv testSMPServer2]}
initAgentServers2 = initAgentServers {smp = userServers [testSMPServer, testSMPServer2]}
initAgentServersProxy :: SMPProxyMode -> SMPProxyFallback -> InitialAgentServers
initAgentServersProxy smpProxyMode smpProxyFallback =
@@ -80,8 +81,8 @@ agentCfg =
where
networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000}
agentProxyCfg :: AgentConfig
agentProxyCfg = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRange}}
agentProxyCfgV8 :: AgentConfig
agentProxyCfgV8 = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRangeV8}}
fastRetryInterval :: RetryInterval
fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000}
@@ -89,5 +90,11 @@ fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000}
fastMessageRetryInterval :: RetryInterval2
fastMessageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval}
userServers :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ProtoServerWithAuth p))
userServers srvs = M.fromList [(1, srvs)]
userServers :: NonEmpty (ProtocolServer p) -> Map UserId (NonEmpty (ServerCfg p))
userServers = userServers' . L.map noAuthSrv
userServers' :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ServerCfg p))
userServers' srvs = M.fromList [(1, L.map (presetServerCfg True) srvs)]
noAuthSrvCfg :: ProtocolServer p -> ServerCfg p
noAuthSrvCfg = presetServerCfg True . noAuthSrv
+15 -10
View File
@@ -29,6 +29,7 @@ import qualified Simplex.Messaging.Transport.Client as Client
import Simplex.Messaging.Transport.Server
import qualified Simplex.Messaging.Transport.Server as Server
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
import System.Environment (lookupEnv)
import System.Info (os)
import Test.Hspec
@@ -99,7 +100,6 @@ cfg =
{ transports = [],
smpHandshakeTimeout = 60000000,
tbqSize = 1,
-- serverTbqSize = 1,
msgQueueQuota = 4,
queueIdBytes = 24,
msgIdBytes = 24,
@@ -133,18 +133,26 @@ cfgV7 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVer
cfgV8 :: ServerConfig
cfgV8 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion}
cfgVPrev :: ServerConfig
cfgVPrev = cfg {smpServerVRange = prevRange $ smpServerVRange cfg}
prevRange :: VersionRange v -> VersionRange v
prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)}
prevVersion :: Version v -> Version v
prevVersion (Version v) = Version (v - 1)
proxyCfg :: ServerConfig
proxyCfg =
cfgV7
cfg
{ allowSMPProxy = True,
smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion,
smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {serverVRange = proxyVRange, agreeSecret = True}}
smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True}}
}
where
smpAgentCfg' = smpAgentCfg cfgV7
smpAgentCfg' = smpAgentCfg cfg
proxyVRange :: VersionRangeSMP
proxyVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion
proxyVRangeV8 :: VersionRangeSMP
proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion
withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
@@ -180,9 +188,6 @@ withSmpServerOn t port' = withSmpServerThreadOn t port' . const
withSmpServer :: HasCallStack => ATransport -> IO a -> IO a
withSmpServer t = withSmpServerOn t testPort
withSmpServerV7 :: HasCallStack => ATransport -> IO a -> IO a
withSmpServerV7 t = withSmpServerConfigOn t cfgV7 testPort . const
withSmpServerProxy :: HasCallStack => ATransport -> IO a -> IO a
withSmpServerProxy t = withSmpServerConfigOn t proxyCfg testPort . const
+77 -32
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
@@ -14,9 +15,9 @@ module SMPProxyTests where
import AgentTests.EqInstances ()
import AgentTests.FunctionalAPITests
import Control.Concurrent (ThreadId)
import Control.Concurrent (ThreadId, threadDelay)
import Control.Logger.Simple
import Control.Monad (forM, forM_, forever)
import Control.Monad (forM, forM_, forever, replicateM_)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.ByteString.Char8 (ByteString)
import Data.List.NonEmpty (NonEmpty)
@@ -33,12 +34,14 @@ import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (bshow, tshow)
import Simplex.Messaging.Version (mkVersionRange)
import System.FilePath (splitExtensions)
import System.Random (randomRIO)
import Test.Hspec
import UnliftIO
import Util
@@ -82,6 +85,10 @@ smpProxyTests = do
it "1x1000" . twoServersFirstProxy $ deliver 1000
it "5x200" . twoServersFirstProxy $ 5 `inParrallel` deliver 200
it "10x100" . twoServersFirstProxy $ 10 `inParrallel` deliver 100
describe "stress test - no host" $ do
it "1x1000, no delay" . oneServer $ proxyConnectDeadRelay 1000 0 srv1
xit "1x1000, 100ms" . oneServer $ proxyConnectDeadRelay 1000 100000 srv1
xit "100x1000, 100ms" . oneServer $ 100 `inParrallel` (randomRIO (0, 1000000) >>= threadDelay >> proxyConnectDeadRelay 1000 100000 srv1)
xdescribe "stress test 10k" $ do
let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n])
it "1x10000" . twoServersFirstProxy $ deliver 10000
@@ -96,26 +103,28 @@ smpProxyTests = do
describe "agent API" $ do
describe "one server" $ do
it "always via proxy" . oneServer $
agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2"
agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1
it "without proxy" . oneServer $
agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2"
agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1
describe "two servers" $ do
it "always via proxy" . twoServers $
agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2"
agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1
it "both via proxy" . twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2"
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" 1
it "first via proxy" . twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2"
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1
it "without proxy" . twoServers $
agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2"
agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1
it "first via proxy for unknown" . twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2"
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 1
it "without proxy with fallback" . twoServers_ proxyCfg cfgV7 $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2"
agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 3
it "fails when fallback is prohibited" . twoServers_ proxyCfg cfgV7 $
agentViaProxyVersionError
it "retries sending when destination or proxy relay is offline" $
agentViaProxyRetryOffline
it "retries sending when destination relay session disconnects in proxy" $
agentViaProxyRetryNoSession
describe "stress test 1k" $ do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
it "2 agents, 250 messages" . oneServer $ deliver 2 250
@@ -151,7 +160,7 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
-- prepare receiving queue
(rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
(rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe
SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe False
let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv
-- get proxy session
sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct")
@@ -179,12 +188,27 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
runExceptT' $ ackSMPMessage rc rPriv rcvId msgId'
)
agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> IO ()
agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 =
proxyConnectDeadRelay :: Int -> Int -> SMPServer -> IO ()
proxyConnectDeadRelay n d proxyServ = do
g <- C.newRandom
-- set up proxy
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ())
pc <- either (fail . show) pure pc'
THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
-- get proxy session
replicateM_ n $ do
sess0 <- runExceptT $ connectSMPProxiedRelay pc (SMPServer testHost "45678" testKeyHash) (Just "correct")
case sess0 of
Right !_noWay -> error "got unexpected client"
Left !_err -> threadDelay d
agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO ()
agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId =
withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
(aliceId, sqSecured) <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
liftIO $ sqSecured `shouldBe` True
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` PQSupportOn
allowConnection alice bobId confId "alice's connInfo"
@@ -212,10 +236,9 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b
get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False
ackMessage alice bobId (baseId + 4) Nothing
where
baseId = 3
msgId = subtract baseId . fst
aCfg = agentProxyCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg}
servers (srvs, smpProxyMode, _) = (initAgentServersProxy smpProxyMode SPFAllow) {smp = userServers $ L.map noAuthSrv srvs}
aCfg = agentCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg}
servers (srvs, smpProxyMode, _) = (initAgentServersProxy smpProxyMode SPFAllow) {smp = userServers srvs}
agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO ()
agentDeliverMessagesViaProxyConc agentServers msgs =
@@ -239,7 +262,8 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
-- otherwise the CONF messages would get mixed with MSG
prePair alice bob = do
(bobId, qInfo) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
aliceId <- runExceptT' $ A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
(aliceId, sqSecured) <- runExceptT' $ A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
liftIO $ sqSecured `shouldBe` True
confId <-
get alice >>= \case
("", _, A.CONF confId pqSup' _ "bob's connInfo") -> do
@@ -279,19 +303,19 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
Left (Left e) -> cancel aSender >> throwIO e
logDebug "run finished"
pqEnc = CR.PQEncOn
aCfg = agentProxyCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448}
servers srvs = (initAgentServersProxy SPMAlways SPFAllow) {smp = userServers $ L.map noAuthSrv srvs}
aCfg = agentCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448}
servers srvs = (initAgentServersProxy SPMAlways SPFAllow) {smp = userServers srvs}
agentViaProxyVersionError :: IO ()
agentViaProxyVersionError =
withAgent 1 agentProxyCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do
withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do
Left (A.BROKER _ (TRANSPORT TEVersion)) <-
withAgent 2 agentProxyCfg (servers [SMPServer testHost testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do
withAgent 2 agentCfg (servers [SMPServer testHost testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do
(_bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
pure ()
where
servers srvs = (initAgentServersProxy SPMUnknown SPFProhibit) {smp = userServers $ L.map noAuthSrv srvs}
servers srvs = (initAgentServersProxy SPMUnknown SPFProhibit) {smp = userServers srvs}
agentViaProxyRetryOffline :: IO ()
agentViaProxyRetryOffline = do
@@ -307,7 +331,8 @@ agentViaProxyRetryOffline = do
withServer $ \_ -> do
(aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
(aliceId, sqSecured) <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
liftIO $ sqSecured `shouldBe` True
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` PQSupportOn
allowConnection alice bobId confId "alice's connInfo"
@@ -350,23 +375,43 @@ agentViaProxyRetryOffline = do
withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs} port
a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False
a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False
aCfg = agentProxyCfg {messageRetryInterval = fastMessageRetryInterval}
baseId = 3
aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval}
baseId = 1
msgId = subtract baseId . fst
servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers $ L.map noAuthSrv [srv]}
servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]}
agentViaProxyRetryNoSession :: IO ()
agentViaProxyRetryNoSession = do
let srv1 = SMPServer testHost testPort testKeyHash
srv2 = SMPServer testHost testPort2 testKeyHash
withAgent 1 agentCfg (servers srv1) testDB $ \a ->
withAgent 2 agentCfg (servers srv2) testDB2 $ \b -> do
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> do
(aId, _) <- withServer2 $ \_ -> runRight $ makeConnection a b
nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False
withServer2 $ \_ -> do
nGet b =##> \case ("", "", UP _ [c]) -> c == aId; _ -> False
-- to test retry in case of NO_SESSION error,
-- the client using server 1 as proxy and server 2 as destination
-- should be joining the connection, so the order is swapped here.
_ <- runRight $ makeConnection b a
pure ()
where
withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2} testPort2
servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]}
testNoProxy :: IO ()
testNoProxy = do
withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do
testSMPClient_ "127.0.0.1" testPort2 proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer Nothing)
testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", SMP.PRXY testSMPServer Nothing)
reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
testProxyAuth :: IO ()
testProxyAuth = do
withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do
testSMPClient_ "127.0.0.1" testPort proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer2 $ Just "wrong")
testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", SMP.PRXY testSMPServer2 $ Just "wrong")
reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
where
proxyCfgAuth = proxyCfg {newQueueBasicAuth = Just "correct"}
+27 -25
View File
@@ -73,7 +73,7 @@ pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType B
pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command))
pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg
pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh)
pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure)
pattern Msg :: MsgId -> MsgBody -> BrokerMsg
pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
@@ -134,7 +134,7 @@ testCreateSecure (ATransport t) =
g <- C.newRandom
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
(rId1, "") #== "creates queue"
@@ -199,7 +199,7 @@ testCreateDelete (ATransport t) =
g <- C.newRandom
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
(rId1, "") #== "creates queue"
@@ -271,7 +271,7 @@ stressTest (ATransport t) =
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
(dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
rIds <- forM ([1 .. 50] :: [Int]) . const $ do
Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe)
Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe False)
pure rId
let subscribeQueues h = forM_ rIds $ \rId -> do
Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB)
@@ -289,7 +289,7 @@ testAllowNewQueues t =
g <- C.newRandom
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
(dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
pure ()
testDuplex :: ATransport -> Spec
@@ -299,7 +299,7 @@ testDuplex (ATransport t) =
g <- C.newRandom
(arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
(aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe)
Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe False)
let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv
-- aSnd ID is passed to Bob out-of-band
@@ -315,7 +315,7 @@ testDuplex (ATransport t) =
(brPub, brKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
(bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe)
Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe False)
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
@@ -354,7 +354,7 @@ testSwitchSub (ATransport t) =
g <- C.newRandom
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1")
(ok1, OK) #== "sent test message 1"
@@ -509,19 +509,21 @@ testWithStoreLog at@(ATransport t) =
writeTVar senderId1 sId1
writeTVar notifierId nId
Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB)
signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello") >>= \case
Resp "bcda" _ OK -> pure ()
r -> unexpected r
Resp "" _ (Msg mId1 msg1) <- tGet1 h
(mId1, msg1) <-
signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello") >>= \case
Resp "" _ (Msg mId1 msg1) -> pure (mId1, msg1)
r -> error $ "unexpected response " <> take 100 (show r)
Resp "bcda" _ OK <- tGet1 h
(decryptMsgV3 dhShared mId1 msg1, Right "hello") #== "delivered from queue 1"
Resp "" _ (NMSG _ _) <- tGet1 h1
(sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2
atomically $ writeTVar senderId2 sId2
signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") >>= \case
Resp "cdab" _ OK -> pure ()
r -> unexpected r
Resp "" _ (Msg mId2 msg2) <- tGet1 h
(mId2, msg2) <-
signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") >>= \case
Resp "" _ (Msg mId2 msg2) -> pure (mId2, msg2)
r -> error $ "unexpected response " <> take 100 (show r)
Resp "cdab" _ OK <- tGet1 h
(decryptMsgV3 dhShared2 mId2 msg2, Right "hello too") #== "delivered from queue 2"
Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL)
@@ -608,7 +610,7 @@ testRestoreMessages at@(ATransport t) =
logSize testStoreLogFile `shouldReturn` 2
logSize testStoreMsgsFile `shouldReturn` 5
logSize testServerStatsBackupFile `shouldReturn` 52
logSize testServerStatsBackupFile `shouldReturn` 62
Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats1 [rId] 5 1
@@ -626,7 +628,7 @@ testRestoreMessages at@(ATransport t) =
logSize testStoreLogFile `shouldReturn` 1
-- the last message is not removed because it was not ACK'd
logSize testStoreMsgsFile `shouldReturn` 3
logSize testServerStatsBackupFile `shouldReturn` 52
logSize testServerStatsBackupFile `shouldReturn` 62
Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats2 [rId] 5 3
@@ -645,7 +647,7 @@ testRestoreMessages at@(ATransport t) =
logSize testStoreLogFile `shouldReturn` 1
logSize testStoreMsgsFile `shouldReturn` 0
logSize testServerStatsBackupFile `shouldReturn` 52
logSize testServerStatsBackupFile `shouldReturn` 62
Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats3 [rId] 5 5
@@ -740,7 +742,7 @@ createAndSecureQueue h sPub = do
g <- C.newRandom
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
let dhShared = C.dh' srvDh dhPriv
Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub)
(rId', rId) #== "same queue ID"
@@ -751,7 +753,7 @@ testTiming (ATransport t) =
describe "should have similar time for auth error, whether queue exists or not, for all key types" $
forM_ timingTests $ \tst ->
it (testName tst) $
smpTest2Cfg cfgV7 (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh ->
smpTest2Cfg cfg (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh ->
testSameTiming rh sh tst
where
testName :: (C.AuthAlg, C.AuthAlg, Int) -> String
@@ -775,7 +777,7 @@ testTiming (ATransport t) =
g <- C.newRandom
(rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe)
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False)
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB)
@@ -884,7 +886,7 @@ testMsgExpireOnInterval t =
testSMPClient @c $ \sh -> do
(sId, rId, rKey, _) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should expire)")
threadDelay 2500000
threadDelay 3000000
testSMPClient @c $ \rh -> do
signSendRecv rh rKey ("2", rId, SUB) >>= \case
Resp "2" _ OK -> pure ()
@@ -937,8 +939,8 @@ syntaxTests (ATransport t) = do
describe "NEW" $ do
it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)
it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey, SMSubscribe)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey, SMSubscribe)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey, '0', SMSubscribe, False)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey, '0', SMSubscribe, False)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
describe "KEY" $ do
it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH)
it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX)

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