5.6.1.0

* xftp: prevent overwriting completed upload

* add size check for skipCommitted

* fix import

* fail on incorrect size

---------

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

CHANGELOG.md

@@ -1,3 +1,43 @@
+# 5.6.1
+
+Version 5.6.1.0.
+
+- Much faster iOS notification server start time (fewer skipped notifications).
+- Fix SMP server stored message stats.
+- Prevent overwriting uploaded XFTP files with subsequent upload attempts.
+- Faster base64 encoding/parsing.
+- Control port audit log and authentication.
+
+# 5.6.0
+
+Version 5.6.0.4.
+
+SMP protocol/client/server:
+- support deniable sender command authorization (to be enabled in the next version).
+- remove support for SMP protocol versions (prior to v4, 07/2022).
+
+Agent:
+- optional post-quantum key agreement using sntrup761 in double ratchet protocol.
+- improve performance of deleting multiple connections and files by batching database operations.
+- delay connection deletion to deliver pending messages.
+- API to test for notifications server.
+- remove support for client protocols versions (prior to 10/2022).
+
+XFTP server:
+- restore storage quota in case of failed uploads.
+
+Performance and stability improvements.
+
+# 5.5.3
+
+Agent:
+- notification token API also returns active notifications server.
+- support file descriptions with redirection and file URIs.
+
+Servers:
+- CLI commands for online key and certificate rotation.
+- Configure config and log paths via environment variables.
+
 # 5.5.2
 
 Extensible handshake for clients and SMP/NTF servers (ignore extra data).

apps/ntf-server/Main.hs

@@ -1,13 +1,14 @@
 module Main where
 
 import Control.Logger.Simple
+import Simplex.Messaging.Server.CLI (getEnvPath)
 import Simplex.Messaging.Notifications.Server.Main
 
-cfgPath :: FilePath
-cfgPath = "/etc/opt/simplex-notifications"
+defaultCfgPath :: FilePath
+defaultCfgPath = "/etc/opt/simplex-notifications"
 
-logPath :: FilePath
-logPath = "/var/opt/simplex-notifications"
+defaultLogPath :: FilePath
+defaultLogPath = "/var/opt/simplex-notifications"
 
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -15,4 +16,6 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 main :: IO ()
 main = do
   setLogLevel LogDebug -- change to LogError in production
+  cfgPath <- getEnvPath "NTF_SERVER_CFG_PATH" defaultCfgPath
+  logPath <- getEnvPath "NTF_SERVER_LOG_PATH" defaultLogPath
   withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath

apps/smp-server/Main.hs

@@ -3,8 +3,8 @@
 module Main where
 
 import Control.Logger.Simple
+import Simplex.Messaging.Server.CLI (getEnvPath)
 import Simplex.Messaging.Server.Main
-import System.Environment
 
 defaultCfgPath :: FilePath
 defaultCfgPath = "/etc/opt/simplex"
@@ -21,6 +21,3 @@ main = do
   cfgPath <- getEnvPath "SMP_SERVER_CFG_PATH" defaultCfgPath
   logPath <- getEnvPath "SMP_SERVER_LOG_PATH" defaultLogPath
   withGlobalLogging logCfg $ smpServerCLI cfgPath logPath
-    
-getEnvPath :: String -> FilePath -> IO FilePath
-getEnvPath name def = maybe def (\case "" -> def; f -> f) <$> lookupEnv name

apps/xftp-server/Main.hs

@@ -1,13 +1,14 @@
 module Main where
 
 import Control.Logger.Simple
+import Simplex.Messaging.Server.CLI (getEnvPath)
 import Simplex.FileTransfer.Server.Main
 
-cfgPath :: FilePath
-cfgPath = "/etc/opt/simplex-xftp"
+defaultCfgPath :: FilePath
+defaultCfgPath = "/etc/opt/simplex-xftp"
 
-logPath :: FilePath
-logPath = "/var/opt/simplex-xftp"
+defaultLogPath :: FilePath
+defaultLogPath = "/var/opt/simplex-xftp"
 
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
@@ -15,4 +16,6 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 main :: IO ()
 main = do
   setLogLevel LogDebug -- change to LogError in production
+  cfgPath <- getEnvPath "XFTP_SERVER_CFG_PATH" defaultCfgPath
+  logPath <- getEnvPath "XFTP_SERVER_LOG_PATH" defaultLogPath
   withGlobalLogging logCfg $ xftpServerCLI cfgPath logPath

cabal.project

@@ -14,6 +14,12 @@ source-repository-package
     location: https://github.com/simplex-chat/aeson.git
     tag: aab7b5a14d6c5ea64c64dcaee418de1bb00dcc2b
 
+-- old bs/text compat for 8.10
+source-repository-package
+    type: git
+    location: https://github.com/simplex-chat/base64.git
+    tag: 2d77b6dbcaffc00570a70be8694049f3710e7c94
+
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/hs-socks.git

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.5.2.0
+version: 5.6.1.0
 synopsis: SimpleXMQ message broker
 description: |
   This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -31,7 +31,7 @@ dependencies:
   - async == 2.2.*
   - attoparsec == 0.14.*
   - base >= 4.14 && < 5
-  - base64-bytestring >= 1.0 && < 1.3
+  - base64 == 1.0.*
   - case-insensitive == 1.2.*
   - composition == 1.0.*
   - constraints >= 0.12 && < 0.14
@@ -73,6 +73,7 @@ dependencies:
   - unliftio-core == 0.2.*
   - websockets == 0.12.*
   - yaml == 0.11.*
+  - zstd == 0.1.3.*
 
 flags:
   swift:

rfcs/2023-12-29-pqdr.md

@@ -0,0 +1,36 @@
+# Post-quantum double ratchet implementation
+
+See [the previous doc](https://github.com/simplex-chat/simplex-chat/blob/stable/docs/rfcs/2023-09-30-pq-double-ratchet.md).
+
+The main implementation consideration is that it should be both backwards and forwards compatible, to allow changing the connection DR to/from using PQ primitives (although client version downgrade may be impossible in this case), and also to decide whether to use PQ primitive on per-connection basis:
+- use without links (in SMP confirmation or in SMP invitation via address or via member), don't use with links (as they would be too large).
+- use in small groups, don't use in large groups.
+
+Also note that for DR to work we need to have 2 KEMs running in parallel.
+
+Possible combinations (assuming both clients support PQ):
+
+| Stage        | No PQ kem | PQ key sent | PQ key + PQ ct sent |
+|:------------:|:---------:|:-----------:|:-------------------:|
+| inv   | + | + | - |
+| conf, 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>+ |
+
+These rules 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).
+
+The rules for calculating the shared secret for received/sent messages are (assuming received message is valid according to the above rules):
+
+|   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 |
+
+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.
+
+The type for sending PQ key with optional ciphertext is `Maybe E2ERachetKEM` where `data E2ERachetKEM = E2ERachetKEM KEMPublicKey (Maybe KEMCiphertext)`, and for SMP invitation it will be simply `Maybe KEMPublicKey`. Possibly, there is a way to encode the rules above in the types, these types don't constrain possible transitions to valid ones.

rfcs/2024-01-26-file-links.md

@@ -0,0 +1,73 @@
+# Sending large file descriptions
+
+It is desirable to provide a QR code/URI from which a file can be downloaded. This way files may be addressed outside a chat client.
+Currently the `xftp` CLI tool can generate YAML file descriptions that can be used to receive a file.
+It is possible to pass such a description as an URI, but descriptions for files larger than ~8 MBs (two 4 MB chunks) would give QR codes that are difficult to process.
+A user can manually upload description and get a shorter one. Typically descriptions for files that are up to ~20 GBs would still be small enough to not require another pass, and that is way beyond any current (or, reasonable, fwiw) limitations.
+
+It is possible to streamline this process, so any application using simplexmq agent can easily send file descriptions and follow redirects.
+A file description with a redirect contains an extra field with final file size and digest so it can be followed automatically.
+
+The flow would be like this:
+
+- Sending:
+  1. Upload file as usual with `xftpSendFile`, get recipient file descriptions in `SFDONE` message.
+  2. Upload one of the file descriptions with `xftpSendDescription`, get its redirect-description in its `SFDONE` message.
+  3. Wrap in `FileDescriptionURI` and use `strEncode` to get a QR-sized URI.
+  4. Show QR code / copy link.
+- Receiving:
+  1. Scan QR code / paste link.
+  2. Use `strDecode` and unwrap `FileDescriptionURI` to get `ValidFileDescription 'FRecipient`.
+  3. Download it as usual with `xftpReceiveFile`, getting `RFDONE` message when the file is fully received.
+
+It is not necesary to use redirect description if original description can be encoded to fit in 1002 characters. Beyond this size there is a significant jump in QR code complexity.
+It is possible to call `encodeFileDescriptionURI` right after upload to test if the URI fits and skip step 2.
+When `xftpReceiveFile` receives a decoded description that lacks `redirect` field, the procedure for downloading a file is the same as usual - download chunks and reassemble local file.
+
+## Agent changes
+
+### Sending
+
+Sending and receiving files in agent is a multi-step process mediated by DB entries in `snd_files` and `rcv_files` tables.
+
+`xftpSendDescription` is tasked with storing original description in a temporary locally-encrypted file, then creating upload task for it.
+
+It is necessary to preserve redirect metadata so it can be attached to descriptions in the `SFDONE` message sent by a worker:
+
+```sql
+ALTER TABLE snd_files ADD COLUMN redirect_size INTEGER;
+ALTER TABLE snd_files ADD COLUMN redirect_digest BLOB;
+```
+
+### Receiving
+
+`xftpReceiveFile` gets a file description as an argument and knows if it should follow redirect procedure or run an ordinary download.
+For redirects it will prepare a `RcvFile` for redirect and then a placeholder, for the final file.
+Agent messages would be sent using the entity ID of the final file, which is stored along with redirect metadata in `RcvFile` for the redirect.
+
+```sql
+ALTER TABLE rcv_files ADD COLUMN redirect_id INTEGER REFERENCES rcv_files ON DELETE CASCADE; -- for later updates
+ALTER TABLE rcv_files ADD COLUMN redirect_entity_id BLOB; -- for notifications
+ALTER TABLE rcv_files ADD COLUMN redirect_size INTEGER;
+ALTER TABLE rcv_files ADD COLUMN redirect_digest BLOB;
+```
+
+These additional fields will exist on the file that is a short description to receive an actual description of the final file.
+
+While a description YAML is being downloaded, the application will get `RFPROG` messages tagged for final entity, containing bytes downloaded so far and the total size from the original file.
+When the description is fully downloaded, the worker would decode description and check if the stated size and digest match the declared in redirect.
+Then it will replace placeholder description in `rcv_files` for destination file with the actual data from downloaded description.
+Finally, instead of sending `RFDONE` for redirect, it hands over work to chunk download worker, which will run exactly as if the user requested its download directly.
+An application will then receive `RFPROG` and `RFDONE` messages as usual.
+
+## URI encoding
+
+File description URIs use the same service schema `simplex:` or its `https://simplex.chat` (or any custom host) equivalent as do contact links and can be extracted from text and processed the same way.
+The path section is `/file` (with an optional trailing `/`).
+The payload is encoded in the "fragment" part of the link, using `#/?`, followed by a query string.
+File description is encoded first in a YAML document, then URL-encoded in under the key `d`.
+An application may want to pass extra parameters not necessary to download a file. Those go in the `_` key, encoded as a JSON dictionary.
+
+An example link:
+
+`simplex:/file#/?d=chunkSize%3A%2064kb%0Adigest%3A%20OtpnXkECTW4a18Eots2m3O22maeOCMqPUX4ulugIjgMEJfCpTYc_-T257Uw7s9bW_F0G5WBg5BioBWd4Z_OoCw%3D%3D%0Akey%3A%20rNR8_2SJuH7Qve43gV3zszL0R6oY5HSdRZT_paB-wfE%3D%0Anonce%3A%202oKwfK-w75nwyWp8_1Lv6QnQonIRtJmG%0Aparty%3A%20recipient%0Areplicas%3A%0A-%20chunks%3A%0A%20%20-%201%3ATdvaxMnG2Ph1e3QCx3-rpA%3D%3D%3AMC4CAQAwBQYDK2VwBCIEILdErEICvgrBCajDLTX2h3LXyMB7z5vrtLa3XVigJuf-%3ANS46KuYdgOWs6dUeMp7p2oF8rBQ9wQ2Ez6TW6Y6gHg0%3D%0A%20%20-%202%3AH5SRbtKYrXWVXTthrkeWzw%3D%3D%3AMC4CAQAwBQYDK2VwBCIEIGeEPNLt7lUGPfplwsoJLCDFnbIc5Hm31kz5X6rWXmgu%3A7QNRI-gvFx9UM-baXp3YVDli9pcfh3HGFKDhsA9JQHY%3D%0A%20%20-%203%3A_xjukkIl9WZFryUXT0h_TQ%3D%3D%3AMC4CAQAwBQYDK2VwBCIEIIRFBaL1HvUfePvKLuggwUrC_q_ZHd7v08IL9jhM7teC%3Aid2lgLMMjTGsR8SUogJuRdLoEHAc5SDQKFDqlZRSuEY%3D%0A%20%20server%3A%20xftp%3A%2F%2FLcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI%3D%40localhost%3A7002%0Asize%3A%20192kb%0A&_=%7B%22k%22:%22test%22%7D`

rfcs/2024-02-03-deniability.md

@@ -0,0 +1,51 @@
+# Repudiation for message senders
+
+## Problem
+
+We use double ratchet protocol to send messages. One of its important qualities is the use of symmetric encryption with forward secrecy, when the new key to encrypt the message is rotated after each message. This provides senders ability to plausibly deny having sent some messages, without denying having sent others. While the recipients can prove to themselves that the message was indeed sent by the sender, because it was encrypted using authenticated encryption with associated data, the recipients cannot prove it to any third party - as the message could have been encrypted by themselves, as they also have the same symmetric keys.
+
+To receive the messages, the recipients agree a message queue with the senders, and the commands sent to this queue are signed by the senders using the cryptographic key (Edwards curve key) of which the public counterpart was shared with the recipient in the confirmation message of SMP protocol (this confirmation message itself is not signed).
+
+While it was never claimed that the messaging protocol provides deniability, the deniability is often mentioned as one of the important qualities of double ratchet algorithm used in the innermost layer of e2e encryption, so without explicit disclaimer of deniability limitations, it may be assumed by the users that the system as a whole provides the same level of deniability as the double ratchet algorithm, which currently is not the case.
+
+While societal understanding and legal acceptance of repudiation is arguable, there was less than a decade since this quality became widely available in Signal - legal systems take longer to evolve.  While the argument that the message was forged is unlikely to be accepted in the usual court cases with the ordinary people, it is likely to be considered in cases with high profile defendants, who can reasonably claim that they are the target of smear campaign and are being attributed something that they never sent - the statement that the message is forged is reasonable in such cases, and it provides plausible deniability, and the cryptographic experts invited to the hearing would attest to that.
+
+It’s important to both continue providing repudiation quality in communication systems, when it is appropriate, and also to educate the users about when it can be used as a reasonable defence strategy, thus improving privacy of communication and making digital off-the-record communications possible and understood both by the society and by legal systems.
+
+## Solution
+
+The proposed solution is to avoid the use of signature algorithm for server command authorization, and instead use authenticated encryption to authorize the commands sent to the server queues. If this protocol change is adopted, it could be used both for senders and recipients commands, both for consistency, and also to provide the deniability to recipients about executing any commands on the servers, in a similar way.
+
+The proposed approach is to use NaCl crypto_box that proves authentication and third party unforgeability and, unlike signature, repudiation guarantee. See [crypto_box docs](https://nacl.cr.yp.to/box.html):
+
+> The crypto_box function is designed to meet the standard notions of privacy and third-party unforgeability for a public-key authenticated-encryption scheme using nonces. The crypto_box function is not meant to provide non-repudiation. On the contrary: the crypto_box function guarantees repudiability. A receiver can freely modify a boxed message, and therefore cannot convince third parties that this particular message came from the sender. The sender and receiver are nevertheless protected against forgeries by other parties. In the terminology of https://groups.google.com/group/sci.crypt/msg/ec5c18b23b11d82c, crypto_box uses "public-key authenticators" rather than "public-key signatures.”
+
+DJB further writes in the link above:
+
+> If you were already planning to encrypt the message, using another key derived from g^xy, then you don't have to do any extra public-key work. A secret-key authenticator is easier to implement than a public-key signature, and it takes less CPU time to compute.
+
+So the proposed solution appears to have desired security qualities, without non-repudiation, that is undesirable in the context of private messaging.
+
+When queue is created or secured, the recipient would provide a DH key (X25519) to the server (either their own or received from the sender), and the server would provide its own random X25519 key per session. Then, either the authenticator will be computed in this way:
+
+```abnf
+transmission = authenticator authorized
+authenticator = crypto_box(sha512(authorized), secret = dh(client long term queue key, server session key), nonce = correlation ID)
+authorized = tlsunique correlationId queueId protocol_command ; same as the currently signed part of the transmission
+```
+
+The authenticator is smaller in size than currently used signature size, freeing ~34 bytes from the transmission.
+
+This allows to retain the protocol logic and make authentication scheme configurable, both by the clients and servers, e.g. some servers might be configured to use signature for non-repudiation, and clients may be configured to either agree or disagree to that, per conversation.
+
+There is no required change in SMP command syntax other than allowing X25519 key instead of Ed signature keys passed to the server in NEW and KEY commands. We could add support for migration of the existing queues to the new authorization scheme, but it is not strictly required, as the clients provide a mechanism to rotate the receiving addresses (currently manually, and once automated all queues will be rotated). On another hand, per queue key and identifiers rotation is cheaper than negotiating the new queue (it can be done between client and server, without the involvement of another party), and could be considered as an independent improvement.
+
+## Migration plan
+
+As this new scheme breaks backward compatibility, as the new scheme requires additional keys in protocol handshake, and current implementation does not support forward compatible header extension, we have to migrate in multiple steps, to minimize any disruption to the users.
+
+1. Upgrade clients for forward compatibility of the protocol handshake (ignore extra bytes) - 5.5.3.
+2. Add support for handshake and version negotiation to XFTP - 5.5.4 or 5.6.
+3. Upgrade clients to drop support of SMP earlier than v4 (batching) and also drop support of old double ratchet protocol and old handshake - 5.6.
+4. Upgrade servers to offer SMP v7 with support for new authorization - by the time 5.6 is released.
+5. Upgrade clients to require server support for SMP v7 / new authorization scheme and start using it - 5.7 or 5.8. At this point the old version of the servers will not be supported, as maintaining this backward compatibility would substantially increase the complexity and logic of the client - at the point of generating the key we do not even know which server version will be used.

rfcs/2024-02-12-encryption.md

@@ -0,0 +1,33 @@
+# Transmission encryption
+
+## Problems
+
+### Protection of meta-data from sending proxy
+
+The SEND commands and message queue IDs need to be encrypted so that sending proxy cannot see how many queues exist on each server.
+
+Correlation IDs need to be random and can be re-used as nonces so that the destination relay cannot use the increasing correlation IDs that are sent in v6 of the protocol to track the sender.
+
+###  Protection of the traffic from the attacker who compromised TLS
+
+Currently, even though different sending and receiving queue IDs are used, the attacker who compromised TLS could do statistical analysis and in this way correlate queue IDs of senders and recipients, and therefore correlate the senders and recipients.
+
+## Possible solutions
+
+1. Encrypt sent messages, other commands and their responses in the additional envelope, irrespective of whether proxy is used or not. In this case the requestion transmission could have this syntax:
+
+```abnf
+encReqTransmission = pubKey nonce encrypted(reqTransmission)
+reqTransmission = respNonce entityId command
+
+encRespTransmission = replyNonce encrypted(respTransmission)
+respTransmission = entityId command
+```
+
+The keys to encrypt and decrypt both the command and responses would be computed as curve25519 from the key sent together with command and server session key. For the requests, the nonce has to be random and sent outside of the encrypted envelopt, but for the response respNonce would be taken from inside of the encrypted envelope and it would also be used for correlating commands and responses. This way the attacker who could compromise TLS would not be able to correlate the commands and responses, and also observe entity IDs.
+
+2. The remaining question is to how encrypt and decrypt messages delivered not in response to the commands.
+
+The possible options are:
+- restore client session key only for that purpose, but do not forward this key to the destination proxy for sent messages. Then the messages can be sent with a random replyNonce and the key would be computed from session keys. The advantage here is that we won't need to parameterize handles as both client and server would have session keys. The downside that we would have to either somehow differentiate messages and responses, either by some flag that would allow some correlation or just by the absense of replyNonce in the lookup map - that is if the client can find replyNonce, it would use the associated key to decrypt, and if not it would use session key.
+- use the same key that was sent with SUB or ACK command. This is much more complex, and would only have some upside if we were to introduce receiving proxies (to conceal transport sessions from the receiving relays for the recipients).

rfcs/2024-03-03-pqdr-version.md

@@ -0,0 +1,92 @@
+# Migrating existing connections to post-quantum double ratchet algorithm
+
+## Problem
+
+Post-quantum variant of double ratchet algorithm represents an almost full-stack change affecting all parts of the protocol stack except client-server protocol (SMP):
+- double-ratchet end-to-end encryption: different encoding (additional large keys require byte-strings larger than 255 bytes with 2-byte length prefixes) and larger message headers (increased by ~2200 bytes).
+- agent-agent protocol: a smaller maximum message size to accomodate larger headers and to fit in 16kb blocks, reduced by ~2200 bytes for the messages and by almost ~4000 bytes for connection information.
+- chat protocol: also a smaller message size compensated by zstd comression of JSON messages.
+
+We want the versioning that achieves these objectives:
+- all changes in all protocol layers happen at the same time, when both clients support it.
+- ability to downgrade the clients to the previous version without losing connection.
+- ability to opt-in into this functionality via "experimental" feature toggle, that enables post-quantum encryption in connections when both contacts enable this toggle.
+
+To have ability to downgrade the clients we have two options:
+- roll-out this functionality in two stages: 1) roll-out clients support but do not enable the new version, and then 2) upgrade client version. The problem here is that the clients won't be able to opt-in into this experiment.
+- make offered range dependent on experimental feature being enabled. Currently we have an option to enable PQ encryption in agent API, and this option can be used as a proxy to maxium supported protocol version - if the option is passed, it can be seen as an indication that higher version range (or version) should offered (or accepted).
+
+## Solution
+
+Currently ratchet state stores version range. It's unclear what was the intended semantics of that version range - it simply stores the offered/supported version range at the time ratchet was initialised, but only a high bound is used to send in message headers, and it is never upgraded. In JSON this range is encoded as tuple (an array of two elements in JSON).
+
+We could continue using this range with the meaning of the lower bound to be "currently used ratchet version" and the meaning of higher boundary to be "maximum supported ratchet version". We could also use the version communicated in message headers to upgrade ratchet version, with the condition that upgrade should only happen if both sides want it. Currently it's defined by pqEnableKEM property in ratchet state. We could also make it more explicit by defining maximum version to which ratchet should upgrade. Given that irreversible upgrades are not very common, it is probably ok to keep it implicit.
+
+We can define a better type than VersionRange to reflect semantics of the range in ratchet (current/max supported range), but for backward compatibility it needs to be encoded in the same way as now.
+
+To summarize, the proposed solution for ratchet versioning is:
+- define ratchet versions as new type to include current and maximum allowed versions, where maximum allowed will be either the same or lower than maximum supported based on PQ option (in 5.6), and in 5.7 it will be changed to maximum supported, so version starts upgrading independently from PQ being enabled.
+- make encodings in ratchet depend on current version (in curent code it depends on max version).
+- include max allowed in message header.
+- upgrade current if in range on each new message if less than max and higher than current (same as we do for connections).
+- increase max allowed once PQ is enabled (only in 5.6). Make max allowed the same as max supported (global constant).
+
+```haskell
+data RatchetVR = RatchetVR
+  { currentVersion :: Version,
+    maxAllowedVersion :: Version
+  }
+
+instance ToJSON RatchetVR where
+  toEncoding (RatchetVR v1 v2) = toEncoding (v1, v2)
+  toJSON (RatchetVR v1 v2) = toJSON (v1, v2)
+
+instance FromJSON RatchetVR where
+  parseJSON v = do
+    -- this also verifies that v2 > v1 (although we could remove JSON instances for VersionRange)
+    VersionRange v1 v2 <- parseJSON v
+    pure $ RatchetVR v1 v2
+```
+
+For connections, we could also make version used for the purposes of encoding dependent on the PQ being enabled, and version for decoding taken from message header, but then we'd have to not only upgrade ratchets but the connection as well every time PQ mode changes.
+
+Another suggestion to ensure that correct version range is used in correct contexts could be:
+- using different newtypes for different version ranges.
+- define generic type class for version aware encoding that would also accept only specific type class for the version to use the correct range. This may be justified as there will be several version-aware encodings, and not just the protocol as now.
+
+```haskell
+class Ord v => EncodingV v a where
+  {-# MINIMAL smpEncodeV, (smpDecodeV | smpVP) #-}
+  smpEncodeV :: v -> a -> ByteString
+  -- default decode uses parser
+  smpDecodeV :: v -> ByteString -> Either String a
+  smpDecodeV = parseAll . smpVP
+  -- default parser decodes from length-specified bytestring
+  smpVP :: v -> Parser a
+  smpVP v = smpDecodeV v <$?> smpP
+```
+
+The version will be passed from currently agreed version, it may only change when message is received, not when message is sent. The version will not be extracted from the encoding itself as it happens now in ratchet encodings.
+
+## Various options how the problem can be simplified
+
+1. Do not support connection downgrade once both devices upgraded. If applied to all existing connections then it is a bad option, as it would disrupt some important conversations.
+
+2. Do not provide ability to opt-in into PQ encryption until v5.7 where it will be rolled out automatically. That is also suboptimal, as it won't allow announcing technology design and have testing outside of the team devices.
+
+3. The logic explained above where connection upgrade and downgrade is possible and applied to all existing connections if both parties consent to it. There are these important downsides:
+  - complexity of this logic
+  - regression risks when this logic is removed.
+  - some non-coordinated upgrades of existing, potentially important conversations, simply because two users opt-in into the experiment without any expectation that another side also opts-in.
+
+4. Apply upgrade/downgrade logic and enable PQ encryption as opt-in, based on the toggle in the UX, only for the new connections. This seems the least risky, and also simpler than option 3, as it would only apply to the new connections, and both users will have to enable experimental toggle prior to connecting.
+
+Option 4 seems the best trade-off, and has these sub-options regarding where it is controlled:
+a) in chat based on connection flag. Chat will pass PQ options only to connections that were created when experimental option was enabled.
+b) in agent - there will be additional logic to ignore PQ option for existing connections.
+c) both in chat and in agent.
+
+Option 4a seems better, as it would:
+- simplify agent code
+- minimise required changes when releasing v5.7 (as we do want that all direct and small groups connections migrate to PQ encryption at the time, without any toggles)
+- allow tests for connection upgrade in the currect code.

rfcs/2024-03-20-server-metadata.md

@@ -0,0 +1,123 @@
+# Relay metadata and SimpleX network decentralization
+
+## Problem
+
+Currently, the clients configure/choose which servers to use, but they cannot see who operates them, in which geography and hosting provider, what is the server source code (in case it was modified from the reference implementation we provide) and also any administrative and feedback contacts.
+
+Further, we currently use simplex.chat domain to host group links, and as diversity of the groups grows it is beginning to require managing feedback from the users about groups. It is important that this feedback is directed to relay owners and not to us, in case they are not our relays, as we are simply providing software here.
+
+We also need to make it much easier to access administrative actions - e.g., if the relay owner wants to block some address based on the feedback, they should be able to do so effectively. While freedom of speech of users is important the autonomy and sovereignty of relay operators allowing them to decide what they want or don't want to host, irrespective of the reasons, is as important - public relays constitute a public space rather than a service, and while there is no authentication or authorization required to use them, the relay owners should be able to decide their conditions and limitations of use, as is the case for any public space.
+
+## Why it is important
+
+1. We are building network and not a service, so contrary to the traditional approach when service collects users metadata and conceals its own, it appears important to do the opposite - expose all relay metadata that may have any effect on users privacy and security and provide access to this metadata with the minimal friction, via the app UI.
+2. We need to remove the only remaining bit of centralization - using simplex.chat website to show the QR code and help new users onboarding - this role can be delegated to the relays.
+3. We need to make it easy for the users to submit feedback and to the relay operators to manage that feedback. That includes ourselves, as relay operators, and also any other person or organization that operates public relays.
+4. It is important to stress the requirement of AGPLv3 license to provide access to the source code to the relay users, as any code modifications might undermine user privacy and security and must be made transparent to the relay users.
+
+While this document is not the end of the journey to decentralize the network, it's an important first step.
+
+## Proposed solution
+
+The proposed solution consists of two parts:
+
+- communicate server metadata via protocol, so it can be observed by the clients.
+- create home page for the relays, with all the same metadata.
+- create invitation and address links in the same domain name as the relay.
+
+The latter point is important so it is clear to the users who operates and owns the relay and where the access point to the content or group is hosted. Even though simplex.chat domain is never accessed by the app, and the meaningful part of the address is never sent to the page hosting server, it creates an impression of centralization, and some dependency on simplex.chat domain for anything other that showing the link QR code.
+
+Moving invitation links to the domain of the relay (primary relay, in case the link has redundancy) will both clarify relay ownership, solve the incorrect mis-perception of centralization, remove the dependency on simplex-chat domain without any user effort, and provides the means to submit content complaints to the relay operators (should they wish to receive them, which seems reasonable for large public relays, but may be unnecessary for private relays where unidentified parties cannot create links).
+
+## Solution details
+
+Extend server INI file with information section:
+
+```
+[INFORMATION]
+# Please note that under AGPLv3 license conditions you MUST make
+# any source code modifications available to the end users of the server.
+# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE
+# Not doing so would constitute a license violation.
+# Declaring an incorrect information here amounts to a fraud.
+# The license holders reserve the right to prosecute missing or incorrect
+# information about the server source code to the fullest extent permitted by the law.
+# The server will show warning on start if this field is absent
+# and will not launch from v6.0 until this field is added.
+# If any other information field is present, source code property also MUST be present.
+source_code: https://github.com/simplex-chat/simplexmq
+
+# Declaring all below information is optional, any of these fields can be omitted.
+# Declaring an incorrect information here would amount to a fraud.
+
+# We should split this document to the model one, where specific parameters will be external to the document,
+# and specific to us, so that relay operators can adopt our recommended policy and publish any amendments separately.
+conditions: https://github.com/simplex-chat/simplex-chat/blob/_archived-ep/ios-file-provider/PRIVACY.md
+# conditions_amendments: link
+
+server_country: SE
+operator: SimpleX Chat Ltd.
+operator_country: GB # operator country
+website: https://simplex.chat
+admin_simplex: administrative SimpleX address
+admin_email: [email protected]
+admin_pgp: PGP key
+feedback_simplex: SimpleX address for feedback, comments and complaints
+feedback_email: [email protected]
+feedback_pgp: PGP key
+hosting: Linode / Akamai Inc.
+hosting_country: US
+```
+
+Server home page would show whether queue creation is allowed and/or password protected, server retention policy (e.g., preserve messages on restart or not, and persist connections or not).
+
+Server queue address/contact pages will optionally, provide the UI to submit feedback, comments and complaints directly from the web page (not an MVP, initially we would simply show addresses for feedback, and, probably, create link that opens in the app with pre-populated message, and we could also use this addresses defined in server meta-data to submit feedback from inside of the app - it's also out of MVP scope).
+
+If server is available on .onion address, the web pages would show "open via .onion" in Tor browser.
+
+Extend server handshake header with these information fields:
+
+```haskell
+data ServerHandshake = ServerHandshake
+  { smpVersionRange :: VersionRangeSMP,
+    sessionId :: SessionId,
+    -- pub key to agree shared secrets for command authorization and entity ID encryption.
+    authPubKey :: Maybe (X.CertificateChain, X.SignedExact X.PubKey),
+    -- ^^ existing fields
+    -- vv new field that will be sent as length-prefixed JSON in the handshake
+    information :: Maybe ServerInformation
+  }
+
+data ServerInformation = ServerInformation
+  { -- below is based on the existing server configuration
+    persistence :: SMPServerPersistenceMode,
+    messageExpiration :: Int,
+    statsEnabled :: Bool,
+    newQueuesAllowed :: Bool,
+    basicAuthEnabled :: Bool, -- server is private if enabled
+    -- below is based on INFORMATION section of INI file
+    sourceCode :: Text, -- note that this property is not optional, in line with AGPLv3 license
+    -- all below properties are optional, except entity name MUST be present if any entity country is present
+    conditions :: Maybe ServerConditions,
+    operator :: Maybe Entity,
+    website :: Maybe Text,
+    admin :: Maybe ServerContactAddress,
+    feedback :: Maybe ServerContactAddress,
+    hosting :: Maybe Entity,
+    serverCountry :: Maybe Text
+  }
+
+data ServerPersistenceMode = SMPMemoryOnly | SPMQueues | SPMQueuesMessages
+
+data ServerConditions = ServerConditions {conditions :: Text, amendments :: Maybe Text}
+
+data Entity = Entity {name :: Text, country :: Maybe Text}
+
+data ServerContactAddress = ServerContactAddress
+  { simplex :: Maybe Text,
+    email :: Maybe Text, -- it is recommended that it matches DNS email address, if either is present
+    pgp :: Maybe Text
+  }
+```
+
+This extended server information will be stored in the chat database every time it changes and shown in the UI of the server configuration.

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.5.2.0
+version:        5.6.1.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -102,9 +102,13 @@ library
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
       Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
+      Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
       Simplex.Messaging.Agent.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
+      Simplex.Messaging.Compression
       Simplex.Messaging.Crypto
       Simplex.Messaging.Crypto.File
       Simplex.Messaging.Crypto.Lazy
@@ -115,6 +119,8 @@ library
       Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI
       Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG
       Simplex.Messaging.Encoding
+      Simplex.Messaging.Encoding.Base64
+      Simplex.Messaging.Encoding.Base64.URL
       Simplex.Messaging.Encoding.String
       Simplex.Messaging.Notifications.Client
       Simplex.Messaging.Notifications.Protocol
@@ -142,6 +148,7 @@ library
       Simplex.Messaging.Server.QueueStore.STM
       Simplex.Messaging.Server.Stats
       Simplex.Messaging.Server.StoreLog
+      Simplex.Messaging.ServiceScheme
       Simplex.Messaging.TMap
       Simplex.Messaging.Transport
       Simplex.Messaging.Transport.Buffer
@@ -156,6 +163,7 @@ library
       Simplex.Messaging.Transport.WebSockets
       Simplex.Messaging.Util
       Simplex.Messaging.Version
+      Simplex.Messaging.Version.Internal
       Simplex.RemoteControl.Client
       Simplex.RemoteControl.Discovery
       Simplex.RemoteControl.Discovery.Multicast
@@ -181,7 +189,7 @@ library
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
+    , base64 ==1.0.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -223,6 +231,7 @@ library
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , yaml ==0.11.*
+    , zstd ==0.1.3.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -252,7 +261,7 @@ executable ntf-server
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
+    , base64 ==1.0.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -295,6 +304,7 @@ executable ntf-server
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , yaml ==0.11.*
+    , zstd ==0.1.3.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -324,7 +334,7 @@ executable smp-agent
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
+    , base64 ==1.0.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -367,6 +377,7 @@ executable smp-agent
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , yaml ==0.11.*
+    , zstd ==0.1.3.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -396,7 +407,7 @@ executable smp-server
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
+    , base64 ==1.0.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -439,6 +450,7 @@ executable smp-server
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , yaml ==0.11.*
+    , zstd ==0.1.3.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -468,7 +480,7 @@ executable xftp
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
+    , base64 ==1.0.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -511,6 +523,7 @@ executable xftp
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , yaml ==0.11.*
+    , zstd ==0.1.3.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -540,7 +553,7 @@ executable xftp-server
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
+    , base64 ==1.0.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -583,6 +596,7 @@ executable xftp-server
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , yaml ==0.11.*
+    , zstd ==0.1.3.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -604,6 +618,7 @@ test-suite simplexmq-test
       AgentTests
       AgentTests.ConnectionRequestTests
       AgentTests.DoubleRatchetTests
+      AgentTests.EqInstances
       AgentTests.FunctionalAPITests
       AgentTests.MigrationTests
       AgentTests.NotificationTests
@@ -616,6 +631,7 @@ test-suite simplexmq-test
       CoreTests.EncodingTests
       CoreTests.ProtocolErrorTests
       CoreTests.RetryIntervalTests
+      CoreTests.TRcvQueuesTests
       CoreTests.UtilTests
       CoreTests.VersionRangeTests
       FileDescriptionTests
@@ -625,6 +641,7 @@ test-suite simplexmq-test
       ServerTests
       SMPAgentClient
       SMPClient
+      Util
       XFTPAgent
       XFTPCLI
       XFTPClient
@@ -643,7 +660,7 @@ test-suite simplexmq-test
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64-bytestring >=1.0 && <1.3
+    , base64 ==1.0.*
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -693,6 +710,7 @@ test-suite simplexmq-test
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , yaml ==0.11.*
+    , zstd ==0.1.3.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON

src/Simplex/FileTransfer/Agent.hs

@@ -17,10 +17,14 @@ module Simplex.FileTransfer.Agent
     -- Receiving files
     xftpReceiveFile',
     xftpDeleteRcvFile',
+    xftpDeleteRcvFiles',
     -- Sending files
     xftpSendFile',
+    xftpSendDescription',
     deleteSndFileInternal,
+    deleteSndFilesInternal,
     deleteSndFileRemote,
+    deleteSndFilesRemote,
   )
 where
 
@@ -28,14 +32,19 @@ import Control.Logger.Simple (logError)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
+import Data.Bifunctor (first)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Coerce (coerce)
 import Data.Composition ((.:))
+import Data.Either (rights)
 import Data.Int (Int64)
-import Data.List (foldl', sortOn)
+import Data.List (foldl', partition, sortOn)
 import qualified Data.List.NonEmpty as L
 import Data.Map (Map)
 import qualified Data.Map.Strict as M
+import Data.Maybe (mapMaybe)
+import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
@@ -45,6 +54,7 @@ import Simplex.FileTransfer.Crypto
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
+import qualified Simplex.FileTransfer.Transport as XFTP
 import Simplex.FileTransfer.Types
 import Simplex.FileTransfer.Util (removePath, uniqueCombine)
 import Simplex.Messaging.Agent.Client
@@ -52,13 +62,15 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store.SQLite
+import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
 import qualified Simplex.Messaging.Crypto.File as CF
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String (strDecode, strEncode)
 import Simplex.Messaging.Protocol (EntityId, XFTPServer)
-import Simplex.Messaging.Util (liftError, tshow, unlessM, whenM)
+import Simplex.Messaging.Util (catchAll_, liftError, tshow, unlessM, whenM)
 import System.FilePath (takeFileName, (</>))
 import UnliftIO
 import UnliftIO.Directory
@@ -97,7 +109,7 @@ closeXFTPAgent a = do
     stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
 
 xftpReceiveFile' :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> m RcvFileId
-xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) cfArgs = do
+xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs = do
   g <- asks random
   prefixPath <- getPrefixPath "rcv.xftp"
   createDirectory prefixPath
@@ -107,14 +119,25 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) cfA
   createDirectory =<< toFSFilePath relTmpPath
   createEmptyFile =<< toFSFilePath relSavePath
   let saveFile = CryptoFile relSavePath cfArgs
-  fId <- withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile
-  forM_ chunks downloadChunk
+  fId <- case redirect of
+    Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile
+    Just _ -> do
+      -- prepare description paths
+      let relTmpPathRedirect = relPrefixPath </> "xftp.redirect-encrypted"
+          relSavePathRedirect = relPrefixPath </> "xftp.redirect-decrypted"
+      createDirectory =<< toFSFilePath relTmpPathRedirect
+      createEmptyFile =<< toFSFilePath relSavePathRedirect
+      cfArgsRedirect <- atomically $ CF.randomArgs g
+      let saveFileRedirect = CryptoFile relSavePathRedirect $ Just cfArgsRedirect
+      -- create download tasks
+      withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile
+  forM_ chunks (downloadChunk c)
   pure fId
-  where
-    downloadChunk :: AgentMonad m => FileChunk -> m ()
-    downloadChunk FileChunk {replicas = (FileChunkReplica {server} : _)} = do
-      void $ getXFTPRcvWorker True c (Just server)
-    downloadChunk _ = throwError $ INTERNAL "no replicas"
+
+downloadChunk :: AgentMonad m => AgentClient -> FileChunk -> m ()
+downloadChunk c FileChunk {replicas = (FileChunkReplica {server} : _)} = do
+  void $ getXFTPRcvWorker True c (Just server)
+downloadChunk _ _ = throwError $ INTERNAL "no replicas"
 
 getPrefixPath :: AgentMonad m => String -> m FilePath
 getPrefixPath suffix = do
@@ -172,14 +195,17 @@ runXFTPRcvWorker c srv Worker {doWork} = do
           relChunkPath = fileTmpPath </> takeFileName chunkPath
       agentXFTPDownloadChunk c userId digest replica chunkSpec
       atomically $ waitUntilForeground c
-      (complete, progress) <- withStore c $ \db -> runExceptT $ do
+      (entityId, complete, progress) <- withStore c $ \db -> runExceptT $ do
         liftIO $ updateRcvFileChunkReceived db (rcvChunkReplicaId replica) rcvChunkId relChunkPath
-        RcvFile {size = FileSize total, chunks} <- ExceptT $ getRcvFile db rcvFileId
+        RcvFile {size = FileSize currentSize, chunks, redirect} <- ExceptT $ getRcvFile db rcvFileId
         let rcvd = receivedSize chunks
             complete = all chunkReceived chunks
+            (entityId, total) = case redirect of
+              Nothing -> (rcvFileEntityId, currentSize)
+              Just RcvFileRedirect {redirectFileInfo = RedirectFileInfo {size = FileSize finalSize}, redirectEntityId} -> (redirectEntityId, finalSize)
         liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived
-        pure (complete, RFPROG rcvd total)
-      notify c rcvFileEntityId progress
+        pure (entityId, complete, RFPROG rcvd total)
+      notify c entityId progress
       when complete . void $
         getXFTPRcvWorker True c Nothing
       where
@@ -223,7 +249,7 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
         \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
           decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
     decryptFile :: RcvFile -> m ()
-    decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, saveFile, status, chunks} = do
+    decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do
       let CryptoFile savePath cfArgs = saveFile
       fsSavePath <- toFSFilePath savePath
       when (status == RFSDecrypting) $
@@ -231,12 +257,33 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
       withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
       chunkPaths <- getChunkPaths chunks
       encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
+      when (FileSize encSize /= size) $ throwError $ XFTP XFTP.SIZE
+      encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
+      when (FileDigest encDigest /= digest) $ throwError $ XFTP XFTP.DIGEST
       let destFile = CryptoFile fsSavePath cfArgs
       void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure destFile
-      notify c rcvFileEntityId $ RFDONE fsSavePath
-      forM_ tmpPath (removePath <=< toFSFilePath)
-      atomically $ waitUntilForeground c
-      withStore' c (`updateRcvFileComplete` rcvFileId)
+      case redirect of
+        Nothing -> do
+          notify c rcvFileEntityId $ RFDONE fsSavePath
+          forM_ tmpPath (removePath <=< toFSFilePath)
+          atomically $ waitUntilForeground c
+          withStore' c (`updateRcvFileComplete` rcvFileId)
+        Just RcvFileRedirect {redirectFileInfo, redirectDbId} -> do
+          let RedirectFileInfo {size = redirectSize, digest = redirectDigest} = redirectFileInfo
+          forM_ tmpPath (removePath <=< toFSFilePath)
+          atomically $ waitUntilForeground c
+          withStore' c (`updateRcvFileComplete` rcvFileId)
+          -- proceed with redirect
+          yaml <- liftError (INTERNAL . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `finally` (toFSFilePath fsSavePath >>= removePath)
+          next@FileDescription {chunks = nextChunks} <- case strDecode (LB.toStrict yaml) of
+            Left _ -> throwError . XFTP $ XFTP.REDIRECT "decode error"
+            Right (ValidFileDescription fd@FileDescription {size = dstSize, digest = dstDigest})
+              | dstSize /= redirectSize -> throwError . XFTP $ XFTP.REDIRECT "size mismatch"
+              | dstDigest /= redirectDigest -> throwError . XFTP $ XFTP.REDIRECT "digest mismatch"
+              | otherwise -> pure fd
+          -- register and download chunks from the actual file
+          withStore c $ \db -> updateRcvFileRedirect db redirectDbId next
+          forM_ nextChunks (downloadChunk c)
       where
         getChunkPaths :: [RcvFileChunk] -> m [FilePath]
         getChunkPaths [] = pure []
@@ -248,13 +295,22 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
           throwError $ INTERNAL "no chunk path"
 
 xftpDeleteRcvFile' :: AgentMonad m => AgentClient -> RcvFileId -> m ()
-xftpDeleteRcvFile' c rcvFileEntityId = do
-  RcvFile {rcvFileId, prefixPath, status} <- withStore c $ \db -> getRcvFileByEntityId db rcvFileEntityId
-  if status == RFSComplete || status == RFSError
-    then do
-      removePath prefixPath
-      withStore' c (`deleteRcvFile'` rcvFileId)
-    else withStore' c (`updateRcvFileDeleted` rcvFileId)
+xftpDeleteRcvFile' c rcvFileEntityId = xftpDeleteRcvFiles' c [rcvFileEntityId]
+
+xftpDeleteRcvFiles' :: forall m. AgentMonad m => AgentClient -> [RcvFileId] -> m ()
+xftpDeleteRcvFiles' c rcvFileEntityIds = do
+  rcvFiles <- rights <$> withStoreBatch c (\db -> map (fmap (first storeError) . getRcvFileByEntityId db) rcvFileEntityIds)
+  redirects <- rights <$> batchFiles getRcvFileRedirects rcvFiles
+  let (toDelete, toMarkDeleted) = partition fileComplete $ concat redirects <> rcvFiles
+  void $ batchFiles deleteRcvFile' toDelete
+  void $ batchFiles updateRcvFileDeleted toMarkDeleted
+  workPath <- getXFTPWorkPath
+  liftIO . forM_ toDelete $ \RcvFile {prefixPath} ->
+    (removePath . (workPath </>)) prefixPath `catchAll_` pure ()
+  where
+    fileComplete RcvFile {status} = status == RFSComplete || status == RFSError
+    batchFiles :: (DB.Connection -> DBRcvFileId -> IO a) -> [RcvFile] -> m [Either AgentErrorType a]
+    batchFiles f rcvFiles = withStoreBatch' c $ \db -> map (\RcvFile {rcvFileId} -> f db rcvFileId) rcvFiles
 
 notify :: forall m e. (MonadUnliftIO m, AEntityI e) => AgentClient -> EntityId -> ACommand 'Agent e -> m ()
 notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, APC (sAEntity @e) cmd)
@@ -268,7 +324,23 @@ xftpSendFile' c userId file numRecipients = do
   key <- atomically $ C.randomSbKey g
   nonce <- atomically $ C.randomCbNonce g
   -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window
-  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce
+  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing
+  void $ getXFTPSndWorker True c Nothing
+  pure fId
+
+xftpSendDescription' :: forall m. AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> m SndFileId
+xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {size, digest}) numRecipients = do
+  g <- asks random
+  prefixPath <- getPrefixPath "snd.xftp"
+  createDirectory prefixPath
+  let relPrefixPath = takeFileName prefixPath
+  let directYaml = prefixPath </> "direct.yaml"
+  cfArgs <- atomically $ CF.randomArgs g
+  let file = CryptoFile directYaml (Just cfArgs)
+  liftError (INTERNAL . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect)
+  key <- atomically $ C.randomSbKey g
+  nonce <- atomically $ C.randomCbNonce g
+  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce $ Just RedirectFileInfo {size, digest}
   void $ getXFTPSndWorker True c Nothing
   pure fId
 
@@ -318,21 +390,25 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
       where
         AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients, messageRetryInterval = ri} = cfg
         encryptFileForUpload :: SndFile -> FilePath -> m (FileDigest, [(XFTPChunkSpec, FileDigest)])
-        encryptFileForUpload SndFile {key, nonce, srcFile} fsEncPath = do
+        encryptFileForUpload SndFile {key, nonce, srcFile, redirect} fsEncPath = do
           let CryptoFile {filePath} = srcFile
               fileName = takeFileName filePath
           fileSize <- liftIO $ fromInteger <$> CF.getFileContentsSize srcFile
-          when (fileSize > maxFileSize) $ throwError $ INTERNAL "max file size exceeded"
+          when (fileSize > maxFileSizeHard) $ throwError $ INTERNAL "max file size exceeded"
           let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
               fileSize' = fromIntegral (B.length fileHdr) + fileSize
-              chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
-              chunkSizes' = map fromIntegral chunkSizes
-              encSize = sum chunkSizes'
+              payloadSize = fileSize' + fileSizeLen + authTagSize
+          chunkSizes <- case redirect of
+            Nothing -> pure $ prepareChunkSizes payloadSize
+            Just _ -> case singleChunkSize payloadSize of
+              Nothing -> throwError $ INTERNAL "max file size exceeded for redirect"
+              Just chunkSize -> pure [chunkSize]
+          let encSize = sum $ map fromIntegral chunkSizes
           void $ liftError (INTERNAL . show) $ encryptFile srcFile fileHdr key nonce fileSize' encSize fsEncPath
           digest <- liftIO $ LC.sha512Hash <$> LB.readFile fsEncPath
           let chunkSpecs = prepareChunkSpecs fsEncPath chunkSizes
-          chunkDigests <- map FileDigest <$> mapM (liftIO . getChunkDigest) chunkSpecs
-          pure (FileDigest digest, zip chunkSpecs chunkDigests)
+          chunkDigests <- liftIO $ mapM getChunkDigest chunkSpecs
+          pure (FileDigest digest, zip chunkSpecs $ coerce chunkDigests)
         chunkCreated :: SndFileChunk -> Bool
         chunkCreated SndFileChunk {replicas} =
           any (\SndFileChunkReplica {replicaStatus} -> replicaStatus == SFRSCreated) replicas
@@ -423,15 +499,15 @@ runXFTPSndWorker c srv Worker {doWork} = do
         sndFileToDescrs :: SndFile -> m (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient])
         sndFileToDescrs SndFile {digest = Nothing} = throwError $ INTERNAL "snd file has no digest"
         sndFileToDescrs SndFile {chunks = []} = throwError $ INTERNAL "snd file has no chunks"
-        sndFileToDescrs SndFile {digest = Just digest, key, nonce, chunks = chunks@(fstChunk : _)} = do
+        sndFileToDescrs SndFile {digest = Just digest, key, nonce, chunks = chunks@(fstChunk : _), redirect} = do
           let chunkSize = FileSize $ sndChunkSize fstChunk
               size = FileSize $ sum $ map (fromIntegral . sndChunkSize) chunks
           -- snd description
           sndDescrChunks <- mapM toSndDescrChunk chunks
-          let fdSnd = FileDescription {party = SFSender, size, digest, key, nonce, chunkSize, chunks = sndDescrChunks}
+          let fdSnd = FileDescription {party = SFSender, size, digest, key, nonce, chunkSize, chunks = sndDescrChunks, redirect = Nothing}
           validFdSnd <- either (throwError . INTERNAL) pure $ validateFileDescription fdSnd
           -- rcv descriptions
-          let fdRcv = FileDescription {party = SFRecipient, size, digest, key, nonce, chunkSize, chunks = []}
+          let fdRcv = FileDescription {party = SFRecipient, size, digest, key, nonce, chunkSize, chunks = [], redirect}
               fdRcvs = createRcvFileDescriptions fdRcv chunks
           validFdRcvs <- either (throwError . INTERNAL) pure $ mapM validateFileDescription fdRcvs
           pure (validFdSnd, validFdRcvs)
@@ -487,24 +563,38 @@ runXFTPSndWorker c srv Worker {doWork} = do
           any (\SndFileChunkReplica {replicaStatus} -> replicaStatus == SFRSUploaded) replicas
 
 deleteSndFileInternal :: AgentMonad m => AgentClient -> SndFileId -> m ()
-deleteSndFileInternal c sndFileEntityId = do
-  SndFile {sndFileId, prefixPath, status} <- withStore c $ \db -> getSndFileByEntityId db sndFileEntityId
-  if status == SFSComplete || status == SFSError
-    then do
-      forM_ prefixPath $ removePath <=< toFSFilePath
-      withStore' c (`deleteSndFile'` sndFileId)
-    else withStore' c (`updateSndFileDeleted` sndFileId)
+deleteSndFileInternal c sndFileEntityId = deleteSndFilesInternal c [sndFileEntityId]
+
+deleteSndFilesInternal :: forall m. AgentMonad m => AgentClient -> [SndFileId] -> m ()
+deleteSndFilesInternal c sndFileEntityIds = do
+  sndFiles <- rights <$> withStoreBatch c (\db -> map (fmap (first storeError) . getSndFileByEntityId db) sndFileEntityIds)
+  let (toDelete, toMarkDeleted) = partition fileComplete sndFiles
+  workPath <- getXFTPWorkPath
+  liftIO . forM_ toDelete $ \SndFile {prefixPath} ->
+    mapM_ (removePath . (workPath </>)) prefixPath `catchAll_` pure ()
+  batchFiles_ deleteSndFile' toDelete
+  batchFiles_ updateSndFileDeleted toMarkDeleted
+  where
+    fileComplete SndFile {status} = status == SFSComplete || status == SFSError
+    batchFiles_ :: (DB.Connection -> DBSndFileId -> IO a) -> [SndFile] -> m ()
+    batchFiles_ f sndFiles = void $ withStoreBatch' c $ \db -> map (\SndFile {sndFileId} -> f db sndFileId) sndFiles
 
 deleteSndFileRemote :: forall m. AgentMonad m => AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> m ()
-deleteSndFileRemote c userId sndFileEntityId (ValidFileDescription FileDescription {chunks}) = do
-  deleteSndFileInternal c sndFileEntityId `catchAgentError` (notify c sndFileEntityId . SFERR)
-  forM_ chunks $ \ch -> deleteFileChunk ch `catchAgentError` (notify c sndFileEntityId . SFERR)
+deleteSndFileRemote c userId sndFileEntityId sfd = deleteSndFilesRemote c userId [(sndFileEntityId, sfd)]
+
+deleteSndFilesRemote :: forall m. AgentMonad m => AgentClient -> UserId -> [(SndFileId, ValidFileDescription 'FSender)] -> m ()
+deleteSndFilesRemote c userId sndFileIdsDescrs = do
+  deleteSndFilesInternal c (map fst sndFileIdsDescrs) `catchAgentError` (notify c "" . SFERR)
+  let rs = concatMap (mapMaybe chunkReplica . fdChunks . snd) sndFileIdsDescrs
+  void $ withStoreBatch' c (\db -> map (uncurry $ createDeletedSndChunkReplica db userId) rs)
+  let servers = S.fromList $ map (\(FileChunkReplica {server}, _) -> server) rs
+  mapM_ (getXFTPDelWorker True c) servers
   where
-    deleteFileChunk :: FileChunk -> m ()
-    deleteFileChunk FileChunk {digest, replicas = replica@FileChunkReplica {server} : _} = do
-      withStore' c $ \db -> createDeletedSndChunkReplica db userId replica digest
-      void $ getXFTPDelWorker True c server
-    deleteFileChunk _ = pure ()
+    fdChunks (ValidFileDescription FileDescription {chunks}) = chunks
+    chunkReplica :: FileChunk -> Maybe (FileChunkReplica, FileDigest)
+    chunkReplica = \case
+      FileChunk {digest, replicas = replica : _} -> Just (replica, digest)
+      _ -> Nothing
 
 resumeXFTPDelWork :: AgentMonad' m => AgentClient -> XFTPServer -> m ()
 resumeXFTPDelWork = void .: getXFTPDelWorker False

src/Simplex/FileTransfer/Client.hs

@@ -45,7 +45,7 @@ import Simplex.Messaging.Protocol
     RecipientId,
     SenderId,
   )
-import Simplex.Messaging.Transport (supportedParameters)
+import Simplex.Messaging.Transport (THandleParams (..), supportedParameters)
 import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Client
@@ -57,6 +57,7 @@ import UnliftIO.Directory
 data XFTPClient = XFTPClient
   { http2Client :: HTTP2Client,
     transportSession :: TransportSession FileResponse,
+    thParams :: THandleParams XFTPVersion,
     config :: XFTPClientConfig
   }
 
@@ -98,7 +99,9 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkC
   let usePort = if null port then "443" else port
       clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected
   http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
-  let c = XFTPClient {http2Client, transportSession, config}
+  let HTTP2Client {sessionId} = http2Client
+      thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True}
+      c = XFTPClient {http2Client, thParams, transportSession, config}
   atomically $ writeTVar clientVar $ Just c
   pure c
 
@@ -131,21 +134,21 @@ xftpClientError = \case
   HCNetworkError -> PCENetworkError
   HCIOError e -> PCEIOError e
 
-sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
-sendXFTPCommand c@XFTPClient {http2Client = HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
+sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
+sendXFTPCommand c@XFTPClient {thParams} pKey fId cmd chunkSpec_ = do
   t <-
     liftEither . first PCETransportError $
-      xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
+      xftpEncodeAuthTransmission thParams pKey ("", fId, FileCmd (sFileParty @p) cmd)
   sendXFTPTransmission c t chunkSpec_
 
 sendXFTPTransmission :: XFTPClient -> ByteString -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
-sendXFTPTransmission XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}} t chunkSpec_ = do
+sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = do
   let req = H.requestStreaming N.methodPost "/" [] streamBody
       reqTimeout = (\XFTPChunkSpec {chunkSize} -> chunkTimeout config chunkSize) <$> chunkSpec_
-  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2 req reqTimeout
+  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2Client req reqTimeout
   when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
   -- TODO validate that the file ID is the same as in the request?
-  (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission sessionId bodyHead
+  (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead
   case respOrErr of
     Right r -> case protocolError r of
       Just e -> throwError $ PCEProtocolError e
@@ -163,9 +166,9 @@ sendXFTPTransmission XFTPClient {config, http2Client = http2@HTTP2Client {sessio
 
 createXFTPChunk ::
   XFTPClient ->
-  C.APrivateSignKey ->
+  C.APrivateAuthKey ->
   FileInfo ->
-  NonEmpty C.APublicVerifyKey ->
+  NonEmpty C.APublicAuthKey ->
   Maybe BasicAuth ->
   ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
 createXFTPChunk c spKey file rcps auth_ =
@@ -173,17 +176,17 @@ createXFTPChunk c spKey file rcps auth_ =
     (FRSndIds sId rIds, body) -> noFile body (sId, rIds)
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-addXFTPRecipients :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> NonEmpty C.APublicVerifyKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId)
+addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId)
 addXFTPRecipients c spKey fId rcps =
   sendXFTPCommand c spKey fId (FADD rcps) Nothing >>= \case
     (FRRcvIds rIds, body) -> noFile body rIds
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
-uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
+uploadXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
 uploadXFTPChunk c spKey fId chunkSpec =
   sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse
 
-downloadXFTPChunk :: TVar ChaChaDRG -> XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
+downloadXFTPChunk :: TVar ChaChaDRG -> XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
 downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do
   (rDhKey, rpDhKey) <- atomically $ C.generateKeyPair g
   sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case
@@ -205,17 +208,17 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
 chunkTimeout :: XFTPClientConfig -> Word32 -> Int
 chunkTimeout config chunkSize = fromIntegral $ (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1
 
-deleteXFTPChunk :: XFTPClient -> C.APrivateSignKey -> SenderId -> ExceptT XFTPClientError IO ()
+deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
 deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse
 
-ackXFTPChunk :: XFTPClient -> C.APrivateSignKey -> RecipientId -> ExceptT XFTPClientError IO ()
+ackXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> RecipientId -> ExceptT XFTPClientError IO ()
 ackXFTPChunk c rpKey rId = sendXFTPCommand c rpKey rId FACK Nothing >>= okResponse
 
 pingXFTP :: XFTPClient -> ExceptT XFTPClientError IO ()
-pingXFTP c@XFTPClient {http2Client = HTTP2Client {sessionId}} = do
+pingXFTP c@XFTPClient {thParams} = do
   t <-
     liftEither . first PCETransportError $
-      xftpEncodeTransmission sessionId Nothing ("", "", FileCmd SFRecipient PING)
+      xftpEncodeTransmission thParams ("", "", FileCmd SFRecipient PING)
   (r, _) <- sendXFTPTransmission c t Nothing
   case r of
     FRPong -> pure ()

src/Simplex/FileTransfer/Client/Main.hs

@@ -15,9 +15,12 @@ module Simplex.FileTransfer.Client.Main
     CLIError (..),
     xftpClientCLI,
     cliSendFile,
+    cliSendFileOpts,
+    singleChunkSize,
     prepareChunkSizes,
     prepareChunkSpecs,
     maxFileSize,
+    maxFileSizeHard,
     fileSizeLen,
     getChunkDigest,
     SentRecipientReplica (..),
@@ -40,7 +43,7 @@ import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, listToMaybe)
 import qualified Data.Text as T
 import Data.Word (Word32)
 import GHC.Records (HasField (getField))
@@ -62,7 +65,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, XFTPServer, XFTPServerWithAuth)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateAuthKey, XFTPServer, XFTPServerWithAuth)
 import Simplex.Messaging.Server.CLI (getCliCommand')
 import Simplex.Messaging.Util (groupAllOn, ifM, tshow, whenM)
 import System.Exit (exitFailure)
@@ -75,12 +78,17 @@ import UnliftIO.Directory
 xftpClientVersion :: String
 xftpClientVersion = "1.0.1"
 
+-- | Soft limit for XFTP clients. Should be checked and reported to user.
 maxFileSize :: Int64
 maxFileSize = gb 1
 
 maxFileSizeStr :: String
 maxFileSizeStr = B.unpack . strEncode $ FileSize maxFileSize
 
+-- | Hard internal limit for XFTP agent after which it refuses to prepare chunks.
+maxFileSizeHard :: Int64
+maxFileSizeHard = gb 5
+
 fileSizeLen :: Int64
 fileSizeLen = 8
 
@@ -208,25 +216,25 @@ cliCommandP =
 data SentFileChunk = SentFileChunk
   { chunkNo :: Int,
     sndId :: SenderId,
-    sndPrivateKey :: SndPrivateSignKey,
+    sndPrivateKey :: SndPrivateAuthKey,
     chunkSize :: FileSize Word32,
     digest :: FileDigest,
     replicas :: [SentFileChunkReplica]
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 data SentFileChunkReplica = SentFileChunkReplica
   { server :: XFTPServer,
-    recipients :: [(ChunkReplicaId, C.APrivateSignKey)]
+    recipients :: [(ChunkReplicaId, C.APrivateAuthKey)]
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 data SentRecipientReplica = SentRecipientReplica
   { chunkNo :: Int,
     server :: XFTPServer,
     rcvNo :: Int,
     replicaId :: ChunkReplicaId,
-    replicaKey :: C.APrivateSignKey,
+    replicaKey :: C.APrivateAuthKey,
     digest :: FileDigest,
     chunkSize :: FileSize Word32
   }
@@ -297,8 +305,8 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
       withExceptT (CLIError . show) $ encryptFile srcFile fileHdr key nonce fileSize' encSize encPath
       digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
       let chunkSpecs = prepareChunkSpecs encPath chunkSizes
-          fdRcv = FileDescription {party = SFRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
-          fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
+          fdRcv = FileDescription {party = SFRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = [], redirect = Nothing}
+          fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = [], redirect = Nothing}
       logInfo $ "encrypted file to " <> tshow encPath
       pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize)
     uploadFile :: TVar ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
@@ -318,8 +326,8 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
         uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk)
         uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do
           logInfo $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..."
-          (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-          rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519 g)
+          (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+          rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g)
           digest <- liftIO $ getChunkDigest chunkSpec
           let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest}
           c <- withRetry retryCount $ getXFTPServerClient a xftpServer
@@ -387,7 +395,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
             sentChunks
         -- SentFileChunk having sndId and sndPrivateKey represents the current implementation's limitation
         -- that sender uploads each chunk only to one server, so we can use the first replica's server for FileChunkReplica
-        sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateSignKey -> [FileChunkReplica]
+        sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateAuthKey -> [FileChunkReplica]
         sndReplicas [] _ _ = []
         sndReplicas (SentFileChunkReplica {server} : _) replicaId replicaKey = [FileChunkReplica {server, replicaId, replicaKey}]
     writeFileDescriptions :: String -> [FileDescription 'FRecipient] -> FileDescription 'FSender -> IO ([FilePath], FilePath)
@@ -406,7 +414,8 @@ getChunkDigest :: XFTPChunkSpec -> IO ByteString
 getChunkDigest XFTPChunkSpec {filePath = chunkPath, chunkOffset, chunkSize} =
   withFile chunkPath ReadMode $ \h -> do
     hSeek h AbsoluteSeek $ fromIntegral chunkOffset
-    LC.sha256Hash <$> LB.hGet h (fromIntegral chunkSize)
+    chunk <- LB.hGet h (fromIntegral chunkSize)
+    pure $! LC.sha256Hash chunk
 
 cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
 cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, verbose, yes} =
@@ -521,14 +530,19 @@ getFileDescription' path =
   getFileDescription path >>= \case
     AVFD fd -> either (throwError . CLIError) pure $ checkParty fd
 
+singleChunkSize :: Int64 -> Maybe Word32
+singleChunkSize size' =
+  listToMaybe $ dropWhile (< chunkSize) serverChunkSizes
+  where
+    chunkSize = fromIntegral size'
+
 prepareChunkSizes :: Int64 -> [Word32]
 prepareChunkSizes size' = prepareSizes size'
   where
     (smallSize, bigSize)
       | size' > size34 chunkSize3 = (chunkSize2, chunkSize3)
-      | otherwise = (chunkSize1, chunkSize2)
-    --  | size' > size34 chunkSize2 = (chunkSize1, chunkSize2)
-    --  | otherwise = (chunkSize0, chunkSize1)
+      | size' > size34 chunkSize2 = (chunkSize1, chunkSize2)
+      | otherwise = (chunkSize0, chunkSize1)
     size34 sz = (fromIntegral sz * 3) `div` 4
     prepareSizes 0 = []
     prepareSizes size

src/Simplex/FileTransfer/Description.hs

@@ -12,6 +12,7 @@
 
 module Simplex.FileTransfer.Description
   ( FileDescription (..),
+    RedirectFileInfo (..),
     AFileDescription (..),
     ValidFileDescription, -- constructor is not exported, use pattern
     pattern ValidFileDescription,
@@ -30,12 +31,17 @@ module Simplex.FileTransfer.Description
     kb,
     mb,
     gb,
+    FileDescriptionURI (..),
+    FileClientData,
+    fileDescriptionURI,
+    qrSizeLimit,
   )
 where
 
 import Control.Applicative (optional)
 import Control.Monad ((<=<))
 import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as J
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -50,17 +56,21 @@ import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe)
 import Data.String
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word32)
 import qualified Data.Yaml as Y
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
 import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Protocol
+import Simplex.Messaging.Agent.QueryString
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, parseAll)
 import Simplex.Messaging.Protocol (XFTPServer)
-import Simplex.Messaging.Util (bshow, (<$?>))
+import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
+import Simplex.Messaging.Util (bshow, safeDecodeUtf8, (<$?>))
 
 data FileDescription (p :: FileParty) = FileDescription
   { party :: SFileParty p,
@@ -69,7 +79,14 @@ data FileDescription (p :: FileParty) = FileDescription
     key :: C.SbKey,
     nonce :: C.CbNonce,
     chunkSize :: FileSize Word32,
-    chunks :: [FileChunk]
+    chunks :: [FileChunk],
+    redirect :: Maybe RedirectFileInfo
+  }
+  deriving (Eq, Show)
+
+data RedirectFileInfo = RedirectFileInfo
+  { size :: FileSize Int64,
+    digest :: FileDigest
   }
   deriving (Eq, Show)
 
@@ -118,7 +135,7 @@ data FileChunk = FileChunk
 data FileChunkReplica = FileChunkReplica
   { server :: XFTPServer,
     replicaId :: ChunkReplicaId,
-    replicaKey :: C.APrivateSignKey
+    replicaKey :: C.APrivateAuthKey
   }
   deriving (Eq, Show)
 
@@ -147,7 +164,8 @@ data YAMLFileDescription = YAMLFileDescription
     key :: C.SbKey,
     nonce :: C.CbNonce,
     chunkSize :: String,
-    replicas :: [YAMLServerReplicas]
+    replicas :: [YAMLServerReplicas],
+    redirect :: Maybe RedirectFileInfo
   }
   deriving (Eq, Show)
 
@@ -161,7 +179,7 @@ data FileServerReplica = FileServerReplica
   { chunkNo :: Int,
     server :: XFTPServer,
     replicaId :: ChunkReplicaId,
-    replicaKey :: C.APrivateSignKey,
+    replicaKey :: C.APrivateAuthKey,
     digest :: Maybe FileDigest,
     chunkSize :: Maybe (FileSize Word32)
   }
@@ -170,8 +188,16 @@ data FileServerReplica = FileServerReplica
 newtype FileSize a = FileSize {unFileSize :: a}
   deriving (Eq, Show)
 
+instance FromJSON a => FromJSON (FileSize a) where
+  parseJSON v = FileSize <$> Y.parseJSON v
+
+instance ToJSON a => ToJSON (FileSize a) where
+  toJSON = Y.toJSON . unFileSize
+
 $(J.deriveJSON defaultJSON ''YAMLServerReplicas)
 
+$(J.deriveJSON defaultJSON ''RedirectFileInfo)
+
 $(J.deriveJSON defaultJSON ''YAMLFileDescription)
 
 instance FilePartyI p => StrEncoding (ValidFileDescription p) where
@@ -201,10 +227,10 @@ validateFileDescription fd@FileDescription {size, chunks}
   | otherwise = Right $ ValidFD fd
   where
     chunkNos = map (\FileChunk {chunkNo} -> chunkNo) chunks
-    chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0
+    chunksSize = foldl' (\(s :: Int64) FileChunk {chunkSize} -> s + fromIntegral (unFileSize chunkSize)) 0
 
 encodeFileDescription :: FileDescription p -> YAMLFileDescription
-encodeFileDescription FileDescription {party, size, digest, key, nonce, chunkSize, chunks} =
+encodeFileDescription FileDescription {party, size, digest, key, nonce, chunkSize, chunks, redirect} =
   YAMLFileDescription
     { party = toFileParty party,
       size = B.unpack $ strEncode size,
@@ -212,9 +238,39 @@ encodeFileDescription FileDescription {party, size, digest, key, nonce, chunkSiz
       key,
       nonce,
       chunkSize = B.unpack $ strEncode chunkSize,
-      replicas = encodeFileReplicas chunkSize chunks
+      replicas = encodeFileReplicas chunkSize chunks,
+      redirect
     }
 
+data FileDescriptionURI = FileDescriptionURI
+  { scheme :: ServiceScheme,
+    description :: ValidFileDescription 'FRecipient,
+    clientData :: Maybe FileClientData -- JSON-encoded extensions to pass in a link
+  }
+  deriving (Eq, Show)
+
+type FileClientData = Text
+
+fileDescriptionURI :: ValidFileDescription 'FRecipient -> FileDescriptionURI
+fileDescriptionURI vfd = FileDescriptionURI SSSimplex vfd mempty
+
+instance StrEncoding FileDescriptionURI where
+  strEncode FileDescriptionURI {scheme, description, clientData} = mconcat [strEncode scheme, "/file", "#/?", queryStr]
+    where
+      queryStr = strEncode $ QSP QEscape qs
+      qs = ("desc", strEncode description) : maybe [] (\cd -> [("data", encodeUtf8 cd)]) clientData
+  strP = do
+    scheme <- strP
+    _ <- "/file" <* optional (A.char '/') <* "#/?"
+    query <- strP
+    description <- queryParam "desc" query
+    let clientData = safeDecodeUtf8 <$> queryParamStr "data" query
+    pure FileDescriptionURI {scheme, description, clientData}
+
+-- | URL length in QR code before jumping up to a next size.
+qrSizeLimit :: Int
+qrSizeLimit = 1002 -- ~2 chunks in URLencoded YAML with some spare size for server hosts
+
 instance (Integral a, Show a) => StrEncoding (FileSize a) where
   strEncode (FileSize b)
     | b' /= 0 = bshow b
@@ -285,13 +341,13 @@ unfoldChunksToReplicas defChunkSize = concatMap chunkReplicas
        in FileServerReplica {chunkNo, server, replicaId, replicaKey, digest = digest', chunkSize = chunkSize'}
 
 decodeFileDescription :: YAMLFileDescription -> Either String AFileDescription
-decodeFileDescription YAMLFileDescription {party, size, digest, key, nonce, chunkSize, replicas} = do
+decodeFileDescription YAMLFileDescription {party, size, digest, key, nonce, chunkSize, replicas, redirect} = do
   size' <- strDecode $ B.pack size
   chunkSize' <- strDecode $ B.pack chunkSize
   replicas' <- decodeFileParts replicas
   chunks <- foldReplicasToChunks chunkSize' replicas'
   pure $ case aFileParty party of
-    AFP party' -> AFD FileDescription {party = party', size = size', digest, key, nonce, chunkSize = chunkSize', chunks}
+    AFP party' -> AFD FileDescription {party = party', size = size', digest, key, nonce, chunkSize = chunkSize', chunks, redirect}
   where
     decodeFileParts = fmap concat . mapM decodeYAMLServerReplicas
 

src/Simplex/FileTransfer/Protocol.hs

@@ -1,21 +1,22 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 module Simplex.FileTransfer.Protocol where
 
-import Control.Applicative ((<|>))
 import qualified Data.Aeson.TH as J
-import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -24,10 +25,11 @@ import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (isNothing)
 import Data.Type.Equality
 import Data.Word (Word32)
+import Simplex.FileTransfer.Transport (VersionXFTP, XFTPErrorType (..), XFTPVersion, pattern VersionXFTP, xftpClientHandshake)
+import Simplex.Messaging.Client (authTransmission)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
   ( BasicAuth,
@@ -38,25 +40,26 @@ import Simplex.Messaging.Protocol
     ProtocolMsgTag (..),
     ProtocolType (..),
     RcvPublicDhKey,
-    RcvPublicVerifyKey,
+    RcvPublicAuthKey,
     RecipientId,
     SenderId,
     SentRawTransmission,
     SignedTransmission,
-    SndPublicVerifyKey,
+    SndPublicAuthKey,
     Transmission,
+    TransmissionForAuth (..),
+    encodeTransmissionForAuth,
     encodeTransmission,
     messageTagP,
     tDecodeParseValidate,
     tEncodeBatch1,
     tParse,
   )
-import Simplex.Messaging.Transport (SessionId, TransportError (..))
-import Simplex.Messaging.Util (bshow, (<$?>))
-import Simplex.Messaging.Version
+import Simplex.Messaging.Transport (THandleParams (..), TransportError (..))
+import Simplex.Messaging.Util ((<$?>))
 
-currentXFTPVersion :: Version
-currentXFTPVersion = 1
+currentXFTPVersion :: VersionXFTP
+currentXFTPVersion = VersionXFTP 1
 
 xftpBlockSize :: Int
 xftpBlockSize = 16384
@@ -138,18 +141,18 @@ instance ProtocolMsgTag FileCmdTag where
 instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where
   decodeTag s = decodeTag s >>= (\(FCT _ t) -> checkParty' t)
 
-instance Protocol XFTPErrorType FileResponse where
+instance Protocol XFTPVersion XFTPErrorType FileResponse where
   type ProtoCommand FileResponse = FileCmd
   type ProtoType FileResponse = 'PXFTP
-  protocolClientHandshake = ntfClientHandshake
+  protocolClientHandshake = xftpClientHandshake
   protocolPing = FileCmd SFRecipient PING
   protocolError = \case
     FRErr e -> Just e
     _ -> Nothing
 
 data FileCommand (p :: FileParty) where
-  FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FSender
-  FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FSender
+  FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileCommand FSender
+  FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender
   FPUT :: FileCommand FSender
   FDEL :: FileCommand FSender
   FGET :: RcvPublicDhKey -> FileCommand FRecipient
@@ -163,15 +166,15 @@ data FileCmd = forall p. FilePartyI p => FileCmd (SFileParty p) (FileCommand p)
 deriving instance Show FileCmd
 
 data FileInfo = FileInfo
-  { sndKey :: SndPublicVerifyKey,
+  { sndKey :: SndPublicAuthKey,
     size :: Word32,
     digest :: ByteString
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 type XFTPFileId = ByteString
 
-instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where
+instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where
   type Tag (FileCommand p) = FileCommandTag p
   encodeProtocol _v = \case
     FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_)
@@ -187,24 +190,24 @@ instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where
 
   protocolP v tag = (\(FileCmd _ c) -> checkParty c) <$?> protocolP v (FCT (sFileParty @p) tag)
 
-  fromProtocolError = fromProtocolError @XFTPErrorType @FileResponse
+  fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (sig, _, fileId, _) cmd = case cmd of
+  checkCredentials (auth, _, fileId, _) cmd = case cmd of
     -- FNEW must not have signature and chunk ID
     FNEW {}
-      | isNothing sig -> Left $ CMD NO_AUTH
+      | isNothing auth -> Left $ CMD NO_AUTH
       | not (B.null fileId) -> Left $ CMD HAS_AUTH
       | otherwise -> Right cmd
     PING
-      | isNothing sig && B.null fileId -> Right cmd
+      | isNothing auth && B.null fileId -> Right cmd
       | otherwise -> Left $ CMD HAS_AUTH
     -- other client commands must have both signature and queue ID
     _
-      | isNothing sig || B.null fileId -> Left $ CMD NO_AUTH
+      | isNothing auth || B.null fileId -> Left $ CMD NO_AUTH
       | otherwise -> Right cmd
 
-instance ProtocolEncoding XFTPErrorType FileCmd where
+instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where
   type Tag FileCmd = FileCmdTag
   encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c
 
@@ -221,7 +224,7 @@ instance ProtocolEncoding XFTPErrorType FileCmd where
         FACK_ -> pure FACK
         PING_ -> pure PING
 
-  fromProtocolError = fromProtocolError @XFTPErrorType @FileResponse
+  fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
   {-# INLINE fromProtocolError #-}
 
   checkCredentials t (FileCmd p c) = FileCmd p <$> checkCredentials t c
@@ -272,7 +275,7 @@ data FileResponse
   | FRPong
   deriving (Show)
 
-instance ProtocolEncoding XFTPErrorType FileResponse where
+instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
   type Tag FileResponse = FileResponseTag
   encodeProtocol _v = \case
     FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds)
@@ -315,74 +318,6 @@ instance ProtocolEncoding XFTPErrorType FileResponse where
         | B.null entId = Right cmd
         | otherwise = Left $ CMD HAS_AUTH
 
-data XFTPErrorType
-  = -- | incorrect block format, encoding or signature size
-    BLOCK
-  | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929)
-    SESSION
-  | -- | SMP command is unknown or has invalid syntax
-    CMD {cmdErr :: CommandError}
-  | -- | command authorization error - bad signature or non-existing SMP queue
-    AUTH
-  | -- | incorrent file size
-    SIZE
-  | -- | storage quota exceeded
-    QUOTA
-  | -- | incorrent file digest
-    DIGEST
-  | -- | file encryption/decryption failed
-    CRYPTO
-  | -- | no expected file body in request/response or no file on the server
-    NO_FILE
-  | -- | unexpected file body
-    HAS_FILE
-  | -- | file IO error
-    FILE_IO
-  | -- | internal server error
-    INTERNAL
-  | -- | used internally, never returned by the server (to be removed)
-    DUPLICATE_ -- not part of SMP protocol, used internally
-  deriving (Eq, Read, Show)
-
-instance StrEncoding XFTPErrorType where
-  strEncode = \case
-    CMD e -> "CMD " <> bshow e
-    e -> bshow e
-  strP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1
-
-instance Encoding XFTPErrorType where
-  smpEncode = \case
-    BLOCK -> "BLOCK"
-    SESSION -> "SESSION"
-    CMD err -> "CMD " <> smpEncode err
-    AUTH -> "AUTH"
-    SIZE -> "SIZE"
-    QUOTA -> "QUOTA"
-    DIGEST -> "DIGEST"
-    CRYPTO -> "CRYPTO"
-    NO_FILE -> "NO_FILE"
-    HAS_FILE -> "HAS_FILE"
-    FILE_IO -> "FILE_IO"
-    INTERNAL -> "INTERNAL"
-    DUPLICATE_ -> "DUPLICATE_"
-
-  smpP =
-    A.takeTill (== ' ') >>= \case
-      "BLOCK" -> pure BLOCK
-      "SESSION" -> pure SESSION
-      "CMD" -> CMD <$> _smpP
-      "AUTH" -> pure AUTH
-      "SIZE" -> pure SIZE
-      "QUOTA" -> pure QUOTA
-      "DIGEST" -> pure DIGEST
-      "CRYPTO" -> pure CRYPTO
-      "NO_FILE" -> pure NO_FILE
-      "HAS_FILE" -> pure HAS_FILE
-      "FILE_IO" -> pure FILE_IO
-      "INTERNAL" -> pure INTERNAL
-      "DUPLICATE_" -> pure DUPLICATE_
-      _ -> fail "bad error type"
-
 checkParty :: forall t p p'. (FilePartyI p, FilePartyI p') => t p' -> Either String (t p)
 checkParty c = case testEquality (sFileParty @p) (sFileParty @p') of
   Just Refl -> Right c
@@ -393,25 +328,25 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
   Just Refl -> Just c
   _ -> Nothing
 
-xftpEncodeTransmission :: ProtocolEncoding e c => SessionId -> Maybe C.APrivateSignKey -> Transmission c -> Either TransportError ByteString
-xftpEncodeTransmission sessionId pKey (corrId, fId, msg) = do
-  let t = encodeTransmission currentXFTPVersion sessionId (corrId, fId, msg)
-  xftpEncodeBatch1 $ signTransmission t
-  where
-    signTransmission :: ByteString -> SentRawTransmission
-    signTransmission t = ((`C.sign` t) <$> pKey, t)
+xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
+xftpEncodeAuthTransmission thParams pKey (corrId, fId, msg) = do
+  let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, fId, msg)
+  xftpEncodeBatch1 . (,tToSend) =<< authTransmission Nothing (Just pKey) corrId tForAuth
+
+xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> Transmission c -> Either TransportError ByteString
+xftpEncodeTransmission thParams (corrId, fId, msg) = do
+  let t = encodeTransmission thParams (corrId, fId, msg)
+  xftpEncodeBatch1 (Nothing, t)
 
 -- this function uses batch syntax but puts only one transmission in the batch
 xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString
 xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 t) xftpBlockSize
 
-xftpDecodeTransmission :: ProtocolEncoding e c => SessionId -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
-xftpDecodeTransmission sessionId t = do
+xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
+xftpDecodeTransmission thParams t = do
   t' <- first (const BLOCK) $ C.unPad t
-  case tParse True t' of
-    t'' :| [] -> Right $ tDecodeParseValidate sessionId currentXFTPVersion t''
+  case tParse thParams t' of
+    t'' :| [] -> Right $ tDecodeParseValidate thParams t''
     _ -> Left BLOCK
 
 $(J.deriveJSON (enumJSON $ dropPrefix "F") ''FileParty)
-
-$(J.deriveJSON (sumTypeJSON id) ''XFTPErrorType)

src/Simplex/FileTransfer/Server.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -17,16 +18,15 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Bifunctor (first)
-import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Builder (byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
@@ -46,13 +46,16 @@ import Simplex.FileTransfer.Server.StoreLog
 import Simplex.FileTransfer.Transport
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
+import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicVerifyKey, RecipientId)
-import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
+import Simplex.Messaging.Protocol (CorrId, RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth)
+import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Stats
+import Simplex.Messaging.Transport (THandleParams (..))
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
+import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
 import Simplex.Messaging.Transport.HTTP2.Server
 import Simplex.Messaging.Transport.Server (runTCPServer)
 import Simplex.Messaging.Util
@@ -66,6 +69,13 @@ import qualified UnliftIO.Exception as E
 
 type M a = ReaderT XFTPEnv IO a
 
+data XFTPTransportRequest = XFTPTransportRequest
+  { thParams :: THandleParams XFTPVersion,
+    reqBody :: HTTP2Body,
+    request :: H.Request,
+    sendResponse :: H.Response -> IO ()
+  }
+
 runXFTPServer :: XFTPServerConfig -> IO ()
 runXFTPServer cfg = do
   started <- newEmptyTMVarIO
@@ -86,7 +96,8 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       liftIO $
         runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration $ \sessionId r sendResponse -> do
           reqBody <- getHTTP2Body r xftpBlockSize
-          processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse} `runReaderT` env
+          let thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True}
+          processRequest XFTPTransportRequest {thParams, request = r, reqBody, sendResponse} `runReaderT` env
 
     stopServer :: M ()
     stopServer = do
@@ -187,17 +198,32 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           hSetBuffering h LineBuffering
           hSetNewlineMode h universalNewlineMode
           hPutStrLn h "XFTP server control port\n'help' for supported commands"
-          cpLoop h
+          role <- newTVarIO CPRNone
+          cpLoop h role
           where
-            cpLoop h = do
-              s <- B.hGetLine h
-              case strDecode $ trimCR s of
+            cpLoop h role  = do
+              s <- trimCR <$> B.hGetLine h
+              case strDecode s of
                 Right CPQuit -> hClose h
-                Right cmd -> processCP h cmd >> cpLoop h
-                Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h
-            processCP h = \case
+                Right cmd -> logCmd s cmd >> processCP h role cmd >> cpLoop h role
+                Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h role
+            logCmd s cmd = when shouldLog $ logWarn $ "ControlPort: " <> tshow s
+              where
+                shouldLog = case cmd of
+                  CPAuth _ -> False
+                  CPHelp -> False
+                  CPQuit -> False
+                  CPSkip -> False
+                  _ -> True
+            processCP h role = \case
+              CPAuth auth -> atomically $ writeTVar role $! newRole cfg
+                where
+                  newRole XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
+                    | Just auth == admin = CPRAdmin
+                    | Just auth == user = CPRUser
+                    | otherwise = CPRNone
               CPStatsRTS -> E.tryAny getRTSStats >>= either (hPrint h) (hPrint h)
-              CPDelete fileId -> unliftIO u $ do
+              CPDelete fileId -> withUserRole $ unliftIO u $ do
                 fs <- asks store
                 r <- runExceptT $ do
                   let asSender = ExceptT . atomically $ getFile fs SFSender fileId
@@ -208,6 +234,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
               CPHelp -> hPutStrLn h "commands: stats-rts, delete, help, quit"
               CPQuit -> pure ()
               CPSkip -> pure ()
+              where
+                withUserRole action = readTVarIO role >>= \case
+                  CPRAdmin -> action
+                  CPRUser -> action
+                  _ -> do
+                    logError "Unauthorized control port command"
+                    hPutStrLn h "AUTH"
 
 data ServerFile = ServerFile
   { filePath :: FilePath,
@@ -215,11 +248,11 @@ data ServerFile = ServerFile
     sbState :: LC.SbState
   }
 
-processRequest :: HTTP2Request -> M ()
-processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
+processRequest :: XFTPTransportRequest -> M ()
+processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
   | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing
   | otherwise = do
-      case xftpDecodeTransmission sessionId bodyHead of
+      case xftpDecodeTransmission thParams bodyHead of
         Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do
           case cmdOrErr of
             Right cmd -> do
@@ -233,7 +266,7 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen
   where
     sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M ()
     sendXFTPResponse (corrId, fId, resp) serverFile_ = do
-      let t_ = xftpEncodeTransmission sessionId Nothing (corrId, fId, resp)
+      let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
       liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_
       where
         streamBody t_ send done = do
@@ -250,10 +283,10 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen
 
 data VerificationResult = VRVerified XFTPRequest | VRFailed
 
-verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
-verifyXFTPTransmission sig_ signed fId cmd =
+verifyXFTPTransmission :: Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
+verifyXFTPTransmission tAuth authorized fId cmd =
   case cmd of
-    FileCmd SFSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file
+    FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
     FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
     FileCmd party _ -> verifyCmd party
   where
@@ -264,8 +297,9 @@ verifyXFTPTransmission sig_ signed fId cmd =
       where
         verify = \case
           Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k
-          _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
-    req `verifyWith` k = if verifyCmdSignature sig_ signed k then VRVerified req else VRFailed
+          _ -> maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed
+    -- TODO verify with DH authorization
+    req `verifyWith` k = if verifyCmdAuthorization Nothing tAuth authorized k then VRVerified req else VRFailed
 
 processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
 processXFTPRequest HTTP2Body {bodyPart} = \case
@@ -286,7 +320,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
   XFTPReqPing -> noFile FRPong
   where
     noFile resp = pure (resp, Nothing)
-    createFile :: FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse
+    createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M FileResponse
     createFile file rks = do
       st <- asks store
       r <- runExceptT $ do
@@ -310,7 +344,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       retryAdd n $ \sId -> runExceptT $ do
         ExceptT $ addFile st sId file ts
         pure sId
-    addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicVerifyKey -> M (Either XFTPErrorType FileRecipient)
+    addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicAuthKey -> M (Either XFTPErrorType FileRecipient)
     addRecipientRetry st n sId rpk =
       retryAdd n $ \rId -> runExceptT $ do
         let rcp = FileRecipient rId rpk
@@ -323,7 +357,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       atomically (add fId) >>= \case
         Left DUPLICATE_ -> retryAdd (n - 1) add
         r -> pure r
-    addRecipients :: XFTPFileId -> NonEmpty RcvPublicVerifyKey -> M FileResponse
+    addRecipients :: XFTPFileId -> NonEmpty RcvPublicAuthKey -> M FileResponse
     addRecipients sId rks = do
       st <- asks store
       r <- runExceptT $ do
@@ -335,35 +369,47 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         pure $ FRRcvIds rIds
       pure $ either FRErr id r
     receiveServerFile :: FileRec -> M FileResponse
-    receiveServerFile fr@FileRec {senderId, fileInfo} = case bodyPart of
-      -- TODO do not allow repeated file upload
+    receiveServerFile FileRec {senderId, fileInfo = FileInfo {size, digest}, filePath} = case bodyPart of
       Nothing -> pure $ FRErr SIZE
-      Just getBody -> do
-        -- TODO validate body size before downloading, once it's populated
-        path <- asks $ filesPath . config
-        let fPath = path </> B.unpack (B64.encode senderId)
-            FileInfo {size, digest} = fileInfo
-        withFileLog $ \sl -> logPutFile sl senderId fPath
-        st <- asks store
-        quota_ <- asks $ fileSizeQuota . config
-        -- TODO timeout file upload, remove partially uploaded files
-        stats <- asks serverStats
-        liftIO $
-          runExceptT (receiveFile getBody (XFTPRcvChunkSpec fPath size digest)) >>= \case
-            Right () -> do
-              used <- readTVarIO $ usedStorage st
-              if maybe False (used + fromIntegral size >) quota_
-                then remove fPath $> FRErr QUOTA
-                else do
-                  atomically (setFilePath' st fr fPath)
-                  atomically $ modifyTVar' (filesUploaded stats) (+ 1)
-                  atomically $ modifyTVar' (filesCount stats) (+ 1)
-                  atomically $ modifyTVar' (filesSize stats) (+ fromIntegral size)
-                  pure FROk
-            Left e -> remove fPath $> FRErr e
+      -- TODO validate body size from request before downloading, once it's populated
+      Just getBody -> skipCommitted $ ifM reserve receive (pure $ FRErr QUOTA)
         where
-          remove fPath = whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError
-
+          -- having a filePath means the file is already uploaded and committed, must not change anything
+          skipCommitted = ifM (isJust <$> readTVarIO filePath) (liftIO $ drain $ fromIntegral size)
+            where
+              -- can't send FROk without reading the request body or a client will block on sending it
+              -- can't send any old error as the client would fail or restart indefinitely
+              drain s = do
+                bs <- B.length <$> getBody fileBlockSize
+                if
+                  | bs == s -> pure FROk
+                  | bs == 0 || bs > s -> pure $ FRErr SIZE
+                  | otherwise -> drain (s - bs)
+          reserve = do
+            us <- asks $ usedStorage . store
+            quota <- asks $ fromMaybe maxBound . fileSizeQuota . config
+            atomically . stateTVar us $
+              \used -> let used' = used + fromIntegral size in if used' <= quota then (True, used') else (False, used)
+          receive = do
+            path <- asks $ filesPath . config
+            let fPath = path </> B.unpack (U.encode senderId)
+            receiveChunk (XFTPRcvChunkSpec fPath size digest) >>= \case
+              Right () -> do
+                stats <- asks serverStats
+                withFileLog $ \sl -> logPutFile sl senderId fPath
+                atomically $ writeTVar filePath (Just fPath)
+                atomically $ modifyTVar' (filesUploaded stats) (+ 1)
+                atomically $ modifyTVar' (filesCount stats) (+ 1)
+                atomically $ modifyTVar' (filesSize stats) (+ fromIntegral size)
+                pure FROk
+              Left e -> do
+                us <- asks $ usedStorage . store
+                atomically . modifyTVar' us $ subtract (fromIntegral size)
+                liftIO $ whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError
+                pure $ FRErr e
+          receiveChunk spec = do
+            t <- asks $ fileTimeout . config
+            liftIO $ fromMaybe (Left TIMEOUT) <$> timeout t (runExceptT (receiveFile getBody spec) `catchAll_` pure (Left FILE_IO))
     sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
     sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do
       readTVarIO filePath >>= \case

src/Simplex/FileTransfer/Server/Control.hs

@@ -5,10 +5,15 @@ module Simplex.FileTransfer.Server.Control where
 
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString (ByteString)
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (BasicAuth)
+
+data CPClientRole = CPRNone | CPRUser | CPRAdmin
 
 data ControlProtocol
-  = CPStatsRTS
+  = CPAuth BasicAuth
+  | CPStatsRTS
   | CPDelete ByteString
   | CPHelp
   | CPQuit
@@ -16,15 +21,17 @@ data ControlProtocol
 
 instance StrEncoding ControlProtocol where
   strEncode = \case
+    CPAuth tok -> "auth " <> strEncode tok
     CPStatsRTS -> "stats-rts"
-    CPDelete bs -> "delete " <> strEncode bs
+    CPDelete fId -> strEncode (Str "delete", fId)
     CPHelp -> "help"
     CPQuit -> "quit"
     CPSkip -> ""
   strP =
     A.takeTill (== ' ') >>= \case
+      "auth" -> CPAuth <$> _strP
       "stats-rts" -> pure CPStatsRTS
-      "delete" -> CPDelete <$> (A.space *> strP)
+      "delete" -> CPDelete <$> _strP
       "help" -> pure CPHelp
       "quit" -> pure CPQuit
       "" -> pure CPSkip

src/Simplex/FileTransfer/Server/Env.hs

@@ -14,17 +14,18 @@ import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.Map.Strict as M
 import Data.Time.Clock (getCurrentTime)
 import Data.Word (Word32)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket
 import qualified Network.TLS as T
-import Simplex.FileTransfer.Protocol (FileCmd, FileInfo, XFTPFileId)
+import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
 import Simplex.FileTransfer.Server.Stats
 import Simplex.FileTransfer.Server.Store
 import Simplex.FileTransfer.Server.StoreLog
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Protocol (BasicAuth, RcvPublicVerifyKey)
+import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
 import Simplex.Messaging.Util (tshow)
@@ -45,8 +46,13 @@ data XFTPServerConfig = XFTPServerConfig
     allowNewFiles :: Bool,
     -- | simple password that the clients need to pass in handshake to be able to create new files
     newFileBasicAuth :: Maybe BasicAuth,
+    -- | control port passwords,
+    controlPortUserAuth :: Maybe BasicAuth,
+    controlPortAdminAuth :: Maybe BasicAuth,
     -- | time after which the files can be removed and check interval, seconds
     fileExpiration :: Maybe ExpirationConfig,
+    -- | timeout to receive file
+    fileTimeout :: Int,
     -- | time after which inactive clients can be disconnected and check interval, seconds
     inactiveClientExpiration :: Maybe ExpirationConfig,
     -- CA certificate private key is not needed for initialization
@@ -93,7 +99,8 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
   random <- liftIO C.newRandom
   store <- atomically newFileStore
   storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile
-  used <- readTVarIO (usedStorage store)
+  used <- countUsedStorage <$> readTVarIO (files store)
+  atomically $ writeTVar (usedStorage store) used
   forM_ fileSizeQuota $ \quota -> do
     logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
     when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
@@ -102,7 +109,10 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
   serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime
   pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
 
+countUsedStorage :: M.Map k FileRec -> Int64
+countUsedStorage = M.foldl' (\acc FileRec {fileInfo = FileInfo {size}} -> acc + fromIntegral size) 0
+
 data XFTPRequest
-  = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth)
+  = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth)
   | XFTPReqCmd XFTPFileId FileRec FileCmd
   | XFTPReqPing

src/Simplex/FileTransfer/Server/Main.hs

@@ -25,6 +25,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
 import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
@@ -32,9 +33,6 @@ import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
-xftpServerVersion :: String
-xftpServerVersion = "1.2.2.0"
-
 xftpServerCLI :: FilePath -> FilePath -> IO ()
 xftpServerCLI cfgPath logPath = do
   getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
@@ -42,6 +40,10 @@ xftpServerCLI cfgPath logPath = do
       doesFileExist iniFile >>= \case
         True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
         _ -> initializeServer opts
+    OnlineCert certOpts ->
+      doesFileExist iniFile >>= \case
+        True -> genOnline cfgPath certOpts
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
     Start ->
       doesFileExist iniFile >>= \case
         True -> readIniFile iniFile >>= either exitError runServer
@@ -53,7 +55,7 @@ xftpServerCLI cfgPath logPath = do
       putStrLn "Deleted configuration and log files"
   where
     iniFile = combine cfgPath "file-server.ini"
-    serverVersion = "SimpleX XFTP server v" <> xftpServerVersion
+    serverVersion = "SimpleX XFTP server v" <> simplexMQVersion
     defaultServerPort = "443"
     executableName = "file-server"
     storeLogFilePath = combine logPath "file-server-store.log"
@@ -95,6 +97,8 @@ xftpServerCLI cfgPath logPath = do
                \# with the users who you want to allow uploading files to your server.\n\
                \# create_password: password to upload files (any printable ASCII characters without whitespace, '@', ':' and '/')\n\
                \\n\
+               \# control_port_admin_password:\n\
+               \# control_port_user_password:\n\
                \[TRANSPORT]\n\
                \# host is only used to print server address on start\n"
             <> ("host: " <> host <> "\n")
@@ -153,11 +157,14 @@ xftpServerCLI cfgPath logPath = do
               allowedChunkSizes = serverChunkSizes,
               allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini,
               newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
+              controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini,
+              controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini,
               fileExpiration =
                 Just
                   defaultFileExpiration
                     { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
                     },
+              fileTimeout = 10 * 60 * 1000000, -- 10 mins to send 4mb chunk
               inactiveClientExpiration =
                 settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
                   $> ExpirationConfig
@@ -179,6 +186,7 @@ xftpServerCLI cfgPath logPath = do
 
 data CliCommand
   = Init InitOptions
+  | OnlineCert CertOptions
   | Start
   | Delete
 
@@ -196,6 +204,7 @@ cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
 cliCommandP cfgPath logPath iniFile =
   hsubparser
     ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
+        <> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")"))
         <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
     )

src/Simplex/FileTransfer/Server/Store.hs

@@ -11,7 +11,6 @@ module Simplex.FileTransfer.Server.Store
     newFileStore,
     addFile,
     setFilePath,
-    setFilePath',
     addRecipient,
     deleteFile,
     deleteRecipient,
@@ -23,22 +22,22 @@ where
 
 import Control.Concurrent.STM
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Time.Clock.System (SystemTime (..))
-import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPErrorType (..), XFTPFileId)
+import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId)
+import Simplex.FileTransfer.Transport (XFTPErrorType (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId)
+import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (ifM, ($>>=))
 
 data FileStore = FileStore
   { files :: TMap SenderId FileRec,
-    recipients :: TMap RecipientId (SenderId, RcvPublicVerifyKey),
+    recipients :: TMap RecipientId (SenderId, RcvPublicAuthKey),
     usedStorage :: TVar Int64
   }
 
@@ -49,9 +48,8 @@ data FileRec = FileRec
     recipientIds :: TVar (Set RecipientId),
     createdAt :: SystemTime
   }
-  deriving (Eq)
 
-data FileRecipient = FileRecipient RecipientId RcvPublicVerifyKey
+data FileRecipient = FileRecipient RecipientId RcvPublicAuthKey
 
 instance StrEncoding FileRecipient where
   strEncode (FileRecipient rId rKey) = strEncode rId <> ":" <> strEncode rKey
@@ -79,12 +77,10 @@ newFileRec senderId fileInfo createdAt = do
 
 setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ())
 setFilePath st sId fPath =
-  withFile st sId $ \fr -> setFilePath' st fr fPath $> Right ()
-
-setFilePath' :: FileStore -> FileRec -> FilePath -> STM ()
-setFilePath' st FileRec {fileInfo, filePath} fPath = do
-  writeTVar filePath (Just fPath)
-  modifyTVar' (usedStorage st) (+ fromIntegral (size fileInfo))
+  withFile st sId $ \FileRec {fileInfo, filePath} -> do
+    writeTVar filePath (Just fPath)
+    modifyTVar' (usedStorage st) (+ fromIntegral (size fileInfo))
+    pure $ Right ()
 
 addRecipient :: FileStore -> SenderId -> FileRecipient -> STM (Either XFTPErrorType ())
 addRecipient st@FileStore {recipients} senderId (FileRecipient rId rKey) =
@@ -113,7 +109,7 @@ deleteRecipient FileStore {recipients} rId FileRec {recipientIds} = do
   TM.delete rId recipients
   modifyTVar' recipientIds $ S.delete rId
 
-getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicVerifyKey))
+getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicAuthKey))
 getFile st party fId = case party of
   SFSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f))
   SFRecipient ->

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -31,7 +31,7 @@ import Data.Time.Clock.System (SystemTime)
 import Simplex.FileTransfer.Protocol (FileInfo (..))
 import Simplex.FileTransfer.Server.Store
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId)
+import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Util (bshow, whenM)
 import System.Directory (doesFileExist, renameFile)
@@ -109,7 +109,7 @@ writeFileStore s FileStore {files, recipients} = do
   allRcps <- readTVarIO recipients
   readTVarIO files >>= mapM_ (logFile allRcps)
   where
-    logFile :: Map RecipientId (SenderId, RcvPublicVerifyKey) -> FileRec -> IO ()
+    logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO ()
     logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} = do
       logAddFile s senderId fileInfo createdAt
       (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds

src/Simplex/FileTransfer/Transport.hs

@@ -1,10 +1,19 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.FileTransfer.Transport
   ( supportedFileServerVRange,
+    xftpClientHandshake, -- stub
+    XFTPVersion,
+    VersionXFTP,
+    pattern VersionXFTP,
+    XFTPErrorType (..),
     XFTPRcvChunkSpec (..),
     ReceiveFileError (..),
     receiveFile,
@@ -14,22 +23,31 @@ module Simplex.FileTransfer.Transport
   )
 where
 
+import Control.Applicative ((<|>))
 import qualified Control.Exception as E
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
+import qualified Data.Aeson.TH as J
+import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import qualified Data.ByteArray as BA
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Word (Word32)
-import Simplex.FileTransfer.Protocol (XFTPErrorType (..))
+import Data.Word (Word16, Word32)
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers
+import Simplex.Messaging.Protocol (CommandError)
+import Simplex.Messaging.Transport (HandshakeError (..), THandle, TransportError (..))
 import Simplex.Messaging.Transport.HTTP2.File
+import Simplex.Messaging.Util (bshow)
 import Simplex.Messaging.Version
+import Simplex.Messaging.Version.Internal
 import System.IO (Handle, IOMode (..), withFile)
 
 data XFTPRcvChunkSpec = XFTPRcvChunkSpec
@@ -39,8 +57,26 @@ data XFTPRcvChunkSpec = XFTPRcvChunkSpec
   }
   deriving (Show)
 
-supportedFileServerVRange :: VersionRange
-supportedFileServerVRange = mkVersionRange 1 1
+data XFTPVersion
+
+instance VersionScope XFTPVersion
+
+type VersionXFTP = Version XFTPVersion
+
+type VersionRangeXFTP = VersionRange XFTPVersion
+
+pattern VersionXFTP :: Word16 -> VersionXFTP
+pattern VersionXFTP v = Version v
+
+initialXFTPVersion :: VersionXFTP
+initialXFTPVersion = VersionXFTP 1
+
+supportedFileServerVRange :: VersionRangeXFTP
+supportedFileServerVRange = mkVersionRange initialXFTPVersion initialXFTPVersion
+
+-- XFTP protocol does not support handshake
+xftpClientHandshake :: c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c)
+xftpClientHandshake _c _ks _keyHash _xftpVRange = throwError $ TEHandshake VERSION
 
 sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
 sendEncFile h send = go
@@ -97,3 +133,85 @@ receiveFile_ receive XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do
   ExceptT $ withFile filePath WriteMode (`receive` chunkSize)
   digest' <- liftIO $ LC.sha256Hash <$> LB.readFile filePath
   when (digest' /= chunkDigest) $ throwError DIGEST
+
+data XFTPErrorType
+  = -- | incorrect block format, encoding or signature size
+    BLOCK
+  | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929)
+    SESSION
+  | -- | SMP command is unknown or has invalid syntax
+    CMD {cmdErr :: CommandError}
+  | -- | command authorization error - bad signature or non-existing SMP queue
+    AUTH
+  | -- | incorrent file size
+    SIZE
+  | -- | storage quota exceeded
+    QUOTA
+  | -- | incorrent file digest
+    DIGEST
+  | -- | file encryption/decryption failed
+    CRYPTO
+  | -- | no expected file body in request/response or no file on the server
+    NO_FILE
+  | -- | unexpected file body
+    HAS_FILE
+  | -- | file IO error
+    FILE_IO
+  | -- | file sending timeout
+    TIMEOUT
+  | -- | bad redirect data
+    REDIRECT {redirectError :: String}
+  | -- | internal server error
+    INTERNAL
+  | -- | used internally, never returned by the server (to be removed)
+    DUPLICATE_ -- not part of SMP protocol, used internally
+  deriving (Eq, Read, Show)
+
+instance StrEncoding XFTPErrorType where
+  strEncode = \case
+    CMD e -> "CMD " <> bshow e
+    REDIRECT e -> "REDIRECT " <> bshow e
+    e -> bshow e
+  strP =
+    "CMD " *> (CMD <$> parseRead1)
+      <|> "REDIRECT " *> (REDIRECT <$> parseRead A.takeByteString)
+      <|> parseRead1
+
+instance Encoding XFTPErrorType where
+  smpEncode = \case
+    BLOCK -> "BLOCK"
+    SESSION -> "SESSION"
+    CMD err -> "CMD " <> smpEncode err
+    AUTH -> "AUTH"
+    SIZE -> "SIZE"
+    QUOTA -> "QUOTA"
+    DIGEST -> "DIGEST"
+    CRYPTO -> "CRYPTO"
+    NO_FILE -> "NO_FILE"
+    HAS_FILE -> "HAS_FILE"
+    FILE_IO -> "FILE_IO"
+    TIMEOUT -> "TIMEOUT"
+    REDIRECT err -> "REDIRECT " <> smpEncode err
+    INTERNAL -> "INTERNAL"
+    DUPLICATE_ -> "DUPLICATE_"
+
+  smpP =
+    A.takeTill (== ' ') >>= \case
+      "BLOCK" -> pure BLOCK
+      "SESSION" -> pure SESSION
+      "CMD" -> CMD <$> _smpP
+      "AUTH" -> pure AUTH
+      "SIZE" -> pure SIZE
+      "QUOTA" -> pure QUOTA
+      "DIGEST" -> pure DIGEST
+      "CRYPTO" -> pure CRYPTO
+      "NO_FILE" -> pure NO_FILE
+      "HAS_FILE" -> pure HAS_FILE
+      "FILE_IO" -> pure FILE_IO
+      "TIMEOUT" -> pure TIMEOUT
+      "REDIRECT" -> REDIRECT <$> _smpP
+      "INTERNAL" -> pure INTERNAL
+      "DUPLICATE_" -> pure DUPLICATE_
+      _ -> fail "bad error type"
+
+$(J.deriveJSON (sumTypeJSON id) ''XFTPErrorType)

src/Simplex/FileTransfer/Types.hs

@@ -47,6 +47,7 @@ data RcvFile = RcvFile
     key :: C.SbKey,
     nonce :: C.CbNonce,
     chunkSize :: FileSize Word32,
+    redirect :: Maybe RcvFileRedirect,
     chunks :: [RcvFileChunk],
     prefixPath :: FilePath,
     tmpPath :: Maybe FilePath,
@@ -54,7 +55,7 @@ data RcvFile = RcvFile
     status :: RcvFileStatus,
     deleted :: Bool
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 data RcvFileStatus
   = RFSReceiving
@@ -95,18 +96,25 @@ data RcvFileChunk = RcvFileChunk
     fileTmpPath :: FilePath,
     chunkTmpPath :: Maybe FilePath
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 data RcvFileChunkReplica = RcvFileChunkReplica
   { rcvChunkReplicaId :: Int64,
     server :: XFTPServer,
     replicaId :: ChunkReplicaId,
-    replicaKey :: C.APrivateSignKey,
+    replicaKey :: C.APrivateAuthKey,
     received :: Bool,
     delay :: Maybe Int64,
     retries :: Int
   }
-  deriving (Eq, Show)
+  deriving (Show)
+
+data RcvFileRedirect = RcvFileRedirect
+  { redirectDbId :: DBRcvFileId,
+    redirectEntityId :: RcvFileId,
+    redirectFileInfo :: RedirectFileInfo
+  }
+  deriving (Show)
 
 -- Sending files
 
@@ -124,9 +132,10 @@ data SndFile = SndFile
     srcFile :: CryptoFile,
     prefixPath :: Maybe FilePath,
     status :: SndFileStatus,
-    deleted :: Bool
+    deleted :: Bool,
+    redirect :: Maybe RedirectFileInfo
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 sndFileEncPath :: FilePath -> FilePath
 sndFileEncPath prefixPath = prefixPath </> "xftp.encrypted"
@@ -173,7 +182,7 @@ data SndFileChunk = SndFileChunk
     digest :: FileDigest,
     replicas :: [SndFileChunkReplica]
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 sndChunkSize :: SndFileChunk -> Word32
 sndChunkSize SndFileChunk {chunkSpec = XFTPChunkSpec {chunkSize}} = chunkSize
@@ -181,22 +190,22 @@ sndChunkSize SndFileChunk {chunkSpec = XFTPChunkSpec {chunkSize}} = chunkSize
 data NewSndChunkReplica = NewSndChunkReplica
   { server :: XFTPServer,
     replicaId :: ChunkReplicaId,
-    replicaKey :: C.APrivateSignKey,
-    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)]
+    replicaKey :: C.APrivateAuthKey,
+    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)]
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 data SndFileChunkReplica = SndFileChunkReplica
   { sndChunkReplicaId :: Int64,
     server :: XFTPServer,
     replicaId :: ChunkReplicaId,
-    replicaKey :: C.APrivateSignKey,
-    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)],
+    replicaKey :: C.APrivateAuthKey,
+    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)],
     replicaStatus :: SndFileReplicaStatus,
     delay :: Maybe Int64,
     retries :: Int
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 data SndFileReplicaStatus
   = SFRSCreated
@@ -221,9 +230,9 @@ data DeletedSndChunkReplica = DeletedSndChunkReplica
     userId :: Int64,
     server :: XFTPServer,
     replicaId :: ChunkReplicaId,
-    replicaKey :: C.APrivateSignKey,
+    replicaKey :: C.APrivateAuthKey,
     chunkDigest :: FileDigest,
     delay :: Maybe Int64,
     retries :: Int
   }
-  deriving (Eq, Show)
+  deriving (Show)

src/Simplex/Messaging/Agent/Client.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
@@ -28,9 +29,11 @@ module Simplex.Messaging.Agent.Client
     withInvLock,
     closeAgentClient,
     closeProtocolServerClients,
+    reconnectServerClients,
     closeXFTPServerClient,
     runSMPServerTest,
     runXFTPServerTest,
+    runNTFServerTest,
     getXFTPWorkPath,
     newRcvQueue,
     subscribeQueues,
@@ -107,8 +110,6 @@ module Simplex.Messaging.Agent.Client
     whenSuspending,
     withStore,
     withStore',
-    withStoreCtx,
-    withStoreCtx',
     withStoreBatch,
     withStoreBatch',
     storeError,
@@ -121,11 +122,14 @@ module Simplex.Messaging.Agent.Client
     getAgentWorkersDetails,
     AgentWorkersSummary (..),
     getAgentWorkersSummary,
+    SMPTransportSession,
+    NtfTransportSession,
+    XFTPTransportSession,
   )
 where
 
 import Control.Applicative ((<|>))
-import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent (ThreadId, forkIO, threadDelay)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
 import Control.Concurrent.STM (retry, throwSTM)
 import Control.Exception (AsyncException (..))
@@ -135,11 +139,12 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 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 Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Composition ((.:.))
 import Data.Either (lefts, partitionEithers)
 import Data.Functor (($>))
 import Data.List (deleteFirstsBy, foldl', partition, (\\))
@@ -147,7 +152,7 @@ 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 (isNothing, listToMaybe)
+import Data.Maybe (isJust, isNothing, listToMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -155,14 +160,12 @@ import Data.Text.Encoding
 import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
 import Data.Word (Word16)
-
--- import GHC.Conc (unsafeIOToSTM)
 import Network.Socket (HostName)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
 import qualified Simplex.FileTransfer.Client as X
 import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb)
-import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, XFTPErrorType (DIGEST))
-import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
+import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse)
+import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..), XFTPErrorType (DIGEST), XFTPVersion)
 import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..))
 import Simplex.FileTransfer.Util (uniqueCombine)
 import Simplex.Messaging.Agent.Env.SQLite
@@ -178,9 +181,11 @@ import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.Base64 (encode)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Client
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Transport (NTFVersion)
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse)
 import Simplex.Messaging.Protocol
@@ -191,6 +196,7 @@ import Simplex.Messaging.Protocol
     MsgFlags (..),
     MsgId,
     NtfServer,
+    NtfServerWithAuth,
     ProtoServer,
     ProtoServerWithAuth (..),
     Protocol (..),
@@ -200,26 +206,30 @@ import Simplex.Messaging.Protocol
     QueueIdsKeys (..),
     RcvMessage (..),
     RcvNtfPublicDhKey,
+    NtfPublicAuthKey,
     SMPMsgMeta (..),
     SProtocolType (..),
-    SndPublicVerifyKey,
+    SndPublicAuthKey,
     SubscriptionMode (..),
     UserProtocol,
     XFTPServer,
     XFTPServerWithAuth,
+    VersionSMPC,
+    VersionRangeSMPC,
     sameSrvAddr',
   )
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Transport (SMPVersion)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
+import System.Mem.Weak (Weak)
 import System.Random (randomR)
 import UnliftIO (mapConcurrently, timeout)
 import UnliftIO.Async (async)
-import UnliftIO.Directory (getTemporaryDirectory)
-import UnliftIO.Exception (bracket)
+import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, removeFile)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
@@ -243,10 +253,11 @@ type NtfTransportSession = TransportSession NtfResponse
 type XFTPTransportSession = TransportSession FileResponse
 
 data AgentClient = AgentClient
-  { active :: TVar Bool,
+  { acThread :: TVar (Maybe (Weak ThreadId)),
+    active :: TVar Bool,
     rcvQ :: TBQueue (ATransmission 'Client),
     subQ :: TBQueue (ATransmission 'Agent),
-    msgQ :: TBQueue (ServerTransmission BrokerMsg),
+    msgQ :: TBQueue (ServerTransmission SMPVersion BrokerMsg),
     smpServers :: TMap UserId (NonEmpty SMPServerWithAuth),
     smpClients :: TMap SMPTransportSession SMPClientVar,
     ntfServers :: TVar [NtfServer],
@@ -341,7 +352,7 @@ newWorker c = do
 
 runWorkerAsync :: AgentMonad' m => Worker -> m () -> m ()
 runWorkerAsync Worker {action} work =
-  bracket
+  E.bracket
     (atomically $ takeTMVar action) -- get current action, locking to avoid race conditions
     (atomically . tryPutTMVar action) -- if it was running (or if start crashes), put it back and unlock (don't lock if it was just started)
     (\a -> when (isNothing a) start) -- start worker if it's not running
@@ -386,6 +397,7 @@ data AgentStatsKey = AgentStatsKey
 newAgentClient :: Int -> InitialAgentServers -> Env -> STM AgentClient
 newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do
   let qSize = tbqSize $ config agentEnv
+  acThread <- newTVar Nothing
   active <- newTVar True
   rcvQ <- newTBQueue qSize
   subQ <- newTBQueue qSize
@@ -419,7 +431,8 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
   agentStats <- TM.empty
   return
     AgentClient
-      { active,
+      { acThread,
+        active,
         rcvQ,
         subQ,
         msgQ,
@@ -460,7 +473,7 @@ agentClientStore AgentClient {agentEnv = Env {store}} = store
 agentDRG :: AgentClient -> TVar ChaChaDRG
 agentDRG AgentClient {agentEnv = Env {random}} = random
 
-class (Encoding err, Show err) => ProtocolServerClient err msg | msg -> err where
+class (Encoding err, Show err) => ProtocolServerClient v err msg | msg -> v, msg -> err where
   type Client msg = c | c -> msg
   getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (Client msg)
   clientProtocolError :: err -> AgentErrorType
@@ -469,8 +482,8 @@ class (Encoding err, Show err) => ProtocolServerClient err msg | msg -> err wher
   clientTransportHost :: Client msg -> TransportHost
   clientSessionTs :: Client msg -> UTCTime
 
-instance ProtocolServerClient ErrorType BrokerMsg where
-  type Client BrokerMsg = ProtocolClient ErrorType BrokerMsg
+instance ProtocolServerClient SMPVersion ErrorType BrokerMsg where
+  type Client BrokerMsg = ProtocolClient SMPVersion ErrorType BrokerMsg
   getProtocolServerClient = getSMPServerClient
   clientProtocolError = SMP
   closeProtocolServerClient = closeProtocolClient
@@ -478,8 +491,8 @@ instance ProtocolServerClient ErrorType BrokerMsg where
   clientTransportHost = transportHost'
   clientSessionTs = sessionTs
 
-instance ProtocolServerClient ErrorType NtfResponse where
-  type Client NtfResponse = ProtocolClient ErrorType NtfResponse
+instance ProtocolServerClient NTFVersion ErrorType NtfResponse where
+  type Client NtfResponse = ProtocolClient NTFVersion ErrorType NtfResponse
   getProtocolServerClient = getNtfServerClient
   clientProtocolError = NTF
   closeProtocolServerClient = closeProtocolClient
@@ -487,7 +500,7 @@ instance ProtocolServerClient ErrorType NtfResponse where
   clientTransportHost = transportHost'
   clientSessionTs = sessionTs
 
-instance ProtocolServerClient XFTPErrorType FileResponse where
+instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where
   type Client FileResponse = XFTPClient
   getProtocolServerClient = getXFTPServerClient
   clientProtocolError = XFTP
@@ -499,30 +512,38 @@ instance ProtocolServerClient XFTPErrorType FileResponse where
 getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m SMPClient
 getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, _) = do
   unlessM (readTVarIO active) . throwError $ INACTIVE
-  v <- atomically (getTSessVar c tSess smpClients)
-  either newClient (waitForProtocolClient c tSess) v
-    `catchAgentError` \e -> resubscribeSMPSession c tSess >> throwError e
+  atomically (getTSessVar c tSess smpClients)
+    >>= either newClient (waitForProtocolClient c tSess)
   where
-    newClient = newProtocolClient c tSess smpClients connectClient
+    -- we resubscribe only on newClient error, but not on waitForProtocolClient error,
+    -- as the large number of delivery workers waiting for the client TMVar
+    -- make it expensive to check for pending subscriptions.
+    newClient v =
+      newProtocolClient c tSess smpClients connectClient v
+        `catchAgentError` \e -> resubscribeSMPSession c tSess >> throwError e
     connectClient :: SMPClientVar -> m SMPClient
     connectClient v = do
       cfg <- getClientConfig c smpCfg
-      u <- askUnliftIO
-      liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg (Just msgQ) $ clientDisconnected u v)
+      g <- asks random
+      env <- ask
+      liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient g tSess cfg (Just msgQ) $ clientDisconnected env v)
 
-    clientDisconnected :: UnliftIO m -> SMPClientVar -> SMPClient -> IO ()
-    clientDisconnected u v client = do
+    clientDisconnected :: Env -> SMPClientVar -> SMPClient -> IO ()
+    clientDisconnected env v client = do
       removeClientAndSubs >>= serverDown
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
       where
+        -- we make active subscriptions pending only if the client for tSess was current (in the map) and active,
+        -- because we can have a race condition when a new current client could have already
+        -- made subscriptions active, and the old client would be processing diconnection later.
         removeClientAndSubs :: IO ([RcvQueue], [ConnId])
-        removeClientAndSubs = atomically $ do
-          removeTSessVar v tSess smpClients
-          qs <- RQ.getDelSessQueues tSess $ activeSubs c
-          mapM_ (`RQ.addQueue` pendingSubs c) qs
-          let cs = S.fromList $ map qConnId qs
-          cs' <- RQ.getConns $ activeSubs c
-          pure (qs, S.toList $ cs `S.difference` cs')
+        removeClientAndSubs = atomically $ ifM currentActiveClient removeSubs $ pure ([], [])
+          where
+            currentActiveClient = (&&) <$> removeTSessVar' v tSess smpClients <*> readTVar active
+            removeSubs = do
+              (qs, cs) <- RQ.getDelSessQueues tSess $ activeSubs c
+              RQ.batchAddQueues (pendingSubs c) qs
+              pure (qs, cs)
 
         serverDown :: ([RcvQueue], [ConnId]) -> IO ()
         serverDown (qs, conns) = whenM (readTVarIO active) $ do
@@ -531,7 +552,7 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv,
           unless (null conns) $ notifySub "" $ DOWN srv conns
           unless (null qs) $ do
             atomically $ mapM_ (releaseGetLock c) qs
-            unliftIO u $ resubscribeSMPSession c tSess
+            runReaderT (resubscribeSMPSession c tSess) env
 
         notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
         notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
@@ -580,16 +601,16 @@ reconnectSMPClient tc c tSess@(_, srv, _) qs = do
   where
     resubscribe :: m ()
     resubscribe = do
-      cs <- atomically . RQ.getConns $ activeSubs c
+      cs <- readTVarIO $ RQ.getConnections $ activeSubs c
       rs <- subscribeQueues c $ L.toList qs
       let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs
       liftIO $ do
-        let conns = S.toList $ S.fromList okConns `S.difference` cs
+        let conns = filter (`M.notMember` cs) okConns
         unless (null conns) $ notifySub "" $ UP srv conns
       let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs
       liftIO $ mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs
       forM_ (listToMaybe tempErrs) $ \(_, err) -> do
-        when (null okConns && S.null cs && null finalErrs) . liftIO $
+        when (null okConns && M.null cs && null finalErrs) . liftIO $
           closeClient c smpClients tSess
         throwError err
     notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
@@ -606,7 +627,8 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d
     connectClient :: NtfClientVar -> m NtfClient
     connectClient v = do
       cfg <- getClientConfig c ntfCfg
-      liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg Nothing $ clientDisconnected v)
+      g <- asks random
+      liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient g tSess cfg Nothing $ clientDisconnected v)
 
     clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
     clientDisconnected v client = do
@@ -648,9 +670,13 @@ getTSessVar c tSess vs = maybe (Left <$> newSessionVar) (pure . Right) =<< TM.lo
       pure v
 
 removeTSessVar :: SessionVar a -> TransportSession msg -> TMap (TransportSession msg) (SessionVar a) -> STM ()
-removeTSessVar v tSess vs =
-  TM.lookup tSess vs
-    >>= mapM_ (\v' -> when (sessionVarId v == sessionVarId v') $ TM.delete tSess vs)
+removeTSessVar = void .:. removeTSessVar'
+
+removeTSessVar' :: SessionVar a -> TransportSession msg -> TMap (TransportSession msg) (SessionVar a) -> STM Bool
+removeTSessVar' v tSess vs =
+  TM.lookup tSess vs >>= \case
+    Just v' | sessionVarId v == sessionVarId v' -> TM.delete tSess vs $> True
+    _ -> pure False
 
 waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ClientVar msg -> m (Client msg)
 waitForProtocolClient c (_, srv, _) v = do
@@ -663,8 +689,8 @@ waitForProtocolClient c (_, srv, _) v = do
 
 -- clientConnected arg is only passed for SMP server
 newProtocolClient ::
-  forall err msg m.
-  (AgentMonad m, ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) =>
+  forall v err msg m.
+  (AgentMonad m, ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
   AgentClient ->
   TransportSession msg ->
   TMap (TransportSession msg) (ClientVar msg) ->
@@ -686,10 +712,10 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v =
         putTMVar (sessionVar v) (Left e)
       throwError e -- signal error to caller
 
-hostEvent :: forall err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> Client msg -> ACommand 'Agent 'AENone
+hostEvent :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> Client msg -> ACommand 'Agent 'AENone
 hostEvent event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost
 
-getClientConfig :: AgentMonad' m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig
+getClientConfig :: AgentMonad' m => AgentClient -> (AgentConfig -> ProtocolClientConfig v) -> m (ProtocolClientConfig v)
 getClientConfig AgentClient {useNetworkConfig} cfgSel = do
   cfg <- asks $ cfgSel . config
   networkConfig <- readTVarIO useNetworkConfig
@@ -734,15 +760,19 @@ throwWhenNoDelivery c sq =
   unlessM (TM.member (qAddress sq) $ smpDeliveryWorkers c) $
     throwSTM ThreadKilled
 
-closeProtocolServerClients :: ProtocolServerClient err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
+closeProtocolServerClients :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
 closeProtocolServerClients c clientsSel =
   atomically (clientsSel c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient_ c)
 
-closeClient :: ProtocolServerClient err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO ()
+reconnectServerClients :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
+reconnectServerClients c clientsSel =
+  readTVarIO (clientsSel c) >>= mapM_ (forkIO . closeClient_ c)
+
+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)
 
-closeClient_ :: ProtocolServerClient err msg => AgentClient -> ClientVar msg -> IO ()
+closeClient_ :: ProtocolServerClient v err msg => AgentClient -> ClientVar msg -> IO ()
 closeClient_ c v = do
   NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
   tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case
@@ -774,7 +804,7 @@ getMapLock locks key = TM.lookup key locks >>= maybe newLock pure
   where
     newLock = createLock >>= \l -> TM.insert key l locks $> l
 
-withClient_ :: forall a m err msg. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> m a) -> m a
+withClient_ :: forall a m v err msg. (AgentMonad m, ProtocolServerClient v err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> m a) -> m a
 withClient_ c tSess@(userId, srv, _) statCmd action = do
   cl <- getProtocolServerClient c tSess
   (action cl <* stat cl "OK") `catchAgentError` logServerError cl
@@ -786,18 +816,18 @@ withClient_ c tSess@(userId, srv, _) statCmd action = do
       stat cl $ strEncode e
       throwError e
 
-withLogClient_ :: (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> m a) -> m a
+withLogClient_ :: (AgentMonad m, ProtocolServerClient v err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> m a) -> m a
 withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do
   logServer "-->" c srv entId cmdStr
   res <- withClient_ c tSess cmdStr action
   logServer "<--" c srv entId "OK"
   return res
 
-withClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> m a
-withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @err @msg) (clientServer client) $ action client
+withClient :: forall m v err msg a. (AgentMonad m, ProtocolServerClient v err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> m a
+withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer client) $ action client
 
-withLogClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> m a
-withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @err @msg) (clientServer client) $ action client
+withLogClient :: forall m v err msg a. (AgentMonad m, ProtocolServerClient v err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> m a
+withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer client) $ action client
 
 withSMPClient :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
 withSMPClient c q cmdStr action = do
@@ -813,7 +843,7 @@ withNtfClient :: forall m a. AgentMonad m => AgentClient -> NtfServer -> EntityI
 withNtfClient c srv = withLogClient c (0, srv, Nothing)
 
 withXFTPClient ::
-  (AgentMonad m, ProtocolServerClient err msg) =>
+  (AgentMonad m, ProtocolServerClient v err msg) =>
   AgentClient ->
   (UserId, ProtoServer msg, EntityId) ->
   ByteString ->
@@ -849,6 +879,8 @@ data ProtocolTestStep
   | TSDownloadFile
   | TSCompareFile
   | TSDeleteFile
+  | TSCreateNtfToken
+  | TSDeleteNtfToken
   deriving (Eq, Show)
 
 data ProtocolTestFailure = ProtocolTestFailure
@@ -860,17 +892,18 @@ data ProtocolTestFailure = ProtocolTestFailure
 runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe ProtocolTestFailure)
 runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
   cfg <- getClientConfig c smpCfg
-  C.SignAlg a <- asks $ cmdSignAlg . config
+  C.AuthAlg ra <- asks $ rcvAuthAlg . config
+  C.AuthAlg sa <- asks $ sndAuthAlg . config
   g <- asks random
   liftIO $ do
     let tSess = (userId, srv, Nothing)
-    getProtocolClient tSess cfg Nothing (\_ -> pure ()) >>= \case
+    getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case
       Right smp -> do
-        (rKey, rpKey) <- atomically $ C.generateSignatureKeyPair a g
-        (sKey, _) <- atomically $ C.generateSignatureKeyPair a g
+        rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g
+        (sKey, _) <- atomically $ C.generateAuthKeyPair sa g
         (dhKey, _) <- atomically $ C.generateKeyPair g
         r <- runExceptT $ do
-          SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rpKey rKey dhKey auth SMSubscribe
+          SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe
           liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey
           liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId
         ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp
@@ -893,10 +926,9 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
   liftIO $ do
     let tSess = (userId, srv, Nothing)
     X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
-      Right xftp -> do
-        (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-        (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-        createTestChunk filePath
+      Right xftp -> withTestChunk filePath $ do
+        (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+        (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
         digest <- liftIO $ C.sha256Hash <$> B.readFile filePath
         let file = FileInfo {sndKey, size = chSize, digest}
             chunkSpec = X.XFTPChunkSpec {filePath, chunkOffset = 0, chunkSize = chSize}
@@ -916,16 +948,45 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
     testErr :: ProtocolTestStep -> XFTPClientError -> ProtocolTestFailure
     testErr step = ProtocolTestFailure step . protocolClientError XFTP addr
     chSize :: Integral a => a
-    chSize = kb 256
+    chSize = kb 64
     getTempFilePath :: FilePath -> m FilePath
     getTempFilePath workPath = do
       ts <- liftIO getCurrentTime
       let isoTime = formatTime defaultTimeLocale "%Y-%m-%dT%H%M%S.%6q" ts
       uniqueCombine workPath isoTime
+    withTestChunk :: FilePath -> IO a -> IO a
+    withTestChunk fp =
+      E.bracket_
+        (createTestChunk fp)
+        (whenM (doesFileExist fp) $ removeFile fp `catchAll_` pure ())
     -- this creates a new DRG on purpose to avoid blocking the one used in the agent
     createTestChunk :: FilePath -> IO ()
     createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom
 
+runNTFServerTest :: AgentMonad m => AgentClient -> UserId -> NtfServerWithAuth -> m (Maybe ProtocolTestFailure)
+runNTFServerTest c userId (ProtoServerWithAuth srv _) = do
+  cfg <- getClientConfig c ntfCfg
+  C.AuthAlg a <- asks $ rcvAuthAlg . config
+  g <- asks random
+  liftIO $ do
+    let tSess = (userId, srv, Nothing)
+    getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case
+      Right ntf -> do
+        (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
+        (dhKey, _) <- atomically $ C.generateKeyPair g
+        r <- runExceptT $ do
+          let deviceToken = DeviceToken PPApnsNull "test_ntf_token"
+          (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
+    addr = B.unpack $ strEncode srv
+    testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
+    testErr step = ProtocolTestFailure step . protocolClientError NTF addr
+
 getXFTPWorkPath :: AgentMonad m => m FilePath
 getXFTPWorkPath = do
   workDir <- readTVarIO =<< asks (xftpWorkDir . xftpAgent)
@@ -946,17 +1007,17 @@ mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q)
 getSessionMode :: AgentMonad' m => AgentClient -> m TransportSessionMode
 getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig
 
-newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> SubscriptionMode -> m (NewRcvQueue, SMPQueueUri)
+newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> m (NewRcvQueue, SMPQueueUri)
 newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do
-  C.SignAlg a <- asks (cmdSignAlg . config)
+  C.AuthAlg a <- asks (rcvAuthAlg . config)
   g <- asks random
-  (recipientKey, rcvPrivateKey) <- atomically $ C.generateSignatureKeyPair a g
+  rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g
   (dhKey, privDhKey) <- atomically $ C.generateKeyPair g
   (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g
   logServer "-->" c srv "" "NEW"
   tSess <- mkTransportSession c userId srv connId
   QIK {rcvId, sndId, rcvPublicDhKey} <-
-    withClient c tSess "NEW" $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth subMode
+    withClient c tSess "NEW" $ \smp -> createSMPQueue smp rKeys dhKey auth subMode
   logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
   let rq =
         RcvQueue
@@ -1006,22 +1067,22 @@ temporaryOrHostError = \case
 subscribeQueues :: forall m. AgentMonad' m => AgentClient -> [RcvQueue] -> m [(RcvQueue, Either AgentErrorType ())]
 subscribeQueues c qs = do
   (errs, qs') <- partitionEithers <$> mapM checkQueue qs
-  forM_ qs' $ \rq@RcvQueue {connId} -> atomically $ do
-    modifyTVar (subscrConns c) $ S.insert connId
-    RQ.addQueue rq $ pendingSubs c
-  u <- askUnliftIO
+  atomically $ do
+    modifyTVar' (subscrConns c) (`S.union` S.fromList (map qConnId qs'))
+    RQ.batchAddQueues (pendingSubs c) qs'
+  env <- ask
   -- only "checked" queues are subscribed
-  (errs <>) <$> sendTSessionBatches "SUB" 90 id (subscribeQueues_ u) c qs'
+  (errs <>) <$> sendTSessionBatches "SUB" 90 id (subscribeQueues_ env) c qs'
   where
     checkQueue rq = do
       prohibited <- atomically $ hasGetLock c rq
       pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED) else Right rq
-    subscribeQueues_ :: UnliftIO m -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
-    subscribeQueues_ u smp qs' = do
+    subscribeQueues_ :: Env -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
+    subscribeQueues_ env smp qs' = do
       rs <- sendBatch subscribeSMPQueues smp qs'
       mapM_ (uncurry $ processSubResult c) rs
-      when (any temporaryClientError . lefts . map snd $ L.toList rs) . unliftIO u $
-        resubscribeSMPSession c (transportSession' smp)
+      when (any temporaryClientError . lefts . map snd $ L.toList rs) $
+        runReaderT (resubscribeSMPSession c $ transportSession' smp) env
       pure rs
 
 type BatchResponses e r = (NonEmpty (RcvQueue, Either e r))
@@ -1054,7 +1115,7 @@ sendTSessionBatches statCmd statBatchSize toRQ action c qs =
               let n = (length qs - 1) `div` statBatchSize + 1
                in incClientStatN c userId smp n statCmd "OK"
 
-sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
+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)
   where
     queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
@@ -1096,7 +1157,7 @@ sendConfirmation c sq@SndQueue {sndId, sndPublicKey = Just sndPublicKey, e2ePubK
     liftClient SMP (clientServer smp) $ sendSMPMessage smp Nothing sndId (SMP.MsgFlags {notification = True}) msg
 sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
 
-sendInvitation :: forall m. AgentMonad m => AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible Version -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
+sendInvitation :: forall m. AgentMonad m => AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
 sendInvitation c userId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
   tSess <- mkTransportSession c userId smpServer senderId
   withLogClient_ c tSess senderId "SEND <INV>" $ \smp -> do
@@ -1113,11 +1174,11 @@ sendInvitation c userId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer,
 getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMeta)
 getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
   atomically createTakeGetLock
-  (v, msg_) <- withSMPClient c rq "GET" $ \smp ->
-    (thVersion smp,) <$> getSMPMessage smp rcvPrivateKey rcvId
-  mapM (decryptMeta v) msg_
+  msg_ <- withSMPClient c rq "GET" $ \smp ->
+    getSMPMessage smp rcvPrivateKey rcvId
+  mapM decryptMeta msg_
   where
-    decryptMeta v msg@SMP.RcvMessage {msgId} = SMP.rcvMessageMeta msgId <$> decryptSMPMessage v rq msg
+    decryptMeta msg@SMP.RcvMessage {msgId} = SMP.rcvMessageMeta msgId <$> decryptSMPMessage rq msg
     createTakeGetLock = TM.alterF takeLock (server, rcvId) $ getMsgLocks c
       where
         takeLock l_ = do
@@ -1125,30 +1186,29 @@ getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
           takeTMVar l
           pure $ Just l
 
-decryptSMPMessage :: AgentMonad m => Version -> RcvQueue -> SMP.RcvMessage -> m SMP.ClientRcvMsgBody
-decryptSMPMessage v rq SMP.RcvMessage {msgId, msgTs, msgFlags, msgBody = SMP.EncRcvMsgBody body}
-  | v == 1 || v == 2 = SMP.ClientRcvMsgBody msgTs msgFlags <$> decrypt body
-  | otherwise = liftEither . parse SMP.clientRcvMsgBodyP (AGENT A_MESSAGE) =<< decrypt body
+decryptSMPMessage :: AgentMonad m => RcvQueue -> SMP.RcvMessage -> m SMP.ClientRcvMsgBody
+decryptSMPMessage rq SMP.RcvMessage {msgId, msgBody = SMP.EncRcvMsgBody body} =
+  liftEither . parse SMP.clientRcvMsgBodyP (AGENT A_MESSAGE) =<< decrypt body
   where
     decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId)
 
-secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
+secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicAuthKey -> m ()
 secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
   withSMPClient c rq "KEY <key>" $ \smp ->
     secureSMPQueue smp rcvPrivateKey rcvId senderKey
 
-enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> SMP.NtfPublicVerifyKey -> SMP.RcvNtfPublicDhKey -> m (SMP.NotifierId, SMP.RcvNtfPublicDhKey)
+enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> m (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 :: forall m. AgentMonad' m => AgentClient -> [(RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey)] -> m [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
+enableQueuesNtfs :: forall m. AgentMonad' m => AgentClient -> [(RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)] -> m [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
 enableQueuesNtfs = sendTSessionBatches "NKEY" 90 fst3 enableQueues_
   where
     fst3 (x, _, _) = x
-    enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
+    enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
     enableQueues_ smp qs' = L.zipWith ((,) . fst3) qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
-    queueCreds :: (RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateSignKey, SMP.RecipientId, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey)
+    queueCreds :: (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateAuthKey, SMP.RecipientId, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)
     queueCreds (RcvQueue {rcvPrivateKey, rcvId}, notifierKey, rcvNtfPublicDhKey) = (rcvPrivateKey, rcvId, notifierKey, rcvNtfPublicDhKey)
 
 disableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> m ()
@@ -1193,7 +1253,7 @@ sendAgentMessage c sq@SndQueue {sndId, sndPrivateKey} msgFlags agentMsg =
     msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
     liftClient SMP (clientServer smp) $ sendSMPMessage smp (Just sndPrivateKey) sndId msgFlags msg
 
-agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519)
+agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> m (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)
 
@@ -1217,7 +1277,7 @@ agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> W
 agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval =
   withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval
 
-agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateSignKey -> m NtfSubscriptionId
+agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateAuthKey -> m NtfSubscriptionId
 agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =
   withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
 
@@ -1237,7 +1297,7 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se
 agentXFTPNewChunk :: AgentMonad m => AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> m NewSndChunkReplica
 agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do
   rKeys <- xftpRcvKeys n
-  (sndKey, replicaKey) <- atomically . C.generateSignatureKeyPair C.SEd25519 =<< asks random
+  (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random
   let fileInfo = FileInfo {sndKey, size = fromIntegral chunkSize, digest = chunkDigest}
   logServer "-->" c srv "" "FNEW"
   tSess <- mkTransportSession c userId srv chunkDigest
@@ -1249,7 +1309,7 @@ agentXFTPUploadChunk :: AgentMonad m => AgentClient -> UserId -> FileDigest -> S
 agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec =
   withXFTPClient c (userId, server, chunkDigest) "FPUT" $ \xftp -> X.uploadXFTPChunk xftp replicaKey fId chunkSpec
 
-agentXFTPAddRecipients :: AgentMonad m => AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> Int -> m (NonEmpty (ChunkReplicaId, C.APrivateSignKey))
+agentXFTPAddRecipients :: AgentMonad m => AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> Int -> m (NonEmpty (ChunkReplicaId, C.APrivateAuthKey))
 agentXFTPAddRecipients c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} n = do
   rKeys <- xftpRcvKeys n
   rIds <- withXFTPClient c (userId, server, chunkDigest) "FADD" $ \xftp -> X.addXFTPRecipients xftp replicaKey fId (L.map fst rKeys)
@@ -1259,14 +1319,14 @@ agentXFTPDeleteChunk :: AgentMonad m => AgentClient -> UserId -> DeletedSndChunk
 agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey, chunkDigest = FileDigest chunkDigest} =
   withXFTPClient c (userId, server, chunkDigest) "FDEL" $ \xftp -> X.deleteXFTPChunk xftp replicaKey fId
 
-xftpRcvKeys :: AgentMonad m => Int -> m (NonEmpty C.ASignatureKeyPair)
+xftpRcvKeys :: AgentMonad m => Int -> m (NonEmpty C.AAuthKeyPair)
 xftpRcvKeys n = do
-  rKeys <- atomically . replicateM n . C.generateSignatureKeyPair C.SEd25519 =<< asks random
+  rKeys <- atomically . replicateM n . C.generateAuthKeyPair C.SEd25519 =<< asks random
   case L.nonEmpty rKeys of
     Just rKeys' -> pure rKeys'
     _ -> throwError $ INTERNAL "non-positive number of recipients"
 
-xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.ASignatureKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateSignKey)
+xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey)
 xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
 
 agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString
@@ -1280,7 +1340,7 @@ agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do
   pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}
 
 -- add encoding as AgentInvitation'?
-agentCbEncryptOnce :: AgentMonad m => Version -> C.PublicKeyX25519 -> ByteString -> m ByteString
+agentCbEncryptOnce :: AgentMonad m => VersionSMPC -> C.PublicKeyX25519 -> ByteString -> m ByteString
 agentCbEncryptOnce clientVersion dhRcvPubKey msg = do
   g <- asks random
   (dhSndPubKey, dhSndPrivKey) <- atomically $ C.generateKeyPair g
@@ -1399,34 +1459,13 @@ waitUntilForeground :: AgentClient -> STM ()
 waitUntilForeground c = unlessM ((ASForeground ==) <$> readTVar (agentState c)) retry
 
 withStore' :: AgentMonad m => AgentClient -> (DB.Connection -> IO a) -> m a
-withStore' = withStoreCtx_' Nothing
+withStore' c action = withStore c $ fmap Right . action
 
 withStore :: AgentMonad m => AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> m a
-withStore = withStoreCtx_ Nothing
-
-withStoreCtx' :: AgentMonad m => String -> AgentClient -> (DB.Connection -> IO a) -> m a
-withStoreCtx' = withStoreCtx_' . Just
-
-withStoreCtx :: AgentMonad m => String -> AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> m a
-withStoreCtx = withStoreCtx_ . Just
-
-withStoreCtx_' :: AgentMonad m => Maybe String -> AgentClient -> (DB.Connection -> IO a) -> m a
-withStoreCtx_' ctx_ c action = withStoreCtx_ ctx_ c $ fmap Right . action
-
-withStoreCtx_ :: AgentMonad m => Maybe String -> AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> m a
-withStoreCtx_ ctx_ c action = do
+withStore c action = do
   st <- asks store
-  liftEitherError storeError . agentOperationBracket c AODatabase (\_ -> pure ()) $ case ctx_ of
-    Nothing -> withTransaction st action `E.catch` handleInternal ""
-    -- uncomment to debug store performance
-    -- Just ctx -> do
-    --   t1 <- liftIO getCurrentTime
-    --   putStrLn $ "agent withStoreCtx start       :: " <> show t1 <> " :: " <> ctx
-    --   r <- withTransaction st action `E.catch` handleInternal (" (" <> ctx <> ")")
-    --   t2 <- liftIO getCurrentTime
-    --   putStrLn $ "agent withStoreCtx end         :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
-    --   pure r
-    Just _ -> withTransaction st action `E.catch` handleInternal ""
+  liftEitherError storeError . agentOperationBracket c AODatabase (\_ -> pure ()) $
+    withTransaction st action `E.catch` handleInternal ""
   where
     handleInternal :: String -> E.SomeException -> IO (Either StoreError a)
     handleInternal ctxStr e = pure . Left . SEInternal . B.pack $ show e <> ctxStr
@@ -1464,7 +1503,7 @@ incStat AgentClient {agentStats} n k = do
     Just v -> modifyTVar' v (+ n)
     _ -> newTVar n >>= \v -> TM.insert k v agentStats
 
-incClientStat :: ProtocolServerClient err msg => AgentClient -> UserId -> Client msg -> ByteString -> ByteString -> IO ()
+incClientStat :: ProtocolServerClient v err msg => AgentClient -> UserId -> Client msg -> ByteString -> ByteString -> IO ()
 incClientStat c userId pc = incClientStatN c userId pc 1
 
 incServerStat :: AgentClient -> UserId -> ProtocolServer p -> ByteString -> ByteString -> IO ()
@@ -1474,7 +1513,7 @@ incServerStat c userId ProtocolServer {host} cmd res = do
   where
     statsKey = AgentStatsKey {userId, host = strEncode $ L.head host, clientTs = "", cmd, res}
 
-incClientStatN :: ProtocolServerClient err msg => AgentClient -> UserId -> Client msg -> Int -> ByteString -> ByteString -> IO ()
+incClientStatN :: ProtocolServerClient v err msg => AgentClient -> UserId -> Client msg -> Int -> ByteString -> ByteString -> IO ()
 incClientStatN c userId pc n cmd res = do
   atomically $ incStat c n statsKey
   where
@@ -1607,14 +1646,21 @@ data AgentWorkersSummary = AgentWorkersSummary
   { smpClientsCount :: Int,
     ntfClientsCount :: Int,
     xftpClientsCount :: Int,
-    smpDeliveryWorkersCount :: Int,
-    asyncCmdWorkersCount :: Int,
+    smpDeliveryWorkersCount :: WorkersSummary,
+    asyncCmdWorkersCount :: WorkersSummary,
     smpSubWorkersCount :: Int,
-    ntfWorkersCount :: Int,
-    ntfSMPWorkersCount :: Int,
-    xftpRcvWorkersCount :: Int,
-    xftpSndWorkersCount :: Int,
-    xftpDelWorkersCount :: Int
+    ntfWorkersCount :: WorkersSummary,
+    ntfSMPWorkersCount :: WorkersSummary,
+    xftpRcvWorkersCount :: WorkersSummary,
+    xftpSndWorkersCount :: WorkersSummary,
+    xftpDelWorkersCount :: WorkersSummary
+  }
+  deriving (Show)
+
+data WorkersSummary = WorkersSummary
+  { numActive :: Int,
+    numIdle :: Int,
+    totalRestarts :: Int
   }
   deriving (Show)
 
@@ -1623,14 +1669,14 @@ getAgentWorkersSummary AgentClient {smpClients, ntfClients, xftpClients, smpDeli
   smpClientsCount <- M.size <$> readTVarIO smpClients
   ntfClientsCount <- M.size <$> readTVarIO ntfClients
   xftpClientsCount <- M.size <$> readTVarIO xftpClients
-  smpDeliveryWorkersCount <- M.size <$> readTVarIO smpDeliveryWorkers
-  asyncCmdWorkersCount <- M.size <$> readTVarIO asyncCmdWorkers
+  smpDeliveryWorkersCount <- readTVarIO smpDeliveryWorkers >>= workerSummary . fmap fst
+  asyncCmdWorkersCount <- readTVarIO asyncCmdWorkers >>= workerSummary
   smpSubWorkersCount <- M.size <$> readTVarIO smpSubWorkers
-  ntfWorkersCount <- M.size <$> readTVarIO ntfWorkers
-  ntfSMPWorkersCount <- M.size <$> readTVarIO ntfSMPWorkers
-  xftpRcvWorkersCount <- M.size <$> readTVarIO xftpRcvWorkers
-  xftpSndWorkersCount <- M.size <$> readTVarIO xftpSndWorkers
-  xftpDelWorkersCount <- M.size <$> readTVarIO xftpDelWorkers
+  ntfWorkersCount <- readTVarIO ntfWorkers >>= workerSummary
+  ntfSMPWorkersCount <- readTVarIO ntfSMPWorkers >>= workerSummary
+  xftpRcvWorkersCount <- readTVarIO xftpRcvWorkers >>= workerSummary
+  xftpSndWorkersCount <- readTVarIO xftpSndWorkers >>= workerSummary
+  xftpDelWorkersCount <- readTVarIO xftpDelWorkers >>= workerSummary
   pure
     AgentWorkersSummary
       { smpClientsCount,
@@ -1649,6 +1695,15 @@ getAgentWorkersSummary AgentClient {smpClients, ntfClients, xftpClients, smpDeli
     Env {ntfSupervisor, xftpAgent} = agentEnv
     NtfSupervisor {ntfWorkers, ntfSMPWorkers} = ntfSupervisor
     XFTPAgent {xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers} = xftpAgent
+    workerSummary :: MonadIO m => M.Map k Worker -> m WorkersSummary
+    workerSummary = liftIO . foldM byWork WorkersSummary {numActive = 0, numIdle = 0, totalRestarts = 0}
+      where
+        byWork WorkersSummary {numActive, numIdle, totalRestarts} Worker {action, restarts} = do
+          RestartCount {restartCount} <- readTVarIO restarts
+          ifM
+            (atomically $ isJust <$> tryReadTMVar action)
+            (pure WorkersSummary {numActive, numIdle = numIdle + 1, totalRestarts = totalRestarts + restartCount})
+            (pure WorkersSummary {numActive = numActive + 1, numIdle, totalRestarts = totalRestarts + restartCount})
 
 $(J.deriveJSON defaultJSON ''AgentLocks)
 
@@ -1661,6 +1716,9 @@ $(J.deriveJSON defaultJSON ''SubInfo)
 $(J.deriveJSON defaultJSON ''SubscriptionsInfo)
 
 $(J.deriveJSON defaultJSON ''WorkersDetails)
+
+$(J.deriveJSON defaultJSON ''WorkersSummary)
+
 $(J.deriveJSON defaultJSON {J.fieldLabelModifier = takeWhile (/= '_')} ''AgentWorkersDetails)
 
 $(J.deriveJSON defaultJSON ''AgentWorkersSummary)

src/Simplex/Messaging/Agent/Env/SQLite.hs

@@ -56,15 +56,16 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange)
+import Simplex.Messaging.Crypto.Ratchet (PQSupport, VersionRangeE2E, supportedE2EEncryptVRange)
+import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
+import Simplex.Messaging.Notifications.Transport (NTFVersion)
 import Simplex.Messaging.Notifications.Types
-import Simplex.Messaging.Protocol (NtfServer, XFTPServer, XFTPServerWithAuth, supportedSMPClientVRange)
+import Simplex.Messaging.Protocol (NtfServer, VersionRangeSMPC, XFTPServer, XFTPServerWithAuth, supportedSMPClientVRange)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (TLS, Transport (..))
+import Simplex.Messaging.Transport (SMPVersion, TLS, Transport (..))
 import Simplex.Messaging.Transport.Client (defaultSMPPort)
 import Simplex.Messaging.Util (allFinally, catchAllErrors, tryAllErrors)
-import Simplex.Messaging.Version
 import System.Random (StdGen, newStdGen)
 import UnliftIO (Async, SomeException)
 import UnliftIO.STM
@@ -82,15 +83,17 @@ data InitialAgentServers = InitialAgentServers
 
 data AgentConfig = AgentConfig
   { tcpPort :: ServiceName,
-    cmdSignAlg :: C.SignAlg,
+    rcvAuthAlg :: C.AuthAlg,
+    sndAuthAlg :: C.AuthAlg,
     connIdBytes :: Int,
     tbqSize :: Natural,
-    smpCfg :: ProtocolClientConfig,
-    ntfCfg :: ProtocolClientConfig,
+    smpCfg :: ProtocolClientConfig SMPVersion,
+    ntfCfg :: ProtocolClientConfig NTFVersion,
     xftpCfg :: XFTPClientConfig,
     reconnectInterval :: RetryInterval,
     messageRetryInterval :: RetryInterval2,
     messageTimeout :: NominalDiffTime,
+    connDeleteDeliveryTimeout :: NominalDiffTime,
     helloTimeout :: NominalDiffTime,
     quotaExceededTimeout :: NominalDiffTime,
     initialCleanupDelay :: Int64,
@@ -113,9 +116,9 @@ data AgentConfig = AgentConfig
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
-    e2eEncryptVRange :: VersionRange,
-    smpAgentVRange :: VersionRange,
-    smpClientVRange :: VersionRange
+    e2eEncryptVRange :: PQSupport -> VersionRangeE2E,
+    smpAgentVRange :: PQSupport -> VersionRangeSMPA,
+    smpClientVRange :: VersionRangeSMPC
   }
 
 defaultReconnectInterval :: RetryInterval
@@ -147,15 +150,19 @@ defaultAgentConfig :: AgentConfig
 defaultAgentConfig =
   AgentConfig
     { tcpPort = "5224",
-      cmdSignAlg = C.SignAlg C.SEd448,
+      -- while the current client version supports X25519, it can only be enabled once support for SMP v6 is dropped,
+      -- and all servers are required to support v7 to be compatible.
+      rcvAuthAlg = C.AuthAlg C.SEd25519, -- this will stay as Ed25519
+      sndAuthAlg = C.AuthAlg C.SEd25519, -- TODO replace with X25519 when switching to v7
       connIdBytes = 12,
       tbqSize = 64,
-      smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
-      ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
+      smpCfg = defaultSMPClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
+      ntfCfg = defaultNTFClientConfig {defaultTransport = ("443", transport @TLS)},
       xftpCfg = defaultXFTPClientConfig,
       reconnectInterval = defaultReconnectInterval,
       messageRetryInterval = defaultMessageRetryInterval,
       messageTimeout = 2 * nominalDay,
+      connDeleteDeliveryTimeout = 2 * nominalDay,
       helloTimeout = 2 * nominalDay,
       quotaExceededTimeout = 7 * nominalDay,
       initialCleanupDelay = 30 * 1000000, -- 30 seconds

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -253,9 +253,9 @@ runNtfSMPWorker c srv Worker {doWork} = do
             getNtfToken >>= \case
               Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
                 rq <- withStore c (`getPrimaryRcvQueue` connId)
-                C.SignAlg a <- asks (cmdSignAlg . config)
+                C.AuthAlg a <- asks (rcvAuthAlg . config)
                 g <- asks random
-                (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateSignatureKeyPair a g
+                (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateAuthKeyPair a g
                 (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
                 (notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey
                 let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey

src/Simplex/Messaging/Agent/Protocol.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -33,6 +34,14 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
 module Simplex.Messaging.Agent.Protocol
   ( -- * Protocol parameters
+    VersionSMPA,
+    VersionRangeSMPA,
+    pattern VersionSMPA,
+    duplexHandshakeSMPAgentVersion,
+    ratchetSyncSMPAgentVersion,
+    deliveryRcptsSMPAgentVersion,
+    pqdrSMPAgentVersion,
+    currentSMPAgentVersion,
     supportedSMPAgentVRange,
     e2eEncConnInfoLength,
     e2eEncUserMsgLength,
@@ -97,7 +106,7 @@ module Simplex.Messaging.Agent.Protocol
     AConnectionRequestUri (..),
     ConnReqUriData (..),
     CRClientData,
-    ConnReqScheme (..),
+    ServiceScheme,
     simplexChat,
     AgentErrorType (..),
     CommandErrorType (..),
@@ -154,7 +163,6 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
@@ -164,7 +172,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Maybe (isJust)
+import Data.Maybe (fromMaybe, isJust)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@@ -173,15 +181,27 @@ import Data.Time.Clock.System (SystemTime)
 import Data.Time.ISO8601
 import Data.Type.Equality
 import Data.Typeable ()
-import Data.Word (Word32)
+import Data.Word (Word16, Word32)
 import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.ToField
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..), XFTPErrorType)
+import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Transport (XFTPErrorType)
 import Simplex.Messaging.Agent.QueryString
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Ratchet (E2ERatchetParams, E2ERatchetParamsUri)
+import Simplex.Messaging.Crypto.Ratchet
+  ( InitialKeys (..),
+    PQEncryption (..),
+    pattern PQEncOff,
+    PQSupport,
+    pattern PQSupportOn,
+    pattern PQSupportOff,
+    RcvE2ERatchetParams,
+    RcvE2ERatchetParamsUri,
+    SndE2ERatchetParams
+  )
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.Base64 (base64P, encode)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
@@ -196,40 +216,87 @@ import Simplex.Messaging.Protocol
     SMPMsgMeta,
     SMPServer,
     SMPServerWithAuth,
-    SndPublicVerifyKey,
-    SrvLoc (..),
+    SndPublicAuthKey,
     SubscriptionMode,
+    SMPClientVersion,
+    VersionSMPC,
+    VersionRangeSMPC,
+    initialSMPClientVersion,
     legacyEncodeServer,
     legacyServerP,
     legacyStrEncodeServer,
     noAuthSrv,
     sameSrvAddr,
+    srvHostnamesSMPClientVersion,
     pattern ProtoServerWithAuth,
     pattern SMPServer,
   )
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.ServiceScheme
 import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
 import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts_ (..))
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
+import Simplex.Messaging.Version.Internal
 import Simplex.RemoteControl.Types
 import Text.Read
 import UnliftIO.Exception (Exception)
 
-currentSMPAgentVersion :: Version
-currentSMPAgentVersion = 4
+-- SMP agent protocol version history:
+-- 1 - binary protocol encoding (1/1/2022)
+-- 2 - "duplex" (more efficient) connection handshake (6/9/2022)
+-- 3 - support ratchet renegotiation (6/30/2023)
+-- 4 - delivery receipts (7/13/2023)
+-- 5 - post-quantum double ratchet (3/14/2024)
 
-supportedSMPAgentVRange :: VersionRange
-supportedSMPAgentVRange = mkVersionRange 1 currentSMPAgentVersion
+data SMPAgentVersion
+
+instance VersionScope SMPAgentVersion
+
+type VersionSMPA = Version SMPAgentVersion
+
+type VersionRangeSMPA = VersionRange SMPAgentVersion
+
+pattern VersionSMPA :: Word16 -> VersionSMPA
+pattern VersionSMPA v = Version v
+
+duplexHandshakeSMPAgentVersion :: VersionSMPA
+duplexHandshakeSMPAgentVersion = VersionSMPA 2
+
+ratchetSyncSMPAgentVersion :: VersionSMPA
+ratchetSyncSMPAgentVersion = VersionSMPA 3
+
+deliveryRcptsSMPAgentVersion :: VersionSMPA
+deliveryRcptsSMPAgentVersion = VersionSMPA 4
+
+pqdrSMPAgentVersion :: VersionSMPA
+pqdrSMPAgentVersion = VersionSMPA 5
+
+-- TODO v5.7 increase to 5
+currentSMPAgentVersion :: VersionSMPA
+currentSMPAgentVersion = VersionSMPA 4
+
+-- TODO v5.7 remove dependency of version range on whether PQ support is needed
+supportedSMPAgentVRange :: PQSupport -> VersionRangeSMPA
+supportedSMPAgentVRange pq =
+  mkVersionRange duplexHandshakeSMPAgentVersion $ case pq of
+    PQSupportOn -> pqdrSMPAgentVersion
+    PQSupportOff -> currentSMPAgentVersion
 
 -- it is shorter to allow all handshake headers,
 -- including E2E (double-ratchet) parameters and
 -- signing key of the sender for the server
-e2eEncConnInfoLength :: Int
-e2eEncConnInfoLength = 14848
+e2eEncConnInfoLength :: VersionSMPA -> PQSupport -> Int
+e2eEncConnInfoLength v = \case
+  -- reduced by 3726 (roughly the increase of message ratchet header size + key and ciphertext in reply link)
+  PQSupportOn | v >= pqdrSMPAgentVersion -> 11122
+  _ -> 14848
 
-e2eEncUserMsgLength :: Int
-e2eEncUserMsgLength = 15856
+e2eEncUserMsgLength :: VersionSMPA -> PQSupport -> Int
+e2eEncUserMsgLength v = \case
+  -- reduced by 2222 (the increase of message ratchet header size)
+  PQSupportOn | v >= pqdrSMPAgentVersion -> 13634
+  _ -> 15856
 
 -- | Raw (unparsed) SMP agent protocol transmission.
 type ARawTransmission = (ByteString, ByteString, ByteString)
@@ -255,8 +322,6 @@ data SAParty :: AParty -> Type where
 
 deriving instance Show (SAParty p)
 
-deriving instance Eq (SAParty p)
-
 instance TestEquality SAParty where
   testEquality SAgent SAgent = Just Refl
   testEquality SClient SClient = Just Refl
@@ -279,8 +344,6 @@ data SAEntity :: AEntity -> Type where
 
 deriving instance Show (SAEntity e)
 
-deriving instance Eq (SAEntity e)
-
 instance TestEquality SAEntity where
   testEquality SAEConn SAEConn = Just Refl
   testEquality SAERcvFile SAERcvFile = Just Refl
@@ -315,16 +378,16 @@ type ConnInfo = ByteString
 
 -- | Parameterized type for SMP agent protocol commands and responses from all participants.
 data ACommand (p :: AParty) (e :: AEntity) where
-  NEW :: Bool -> AConnectionMode -> SubscriptionMode -> ACommand Client AEConn -- response INV
+  NEW :: Bool -> AConnectionMode -> InitialKeys -> SubscriptionMode -> ACommand Client AEConn -- response INV
   INV :: AConnectionRequestUri -> ACommand Agent AEConn
-  JOIN :: Bool -> AConnectionRequestUri -> SubscriptionMode -> ConnInfo -> ACommand Client AEConn -- response OK
-  CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
+  JOIN :: Bool -> AConnectionRequestUri -> PQSupport -> SubscriptionMode -> ConnInfo -> ACommand Client AEConn -- response OK
+  CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
   LET :: ConfirmationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
-  REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender
-  ACPT :: InvitationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
+  REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender
+  ACPT :: InvitationId -> PQSupport -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
   RJCT :: InvitationId -> ACommand Client AEConn
-  INFO :: ConnInfo -> ACommand Agent AEConn
-  CON :: ACommand Agent AEConn -- notification that connection is established
+  INFO :: PQSupport -> ConnInfo -> ACommand Agent AEConn
+  CON :: PQEncryption -> ACommand Agent AEConn -- notification that connection is established
   SUB :: ACommand Client AEConn
   END :: ACommand Agent AEConn
   CONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone
@@ -333,8 +396,8 @@ data ACommand (p :: AParty) (e :: AEntity) where
   UP :: SMPServer -> [ConnId] -> ACommand Agent AENone
   SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent AEConn
   RSYNC :: RatchetSyncState -> Maybe AgentCryptoError -> ConnectionStats -> ACommand Agent AEConn
-  SEND :: MsgFlags -> MsgBody -> ACommand Client AEConn
-  MID :: AgentMsgId -> ACommand Agent AEConn
+  SEND :: PQEncryption -> MsgFlags -> MsgBody -> ACommand Client AEConn
+  MID :: AgentMsgId -> PQEncryption -> ACommand Agent AEConn
   SENT :: AgentMsgId -> ACommand Agent AEConn
   MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
   MERRS :: NonEmpty AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
@@ -440,8 +503,8 @@ aCommandTag = \case
   REQ {} -> REQ_
   ACPT {} -> ACPT_
   RJCT _ -> RJCT_
-  INFO _ -> INFO_
-  CON -> CON_
+  INFO {} -> INFO_
+  CON _ -> CON_
   SUB -> SUB_
   END -> END_
   CONNECT {} -> CONNECT_
@@ -451,7 +514,7 @@ aCommandTag = \case
   SWITCH {} -> SWITCH_
   RSYNC {} -> RSYNC_
   SEND {} -> SEND_
-  MID _ -> MID_
+  MID {} -> MID_
   SENT _ -> SENT_
   MERR {} -> MERR_
   MERRS {} -> MERRS_
@@ -647,7 +710,7 @@ instance StrEncoding SndQueueInfo where
     pure SndQueueInfo {sndServer, sndSwitchStatus}
 
 data ConnectionStats = ConnectionStats
-  { connAgentVersion :: Version,
+  { connAgentVersion :: VersionSMPA,
     rcvQueuesInfo :: [RcvQueueInfo],
     sndQueuesInfo :: [SndQueueInfo],
     ratchetSyncState :: RatchetSyncState,
@@ -751,17 +814,19 @@ data MsgMeta = MsgMeta
   { integrity :: MsgIntegrity,
     recipient :: (AgentMsgId, UTCTime),
     broker :: (MsgId, UTCTime),
-    sndMsgId :: AgentMsgId
+    sndMsgId :: AgentMsgId,
+    pqEncryption :: PQEncryption
   }
   deriving (Eq, Show)
 
 instance StrEncoding MsgMeta where
-  strEncode MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
+  strEncode MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId, pqEncryption} =
     B.unwords
       [ strEncode integrity,
         "R=" <> bshow rmId <> "," <> showTs rTs,
         "B=" <> encode bmId <> "," <> showTs bTs,
-        "S=" <> bshow sndMsgId
+        "S=" <> bshow sndMsgId,
+        "PQ=" <> strEncode pqEncryption
       ]
     where
       showTs = B.pack . formatISO8601Millis
@@ -770,13 +835,14 @@ instance StrEncoding MsgMeta where
     recipient <- " R=" *> partyMeta A.decimal
     broker <- " B=" *> partyMeta base64P
     sndMsgId <- " S=" *> A.decimal
-    pure MsgMeta {integrity, recipient, broker, sndMsgId}
+    pqEncryption <- " PQ=" *> strP
+    pure MsgMeta {integrity, recipient, broker, sndMsgId, pqEncryption}
     where
       partyMeta idParser = (,) <$> idParser <* A.char ',' <*> tsISO8601P
 
 data SMPConfirmation = SMPConfirmation
   { -- | sender's public key to use for authentication of sender's commands at the recepient's server
-    senderKey :: SndPublicVerifyKey,
+    senderKey :: 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
@@ -784,28 +850,28 @@ data SMPConfirmation = SMPConfirmation
     -- | optional reply queues included in confirmation (added in agent protocol v2)
     smpReplyQueues :: [SMPQueueInfo],
     -- | SMP client version
-    smpClientVersion :: Version
+    smpClientVersion :: VersionSMPC
   }
   deriving (Show)
 
 data AgentMsgEnvelope
   = AgentConfirmation
-      { agentVersion :: Version,
-        e2eEncryption_ :: Maybe (E2ERatchetParams 'C.X448),
+      { agentVersion :: VersionSMPA,
+        e2eEncryption_ :: Maybe (SndE2ERatchetParams 'C.X448),
         encConnInfo :: ByteString
       }
   | AgentMsgEnvelope
-      { agentVersion :: Version,
+      { agentVersion :: VersionSMPA,
         encAgentMessage :: ByteString
       }
   | AgentInvitation -- the connInfo in contactInvite is only encrypted with per-queue E2E, not with double ratchet,
-      { agentVersion :: Version,
+      { agentVersion :: VersionSMPA,
         connReq :: ConnectionRequestUri 'CMInvitation,
         connInfo :: ByteString -- this message is only encrypted with per-queue E2E, not with double ratchet,
       }
   | AgentRatchetKey
-      { agentVersion :: Version,
-        e2eEncryption :: E2ERatchetParams 'C.X448,
+      { agentVersion :: VersionSMPA,
+        e2eEncryption :: RcvE2ERatchetParams 'C.X448,
         info :: ByteString
       }
   deriving (Show)
@@ -843,9 +909,10 @@ instance Encoding AgentMsgEnvelope where
 -- or in case of AgentInvitation - in plain text body)
 -- AgentRatchetInfo is not encrypted with double ratchet, but with per-queue E2E encryption
 data AgentMessage
-  = AgentConnInfo ConnInfo
-  | -- AgentConnInfoReply is only used in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
-    -- It makes REPLY message unnecessary.
+  = -- used by the initiating party when confirming reply queue
+  AgentConnInfo ConnInfo
+  | -- AgentConnInfoReply is used by accepting party in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
+    -- It made removed REPLY message unnecessary.
     AgentConnInfoReply (NonEmpty SMPQueueInfo) ConnInfo
   | AgentRatchetInfo ByteString
   | AgentMessage APrivHeader AMessage
@@ -927,8 +994,6 @@ agentMessageType = \case
     --   until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it.
     -- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured.
     HELLO -> AM_HELLO_
-    -- REPLY is only used in v1
-    REPLY _ -> AM_REPLY_
     A_MSG _ -> AM_A_MSG_
     A_RCVD {} -> AM_A_RCVD_
     QCONT _ -> AM_QCONT_
@@ -953,7 +1018,6 @@ instance Encoding APrivHeader where
 
 data AMsgType
   = HELLO_
-  | REPLY_
   | A_MSG_
   | A_RCVD_
   | QCONT_
@@ -967,7 +1031,6 @@ data AMsgType
 instance Encoding AMsgType where
   smpEncode = \case
     HELLO_ -> "H"
-    REPLY_ -> "R"
     A_MSG_ -> "M"
     A_RCVD_ -> "V"
     QCONT_ -> "QC"
@@ -979,7 +1042,6 @@ instance Encoding AMsgType where
   smpP =
     A.anyChar >>= \case
       'H' -> pure HELLO_
-      'R' -> pure REPLY_
       'M' -> pure A_MSG_
       'V' -> pure A_RCVD_
       'Q' ->
@@ -999,8 +1061,6 @@ instance Encoding AMsgType where
 data AMessage
   = -- | the first message in the queue to validate it is secured
     HELLO
-  | -- | reply queues information
-    REPLY (NonEmpty SMPQueueInfo)
   | -- | agent envelope for the client message
     A_MSG MsgBody
   | -- | agent envelope for delivery receipt
@@ -1010,7 +1070,7 @@ data AMessage
   | -- add queue to connection (sent by recipient), with optional address of the replaced queue
     QADD (NonEmpty (SMPQueueUri, Maybe SndQAddr))
   | -- key to secure the added queues and agree e2e encryption key (sent by sender)
-    QKEY (NonEmpty (SMPQueueInfo, SndPublicVerifyKey))
+    QKEY (NonEmpty (SMPQueueInfo, SndPublicAuthKey))
   | -- inform that the queues are ready to use (sent by recipient)
     QUSE (NonEmpty (SndQAddr, Bool))
   | -- sent by the sender to test new queues and to complete switching
@@ -1062,7 +1122,6 @@ type SndQAddr = (SMPServer, SMP.SenderId)
 instance Encoding AMessage where
   smpEncode = \case
     HELLO -> smpEncode HELLO_
-    REPLY smpQueues -> smpEncode (REPLY_, smpQueues)
     A_MSG body -> smpEncode (A_MSG_, Tail body)
     A_RCVD mrs -> smpEncode (A_RCVD_, mrs)
     QCONT addr -> smpEncode (QCONT_, addr)
@@ -1075,7 +1134,6 @@ instance Encoding AMessage where
     smpP
       >>= \case
         HELLO_ -> pure HELLO
-        REPLY_ -> REPLY <$> smpP
         A_MSG_ -> A_MSG . unTail <$> smpP
         A_RCVD_ -> A_RCVD <$> smpP
         QCONT_ -> QCONT <$> smpP
@@ -1105,7 +1163,7 @@ instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) whe
     CRInvitationUri crData e2eParams -> crEncode "invitation" crData (Just e2eParams)
     CRContactUri crData -> crEncode "contact" crData Nothing
     where
-      crEncode :: ByteString -> ConnReqUriData -> Maybe (E2ERatchetParamsUri 'C.X448) -> ByteString
+      crEncode :: ByteString -> ConnReqUriData -> Maybe (RcvE2ERatchetParamsUri 'C.X448) -> ByteString
       crEncode crMode ConnReqUriData {crScheme, crAgentVRange, crSmpQueues, crClientData} e2eParams =
         strEncode crScheme <> "/" <> crMode <> "#/?" <> queryStr
         where
@@ -1123,20 +1181,25 @@ instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) whe
 instance StrEncoding AConnectionRequestUri where
   strEncode (ACR _ cr) = strEncode cr
   strP = do
-    _crScheme :: ConnReqScheme <- strP
+    _crScheme :: ServiceScheme <- strP
     crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?"
     query <- strP
-    crAgentVRange <- queryParam "v" query
+    aVRange <- queryParam "v" query
     crSmpQueues <- queryParam "smp" query
     let crClientData = safeDecodeUtf8 <$> queryParamStr "data" query
-    let crData = ConnReqUriData {crScheme = CRSSimplex, crAgentVRange, crSmpQueues, crClientData}
+    let crData = ConnReqUriData {crScheme = SSSimplex, crAgentVRange = aVRange, crSmpQueues, crClientData}
     case crMode of
       CMInvitation -> do
         crE2eParams <- queryParam "e2e" query
         pure . ACR SCMInvitation $ CRInvitationUri crData crE2eParams
-      CMContact -> pure . ACR SCMContact $ CRContactUri crData
+      -- contact links are adjusted to the minimum version supported by the agent
+      -- to preserve compatibility with the old links published online
+      CMContact -> pure . ACR SCMContact $ CRContactUri crData {crAgentVRange = adjustAgentVRange aVRange}
     where
       crModeP = "invitation" $> CMInvitation <|> "contact" $> CMContact
+      adjustAgentVRange vr =
+        let v = max duplexHandshakeSMPAgentVersion $ minVersion vr
+         in fromMaybe vr $ safeVersionRange v (max v $ maxVersion vr)
 
 instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where
   parseJSON = strParseJSON "ConnectionRequestUri"
@@ -1213,16 +1276,16 @@ sameQueue :: SMPQueue q => (SMPServer, SMP.QueueId) -> q -> Bool
 sameQueue addr q = sameQAddress addr (qAddress q)
 {-# INLINE sameQueue #-}
 
-data SMPQueueInfo = SMPQueueInfo {clientVersion :: Version, queueAddress :: SMPQueueAddress}
+data SMPQueueInfo = SMPQueueInfo {clientVersion :: VersionSMPC, queueAddress :: SMPQueueAddress}
   deriving (Eq, Show)
 
 instance Encoding SMPQueueInfo where
   smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey})
-    | clientVersion > 1 = smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
+    | clientVersion > initialSMPClientVersion = smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
     | otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey)
   smpP = do
     clientVersion <- smpP
-    smpServer <- if clientVersion > 1 then smpP else updateSMPServerHosts <$> legacyServerP
+    smpServer <- if clientVersion > initialSMPClientVersion then smpP else updateSMPServerHosts <$> legacyServerP
     (senderId, dhPublicKey) <- smpP
     pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey}
 
@@ -1230,20 +1293,20 @@ instance Encoding SMPQueueInfo where
 -- But this is created to allow backward and forward compatibility where SMPQueueUri
 -- could have more fields to convert to different versions of SMPQueueInfo in a different way,
 -- and this instance would become non-trivial.
-instance VersionI SMPQueueInfo where
-  type VersionRangeT SMPQueueInfo = SMPQueueUri
+instance VersionI SMPClientVersion SMPQueueInfo where
+  type VersionRangeT SMPClientVersion SMPQueueInfo = SMPQueueUri
   version = clientVersion
   toVersionRangeT (SMPQueueInfo _v addr) vr = SMPQueueUri vr addr
 
-instance VersionRangeI SMPQueueUri where
-  type VersionT SMPQueueUri = SMPQueueInfo
+instance VersionRangeI SMPClientVersion SMPQueueUri where
+  type VersionT SMPClientVersion SMPQueueUri = SMPQueueInfo
   versionRange = clientVRange
   toVersionT (SMPQueueUri _vr addr) v = SMPQueueInfo v addr
 
 -- | SMP queue information sent out-of-band.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages
-data SMPQueueUri = SMPQueueUri {clientVRange :: VersionRange, queueAddress :: SMPQueueAddress}
+data SMPQueueUri = SMPQueueUri {clientVRange :: VersionRangeSMPC, queueAddress :: SMPQueueAddress}
   deriving (Eq, Show)
 
 data SMPQueueAddress = SMPQueueAddress
@@ -1277,7 +1340,7 @@ sameQAddress (srv, qId) (srv', qId') = sameSrvAddr srv srv' && qId == qId'
 
 instance StrEncoding SMPQueueUri where
   strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey})
-    | minVersion vr > 1 = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams
+    | minVersion vr >= srvHostnamesSMPClientVersion = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams
     | otherwise = legacyStrEncodeServer srv <> "/" <> strEncode qId <> "#/?" <> query (queryParams <> srvParam)
     where
       query = strEncode . QSP QEscape
@@ -1289,10 +1352,10 @@ instance StrEncoding SMPQueueUri where
     senderId <- strP <* optional (A.char '/') <* A.char '#'
     (vr, hs, dhPublicKey) <- unversioned <|> versioned
     let srv' = srv {host = h :| host <> hs}
-        smpServer = if maxVersion vr == 1 then updateSMPServerHosts srv' else srv'
+        smpServer = if maxVersion vr < srvHostnamesSMPClientVersion then updateSMPServerHosts srv' else srv'
     pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey}
     where
-      unversioned = (versionToRange 1,[],) <$> strP <* A.endOfInput
+      unversioned = (versionToRange initialSMPClientVersion,[],) <$> strP <* A.endOfInput
       versioned = do
         dhKey_ <- optional strP
         query <- optional (A.char '/') *> A.char '?' *> strP
@@ -1309,8 +1372,8 @@ instance Encoding SMPQueueUri where
     pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey}
 
 data ConnectionRequestUri (m :: ConnectionMode) where
-  CRInvitationUri :: ConnReqUriData -> E2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation
-  -- contact connection request does NOT contain E2E encryption parameters -
+  CRInvitationUri :: ConnReqUriData -> RcvE2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation
+  -- contact connection request does NOT contain E2E encryption parameters for double ratchet -
   -- they are passed in AgentInvitation message
   CRContactUri :: ConnReqUriData -> ConnectionRequestUri CMContact
 
@@ -1321,15 +1384,15 @@ deriving instance Show (ConnectionRequestUri m)
 data AConnectionRequestUri = forall m. ConnectionModeI m => ACR (SConnectionMode m) (ConnectionRequestUri m)
 
 instance Eq AConnectionRequestUri where
-  ACR m cr == ACR m' cr' = case testEquality m m' of
-    Just Refl -> cr == cr'
-    _ -> False
+   ACR m cr == ACR m' cr' = case testEquality m m' of
+     Just Refl -> cr == cr'
+     _ -> False
 
 deriving instance Show AConnectionRequestUri
 
 data ConnReqUriData = ConnReqUriData
-  { crScheme :: ConnReqScheme,
-    crAgentVRange :: VersionRange,
+  { crScheme :: ServiceScheme,
+    crAgentVRange :: VersionRangeSMPA,
     crSmpQueues :: NonEmpty SMPQueueUri,
     crClientData :: Maybe CRClientData
   }
@@ -1337,20 +1400,6 @@ data ConnReqUriData = ConnReqUriData
 
 type CRClientData = Text
 
-data ConnReqScheme = CRSSimplex | CRSAppServer SrvLoc
-  deriving (Eq, Show)
-
-instance StrEncoding ConnReqScheme where
-  strEncode = \case
-    CRSSimplex -> "simplex:"
-    CRSAppServer srv -> "https://" <> strEncode srv
-  strP =
-    "simplex:" $> CRSSimplex
-      <|> "https://" *> (CRSAppServer <$> strP)
-
-simplexChat :: ConnReqScheme
-simplexChat = CRSAppServer $ SrvLoc "simplex.chat" ""
-
 -- | SMP queue status.
 data QueueStatus
   = -- | queue is created
@@ -1712,13 +1761,13 @@ commandP binaryP =
     >>= \case
       ACmdTag SClient e cmd ->
         ACmd SClient e <$> case cmd of
-          NEW_ -> s (NEW <$> strP_ <*> strP_ <*> (strP <|> pure SMP.SMSubscribe))
-          JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> (strP_ <|> pure SMP.SMSubscribe) <*> binaryP)
+          NEW_ -> s (NEW <$> strP_ <*> strP_ <*> pqIKP <*> (strP <|> pure SMP.SMSubscribe))
+          JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> pqSupP <*> (strP_ <|> pure SMP.SMSubscribe) <*> binaryP)
           LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP)
-          ACPT_ -> s (ACPT <$> A.takeTill (== ' ') <* A.space <*> binaryP)
+          ACPT_ -> s (ACPT <$> A.takeTill (== ' ') <* A.space <*> pqSupP <*> binaryP)
           RJCT_ -> s (RJCT <$> A.takeByteString)
           SUB_ -> pure SUB
-          SEND_ -> s (SEND <$> smpP <* A.space <*> binaryP)
+          SEND_ -> s (SEND <$> pqEncP <*> smpP <* A.space <*> binaryP)
           ACK_ -> s (ACK <$> A.decimal <*> optional (A.space *> binaryP))
           SWCH_ -> pure SWCH
           OFF_ -> pure OFF
@@ -1727,10 +1776,10 @@ commandP binaryP =
       ACmdTag SAgent e cmd ->
         ACmd SAgent e <$> case cmd of
           INV_ -> s (INV <$> strP)
-          CONF_ -> s (CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> binaryP)
-          REQ_ -> s (REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> binaryP)
-          INFO_ -> s (INFO <$> binaryP)
-          CON_ -> pure CON
+          CONF_ -> s (CONF <$> A.takeTill (== ' ') <* A.space <*> pqSupP <*> strListP <* A.space <*> binaryP)
+          REQ_ -> s (REQ <$> A.takeTill (== ' ') <* A.space <*> pqSupP <*> strP_ <*> binaryP)
+          INFO_ -> s (INFO <$> pqSupP <*> binaryP)
+          CON_ -> s (CON <$> strP)
           END_ -> pure END
           CONNECT_ -> s (CONNECT <$> strP_ <*> strP)
           DISCONNECT_ -> s (DISCONNECT <$> strP_ <*> strP)
@@ -1738,7 +1787,7 @@ commandP binaryP =
           UP_ -> s (UP <$> strP_ <*> connections)
           SWITCH_ -> s (SWITCH <$> strP_ <*> strP_ <*> strP)
           RSYNC_ -> s (RSYNC <$> strP_ <*> strP <*> strP)
-          MID_ -> s (MID <$> A.decimal)
+          MID_ -> s (MID <$> A.decimal <*> _strP)
           SENT_ -> s (SENT <$> A.decimal)
           MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
           MERRS_ -> s (MERRS <$> strP_ <*> strP)
@@ -1761,6 +1810,12 @@ commandP binaryP =
   where
     s :: Parser a -> Parser a
     s p = A.space *> p
+    pqIKP :: Parser InitialKeys
+    pqIKP = strP_ <|> pure (IKNoPQ PQSupportOff)
+    pqSupP :: Parser PQSupport
+    pqSupP = strP_ <|> pure PQSupportOff
+    pqEncP :: Parser PQEncryption
+    pqEncP = strP_ <|> pure PQEncOff
     connections :: Parser [ConnId]
     connections = strP `A.sepBy'` A.char ','
     sfDone :: Text -> Either String (ACommand 'Agent 'AESndFile)
@@ -1776,15 +1831,15 @@ parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX
 -- | Serialize SMP agent command.
 serializeCommand :: ACommand p e -> ByteString
 serializeCommand = \case
-  NEW ntfs cMode subMode -> s (NEW_, ntfs, cMode, subMode)
+  NEW ntfs cMode pqIK subMode -> s (NEW_, ntfs, cMode, pqIK, subMode)
   INV cReq -> s (INV_, cReq)
-  JOIN ntfs cReq subMode cInfo -> s (JOIN_, ntfs, cReq, subMode, Str $ serializeBinary cInfo)
-  CONF confId srvs cInfo -> B.unwords [s CONF_, confId, strEncodeList srvs, serializeBinary cInfo]
+  JOIN ntfs cReq pqSup subMode cInfo -> s (JOIN_, ntfs, cReq, pqSup, subMode, Str $ serializeBinary cInfo)
+  CONF confId pqSup srvs cInfo -> B.unwords [s CONF_, confId, s pqSup, strEncodeList srvs, serializeBinary cInfo]
   LET confId cInfo -> B.unwords [s LET_, confId, serializeBinary cInfo]
-  REQ invId srvs cInfo -> B.unwords [s REQ_, invId, s srvs, serializeBinary cInfo]
-  ACPT invId cInfo -> B.unwords [s ACPT_, invId, serializeBinary cInfo]
+  REQ invId pqSup srvs cInfo -> B.unwords [s REQ_, invId, s pqSup, s srvs, serializeBinary cInfo]
+  ACPT invId pqSup cInfo -> B.unwords [s ACPT_, invId, s pqSup, serializeBinary cInfo]
   RJCT invId -> B.unwords [s RJCT_, invId]
-  INFO cInfo -> B.unwords [s INFO_, serializeBinary cInfo]
+  INFO pqSup cInfo -> B.unwords [s INFO_, s pqSup, serializeBinary cInfo]
   SUB -> s SUB_
   END -> s END_
   CONNECT p h -> s (CONNECT_, p, h)
@@ -1793,8 +1848,8 @@ serializeCommand = \case
   UP srv conns -> B.unwords [s UP_, s srv, connections conns]
   SWITCH dir phase srvs -> s (SWITCH_, dir, phase, srvs)
   RSYNC rrState cryptoErr cstats -> s (RSYNC_, rrState, cryptoErr, cstats)
-  SEND msgFlags msgBody -> B.unwords [s SEND_, smpEncode msgFlags, serializeBinary msgBody]
-  MID mId -> s (MID_, mId)
+  SEND pqEnc msgFlags msgBody -> B.unwords [s SEND_, s pqEnc, smpEncode msgFlags, serializeBinary msgBody]
+  MID mId pqEnc -> s (MID_, mId, pqEnc)
   SENT mId -> s (SENT_, mId)
   MERR mId e -> s (MERR_, mId, e)
   MERRS mIds e -> s (MERRS_, mIds, e)
@@ -1810,7 +1865,7 @@ serializeCommand = \case
   DEL_USER userId -> s (DEL_USER_, userId)
   CHK -> s CHK_
   STAT srvs -> s (STAT_, srvs)
-  CON -> s CON_
+  CON pqEnc -> s (CON_, pqEnc)
   ERR e -> s (ERR_, e)
   OK -> s OK_
   SUSPENDED -> s SUSPENDED_
@@ -1883,14 +1938,14 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
     cmdWithMsgBody :: APartyCmd p -> m (Either AgentErrorType (APartyCmd p))
     cmdWithMsgBody (APC e cmd) =
       APC e <$$> case cmd of
-        SEND msgFlags body -> SEND msgFlags <$$> getBody body
+        SEND pqEnc msgFlags body -> SEND pqEnc msgFlags <$$> getBody body
         MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
-        JOIN ntfs qUri subMode cInfo -> JOIN ntfs qUri subMode <$$> getBody cInfo
-        CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
+        JOIN ntfs qUri pqSup subMode cInfo -> JOIN ntfs qUri pqSup subMode <$$> getBody cInfo
+        CONF confId pqSup srvs cInfo -> CONF confId pqSup srvs <$$> getBody cInfo
         LET confId cInfo -> LET confId <$$> getBody cInfo
-        REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
-        ACPT invId cInfo -> ACPT invId <$$> getBody cInfo
-        INFO cInfo -> INFO <$$> getBody cInfo
+        REQ invId pqSup srvs cInfo -> REQ invId pqSup srvs <$$> getBody cInfo
+        ACPT invId pqSup cInfo -> ACPT invId pqSup <$$> getBody cInfo
+        INFO pqSup cInfo -> INFO pqSup <$$> getBody cInfo
         _ -> pure $ Right cmd
 
     getBody :: ByteString -> m (Either AgentErrorType ByteString)

src/Simplex/Messaging/Agent/Store.hs

@@ -30,23 +30,24 @@ import Data.Type.Equality
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval (RI2State)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Ratchet (RatchetX448)
+import Simplex.Messaging.Crypto.Ratchet (RatchetX448, PQEncryption, PQSupport)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
   ( MsgBody,
     MsgFlags,
     MsgId,
     NotifierId,
-    NtfPrivateSignKey,
-    NtfPublicVerifyKey,
+    NtfPrivateAuthKey,
+    NtfPublicAuthKey,
     RcvDhSecret,
     RcvNtfDhSecret,
-    RcvPrivateSignKey,
-    SndPrivateSignKey,
+    RcvPrivateAuthKey,
+    SndPrivateAuthKey,
+    SndPublicAuthKey,
+    VersionSMPC,
   )
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Util ((<$?>))
-import Simplex.Messaging.Version
 
 -- * Queue types
 
@@ -60,8 +61,6 @@ data DBQueueId (q :: QueueStored) where
   DBQueueId :: Int64 -> DBQueueId 'QSStored
   DBNewQueue :: DBQueueId 'QSNew
 
-deriving instance Eq (DBQueueId q)
-
 deriving instance Show (DBQueueId q)
 
 type RcvQueue = StoredRcvQueue 'QSStored
@@ -75,8 +74,8 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
     server :: SMPServer,
     -- | recipient queue ID
     rcvId :: SMP.RecipientId,
-    -- | key used by the recipient to sign transmissions
-    rcvPrivateKey :: RcvPrivateSignKey,
+    -- | key used by the recipient to authorize transmissions
+    rcvPrivateKey :: RcvPrivateAuthKey,
     -- | shared DH secret used to encrypt/decrypt message bodies from server to recipient
     rcvDhSecret :: RcvDhSecret,
     -- | private DH key related to public sent to sender out-of-band (to agree simple per-queue e2e)
@@ -95,12 +94,12 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
     dbReplaceQueueId :: Maybe Int64,
     rcvSwchStatus :: Maybe RcvSwitchStatus,
     -- | SMP client version
-    smpClientVersion :: Version,
+    smpClientVersion :: VersionSMPC,
     -- | credentials used in context of notifications
     clientNtfCreds :: Maybe ClientNtfCreds,
     deleteErrors :: Int
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 rcvQueueInfo :: RcvQueue -> RcvQueueInfo
 rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
@@ -119,15 +118,15 @@ canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus
       RSReceivedMessage -> False
 
 data ClientNtfCreds = ClientNtfCreds
-  { -- | key pair to be used by the notification server to sign transmissions
-    ntfPublicKey :: NtfPublicVerifyKey,
-    ntfPrivateKey :: NtfPrivateSignKey,
+  { -- | key pair to be used by the notification server to authorize transmissions
+    ntfPublicKey :: NtfPublicAuthKey,
+    ntfPrivateKey :: NtfPrivateAuthKey,
     -- | queue ID to be used by the notification server for NSUB command
     notifierId :: NotifierId,
     -- | shared DH secret used to encrypt/decrypt notification metadata (NMsgMeta) from server to recipient
     rcvNtfDhSecret :: RcvNtfDhSecret
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 type SndQueue = StoredSndQueue 'QSStored
 
@@ -140,9 +139,10 @@ data StoredSndQueue (q :: QueueStored) = SndQueue
     server :: SMPServer,
     -- | sender queue ID
     sndId :: SMP.SenderId,
-    -- | key pair used by the sender to sign transmissions
-    sndPublicKey :: Maybe C.APublicVerifyKey,
-    sndPrivateKey :: SndPrivateSignKey,
+    -- | key pair used by the sender to authorize transmissions
+    -- TODO combine keys to key pair so that types match
+    sndPublicKey :: Maybe SndPublicAuthKey,
+    sndPrivateKey :: SndPrivateAuthKey,
     -- | DH public key used to negotiate per-queue e2e encryption
     e2ePubKey :: Maybe C.PublicKeyX25519,
     -- | shared DH secret agreed for simple per-queue e2e encryption
@@ -157,9 +157,9 @@ data StoredSndQueue (q :: QueueStored) = SndQueue
     dbReplaceQueueId :: Maybe Int64,
     sndSwchStatus :: Maybe SndSwitchStatus,
     -- | SMP client version
-    smpClientVersion :: Version
+    smpClientVersion :: VersionSMPC
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 sndQueueInfo :: SndQueue -> SndQueueInfo
 sndQueueInfo SndQueue {server, sndSwchStatus} =
@@ -254,8 +254,6 @@ data Connection (d :: ConnType) where
   DuplexConnection :: ConnData -> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection CDuplex
   ContactConnection :: ConnData -> RcvQueue -> Connection CContact
 
-deriving instance Eq (Connection d)
-
 deriving instance Show (Connection d)
 
 toConnData :: Connection d -> ConnData
@@ -288,8 +286,6 @@ connType SCSnd = CSnd
 connType SCDuplex = CDuplex
 connType SCContact = CContact
 
-deriving instance Eq (SConnType d)
-
 deriving instance Show (SConnType d)
 
 instance TestEquality SConnType where
@@ -303,35 +299,24 @@ instance TestEquality SConnType where
 -- Used to refer to an arbitrary connection when retrieving from store.
 data SomeConn = forall d. SomeConn (SConnType d) (Connection d)
 
-instance Eq SomeConn where
-  SomeConn d c == SomeConn d' c' = case testEquality d d' of
-    Just Refl -> c == c'
-    _ -> False
-
 deriving instance Show SomeConn
 
 data ConnData = ConnData
   { connId :: ConnId,
     userId :: UserId,
-    connAgentVersion :: Version,
+    connAgentVersion :: VersionSMPA,
     enableNtfs :: Bool,
-    duplexHandshake :: Maybe Bool, -- added in agent protocol v2
     lastExternalSndId :: PrevExternalSndId,
     deleted :: Bool,
-    ratchetSyncState :: RatchetSyncState
+    ratchetSyncState :: RatchetSyncState,
+    pqSupport :: PQSupport
   }
   deriving (Eq, Show)
 
 -- this function should be mirrored in the clients
 ratchetSyncAllowed :: ConnData -> Bool
-ratchetSyncAllowed cData@ConnData {ratchetSyncState} =
-  ratchetSyncSupported' cData && (ratchetSyncState `elem` ([RSAllowed, RSRequired] :: [RatchetSyncState]))
-
-ratchetSyncSupported' :: ConnData -> Bool
-ratchetSyncSupported' ConnData {connAgentVersion} = connAgentVersion >= 3
-
-messageRcptsSupported :: ConnData -> Bool
-messageRcptsSupported ConnData {connAgentVersion} = connAgentVersion >= 4
+ratchetSyncAllowed ConnData {ratchetSyncState, connAgentVersion} =
+  connAgentVersion >= ratchetSyncSMPAgentVersion && (ratchetSyncState `elem` ([RSAllowed, RSRequired] :: [RatchetSyncState]))
 
 -- this function should be mirrored in the clients
 ratchetSyncSendProhibited :: ConnData -> Bool
@@ -388,11 +373,11 @@ instance StrEncoding AgentCommandTag where
 data InternalCommand
   = ICAck SMP.RecipientId MsgId
   | ICAckDel SMP.RecipientId MsgId InternalId
-  | ICAllowSecure SMP.RecipientId SMP.SndPublicVerifyKey
-  | ICDuplexSecure SMP.RecipientId SMP.SndPublicVerifyKey
+  | ICAllowSecure SMP.RecipientId SMP.SndPublicAuthKey
+  | ICDuplexSecure SMP.RecipientId SMP.SndPublicAuthKey
   | ICDeleteConn
   | ICDeleteRcvQueue SMP.RecipientId
-  | ICQSecure SMP.RecipientId SMP.SndPublicVerifyKey
+  | ICQSecure SMP.RecipientId SMP.SndPublicAuthKey
   | ICQDelete SMP.RecipientId
 
 data InternalCommandTag
@@ -539,6 +524,7 @@ data SndMsgData = SndMsgData
     msgType :: AgentMessageType,
     msgFlags :: MsgFlags,
     msgBody :: MsgBody,
+    pqEncryption :: PQEncryption,
     internalHash :: MsgHash,
     prevMsgHash :: MsgHash
   }
@@ -556,6 +542,7 @@ data PendingMsgData = PendingMsgData
     msgType :: AgentMessageType,
     msgFlags :: MsgFlags,
     msgBody :: MsgBody,
+    pqEncryption :: PQEncryption,
     msgRetryState :: Maybe RI2State,
     internalTs :: InternalTs
   }

src/Simplex/Messaging/Agent/Store/SQLite.hs

@@ -50,7 +50,6 @@ module Simplex.Messaging.Agent.Store.SQLite
     createNewConn,
     updateNewConnRcv,
     updateNewConnSnd,
-    createRcvConn, -- no longer used
     createSndConn,
     getConn,
     getDeletedConn,
@@ -59,7 +58,9 @@ module Simplex.Messaging.Agent.Store.SQLite
     getConnData,
     setConnDeleted,
     setConnAgentVersion,
+    setConnPQSupport,
     getDeletedConnIds,
+    getDeletedWaitingDeliveryConnIds,
     setConnRatchetSync,
     addProcessedRatchetKeyHash,
     checkRatchetKeyHashExists,
@@ -92,7 +93,6 @@ module Simplex.Messaging.Agent.Store.SQLite
     acceptConfirmation,
     getAcceptedConfirmation,
     removeConfirmations,
-    setHandshakeVersion,
     -- Invitations - sent via Contact connections
     createInvitation,
     getInvitation,
@@ -123,8 +123,6 @@ module Simplex.Messaging.Agent.Store.SQLite
     -- Double ratchet persistence
     createRatchetX3dhKeys,
     getRatchetX3dhKeys,
-    createRatchetX3dhKeys',
-    getRatchetX3dhKeys',
     setRatchetX3dhKeys,
     createRatchet,
     deleteRatchet,
@@ -164,13 +162,16 @@ module Simplex.Messaging.Agent.Store.SQLite
 
     -- Rcv files
     createRcvFile,
+    createRcvFileRedirect,
     getRcvFile,
     getRcvFileByEntityId,
+    getRcvFileRedirects,
     updateRcvChunkReplicaDelay,
     updateRcvFileChunkReceived,
     updateRcvFileStatus,
     updateRcvFileError,
     updateRcvFileComplete,
+    updateRcvFileRedirect,
     updateRcvFileNoTmpPath,
     updateRcvFileDeleted,
     deleteRcvFile',
@@ -230,7 +231,7 @@ import Data.Bifunctor (first, second)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
-import qualified Data.ByteString.Base64.URL as U
+import qualified Data.ByteString.Char8 as B
 import Data.Char (toLower)
 import Data.Functor (($>))
 import Data.IORef
@@ -239,7 +240,7 @@ import Data.List (foldl', intercalate, sortBy)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe, isJust, listToMaybe)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)
 import Data.Ord (Down (..))
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -255,7 +256,7 @@ import qualified Database.SQLite3 as SQLite3
 import Network.Socket (ServiceName)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
 import Simplex.FileTransfer.Types
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval (RI2State (..))
@@ -266,8 +267,10 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations (DownMigration (..), MTRE
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
-import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
+import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys, PQEncryption (..), PQSupport (..))
+import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
+import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
 import Simplex.Messaging.Notifications.Types
@@ -276,7 +279,7 @@ import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, safeDecodeUtf8, ($>>=), (<$$>))
-import Simplex.Messaging.Version
+import Simplex.Messaging.Version.Internal
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
 import System.Exit (exitFailure)
 import System.FilePath (takeDirectory)
@@ -540,11 +543,8 @@ createConn_ gVar cData create = checkConstraint SEConnDuplicate $ case cData of
   ConnData {connId} -> Right . (connId,) <$> create connId
 
 createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode c -> IO (Either StoreError ConnId)
-createNewConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} cMode = do
-  fst <$$> createConn_ gVar cData create
-  where
-    create connId =
-      DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
+createNewConn db gVar cData cMode = do
+  fst <$$> createConn_ gVar cData (\connId -> createConnRecord db connId cData cMode)
 
 updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue)
 updateNewConnRcv db connId rq =
@@ -566,22 +566,25 @@ updateNewConnSnd db connId sq =
     updateConn :: IO (Either StoreError SndQueue)
     updateConn = Right <$> addConnSndQueue_ db connId sq
 
-createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewRcvQueue -> SConnectionMode c -> IO (Either StoreError (ConnId, RcvQueue))
-createRcvConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} q@RcvQueue {server} cMode =
-  createConn_ gVar cData $ \connId -> do
-    serverKeyHash_ <- createServer_ db server
-    DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, cMode, connAgentVersion, enableNtfs, duplexHandshake)
-    insertRcvQueue_ db connId q serverKeyHash_
-
 createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewSndQueue -> IO (Either StoreError (ConnId, SndQueue))
-createSndConn db gVar cData@ConnData {userId, connAgentVersion, enableNtfs, duplexHandshake} q@SndQueue {server} =
+createSndConn db gVar cData q@SndQueue {server} =
   -- check confirmed snd queue doesn't already exist, to prevent it being deleted by REPLACE in insertSndQueue_
   ifM (liftIO $ checkConfirmedSndQueueExists_ db q) (pure $ Left SESndQueueExists) $
     createConn_ gVar cData $ \connId -> do
       serverKeyHash_ <- createServer_ db server
-      DB.execute db "INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)" (userId, connId, SCMInvitation, connAgentVersion, enableNtfs, duplexHandshake)
+      createConnRecord db connId cData SCMInvitation
       insertSndQueue_ db connId q serverKeyHash_
 
+createConnRecord :: DB.Connection -> ConnId -> ConnData -> SConnectionMode c -> IO ()
+createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSupport} cMode =
+  DB.execute
+    db
+    [sql|
+      INSERT INTO connections
+        (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, duplex_handshake) VALUES (?,?,?,?,?,?,?)
+    |]
+    (userId, connId, cMode, connAgentVersion, enableNtfs, pqSupport, True)
+
 checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool
 checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do
   fromMaybe False
@@ -600,12 +603,32 @@ getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do
       DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (host, port, rcvId)
   (rq,) <$> ExceptT (getConn db connId)
 
-deleteConn :: DB.Connection -> ConnId -> IO ()
-deleteConn db connId =
-  DB.executeNamed
-    db
-    "DELETE FROM connections WHERE conn_id = :conn_id;"
-    [":conn_id" := connId]
+-- | Deletes connection, optionally checking for pending snd message deliveries; returns connection id if it was deleted
+deleteConn :: DB.Connection -> Maybe NominalDiffTime -> ConnId -> IO (Maybe ConnId)
+deleteConn db waitDeliveryTimeout_ connId = case waitDeliveryTimeout_ of
+  Nothing -> delete
+  Just timeout ->
+    ifM
+      checkNoPendingDeliveries_
+      delete
+      ( ifM
+          (checkWaitDeliveryTimeout_ timeout)
+          delete
+          (pure Nothing)
+      )
+  where
+    delete = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) $> Just connId
+    checkNoPendingDeliveries_ = do
+      r :: (Maybe Int64) <-
+        maybeFirstRow fromOnly $
+          DB.query db "SELECT 1 FROM snd_message_deliveries WHERE conn_id = ? AND failed = 0 LIMIT 1" (Only connId)
+      pure $ isNothing r
+    checkWaitDeliveryTimeout_ timeout = do
+      cutoffTs <- addUTCTime (-timeout) <$> getCurrentTime
+      r :: (Maybe Int64) <-
+        maybeFirstRow fromOnly $
+          DB.query db "SELECT 1 FROM connections WHERE conn_id = ? AND deleted_at_wait_delivery < ? LIMIT 1" (connId, cutoffTs)
+      pure $ isJust r
 
 upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue)
 upgradeRcvConnToDuplex db connId sq =
@@ -679,7 +702,7 @@ setRcvQueueDeleted db RcvQueue {rcvId, server = ProtocolServer {host, port}} = d
     |]
     (host, port, rcvId)
 
-setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> Version -> IO ()
+setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> VersionSMPC -> IO ()
 setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret smpClientVersion =
   DB.executeNamed
     db
@@ -780,7 +803,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 = (SndPublicVerifyKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe Version)
+type SMPConfirmationRow = (SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC)
 
 smpConfirmation :: SMPConfirmationRow -> SMPConfirmation
 smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) =
@@ -789,7 +812,7 @@ smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersi
       e2ePubKey,
       connInfo,
       smpReplyQueues = fromMaybe [] smpReplyQueues_,
-      smpClientVersion = fromMaybe 1 smpClientVersion_
+      smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_
     }
 
 createConfirmation :: DB.Connection -> TVar ChaChaDRG -> NewConfirmation -> IO (Either StoreError ConfirmationId)
@@ -866,10 +889,6 @@ removeConfirmations db connId =
     |]
     [":conn_id" := connId]
 
-setHandshakeVersion :: DB.Connection -> ConnId -> Version -> Bool -> IO ()
-setHandshakeVersion db connId aVersion duplexHS =
-  DB.execute db "UPDATE connections SET smp_agent_version = ?, duplex_handshake = ? WHERE conn_id = ?" (aVersion, duplexHS, connId)
-
 createInvitation :: DB.Connection -> TVar ChaChaDRG -> NewInvitation -> IO (Either StoreError InvitationId)
 createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInfo} =
   createWithRandomId gVar $ \invitationId ->
@@ -1006,18 +1025,18 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} =
           DB.query
             db
             [sql|
-              SELECT m.msg_type, m.msg_flags, m.msg_body, m.internal_ts, s.retry_int_slow, s.retry_int_fast
+              SELECT m.msg_type, m.msg_flags, m.msg_body, m.pq_encryption, m.internal_ts, s.retry_int_slow, s.retry_int_fast
               FROM messages m
               JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id
               WHERE m.conn_id = ? AND m.internal_id = ?
             |]
             (connId, msgId)
         err = SEInternal $ "msg delivery " <> bshow msgId <> " returned []"
-        pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, InternalTs, Maybe Int64, Maybe Int64) -> PendingMsgData
-        pendingMsgData (msgType, msgFlags_, msgBody, internalTs, riSlow_, riFast_) =
+        pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, PQEncryption, InternalTs, Maybe Int64, Maybe Int64) -> PendingMsgData
+        pendingMsgData (msgType, msgFlags_, msgBody, pqEncryption, internalTs, riSlow_, riFast_) =
           let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_
               msgRetryState = RI2State <$> riSlow_ <*> riFast_
-           in PendingMsgData {msgId, msgType, msgFlags, msgBody, msgRetryState, internalTs}
+           in PendingMsgData {msgId, msgType, msgFlags, msgBody, pqEncryption, msgRetryState, internalTs}
     markMsgFailed msgId = DB.execute db "UPDATE snd_message_deliveries SET failed = 1 WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
 
 getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a))
@@ -1086,7 +1105,7 @@ getRcvMsg db connId agentMsgId =
       [sql|
         SELECT
           r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash,
-          m.msg_type, m.msg_body, s.internal_id, s.rcpt_status, r.user_ack
+          m.msg_type, m.msg_body, m.pq_encryption, s.internal_id, s.rcpt_status, r.user_ack
         FROM rcv_messages r
         JOIN messages m ON r.conn_id = m.conn_id AND r.internal_id = m.internal_id
         LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id
@@ -1102,7 +1121,7 @@ getLastMsg db connId msgId =
       [sql|
         SELECT
           r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash,
-          m.msg_type, m.msg_body, s.internal_id, s.rcpt_status, r.user_ack
+          m.msg_type, m.msg_body, m.pq_encryption, s.internal_id, s.rcpt_status, r.user_ack
         FROM rcv_messages r
         JOIN messages m ON r.conn_id = m.conn_id AND r.internal_id = m.internal_id
         JOIN connections c ON r.conn_id = c.conn_id AND c.last_internal_msg_id = r.internal_id
@@ -1111,9 +1130,9 @@ getLastMsg db connId msgId =
       |]
       (connId, msgId)
 
-toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs, AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, Maybe AgentMsgId, Maybe MsgReceiptStatus, Bool) -> RcvMsg
-toRcvMsg (agentMsgId, internalTs, brokerId, brokerTs, sndMsgId, integrity, internalHash, msgType, msgBody, rcptInternalId_, rcptStatus_, userAck) =
-  let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity}
+toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs) :. (AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, PQEncryption, Maybe AgentMsgId, Maybe MsgReceiptStatus, Bool) -> RcvMsg
+toRcvMsg ((agentMsgId, internalTs, brokerId, brokerTs) :. (sndMsgId, integrity, internalHash, msgType, msgBody, pqEncryption, rcptInternalId_, rcptStatus_, userAck)) =
+  let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity, pqEncryption}
       msgReceipt = MsgReceipt <$> rcptInternalId_ <*> rcptStatus_
    in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgType, msgBody, internalHash, msgReceipt, userAck}
 
@@ -1173,49 +1192,34 @@ deleteSndMsgsExpired db ttl = do
     "DELETE FROM messages WHERE internal_ts < ? AND internal_snd_id IS NOT NULL"
     (Only cutoffTs)
 
-createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> IO ()
-createRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 =
-  DB.execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2) VALUES (?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2)
+createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO ()
+createRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem =
+  DB.execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2, pq_priv_kem) VALUES (?, ?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2, pqPrivKem)
 
-getRatchetX3dhKeys :: DB.Connection -> ConnId -> IO (Either StoreError (C.PrivateKeyX448, C.PrivateKeyX448))
+getRatchetX3dhKeys :: DB.Connection -> ConnId -> IO (Either StoreError (C.PrivateKeyX448, C.PrivateKeyX448, Maybe CR.RcvPrivRKEMParams))
 getRatchetX3dhKeys db connId =
-  fmap hasKeys $
-    firstRow id SEX3dhKeysNotFound $
-      DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2 FROM ratchets WHERE conn_id = ?" (Only connId)
+  firstRow' keys SEX3dhKeysNotFound $
+    DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2, pq_priv_kem FROM ratchets WHERE conn_id = ?" (Only connId)
   where
-    hasKeys = \case
-      Right (Just k1, Just k2) -> Right (k1, k2)
-      _ -> Left SEX3dhKeysNotFound
-
-createRatchetX3dhKeys' :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> C.PublicKeyX448 -> C.PublicKeyX448 -> IO ()
-createRatchetX3dhKeys' db connId x3dhPrivKey1 x3dhPrivKey2 x3dhPubKey1 x3dhPubKey2 =
-  DB.execute
-    db
-    "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2, x3dh_pub_key_1, x3dh_pub_key_2) VALUES (?,?,?,?,?)"
-    (connId, x3dhPrivKey1, x3dhPrivKey2, x3dhPubKey1, x3dhPubKey2)
-
-getRatchetX3dhKeys' :: DB.Connection -> ConnId -> IO (Either StoreError (C.PrivateKeyX448, C.PrivateKeyX448, C.PublicKeyX448, C.PublicKeyX448))
-getRatchetX3dhKeys' db connId =
-  fmap hasKeys $
-    firstRow id SEX3dhKeysNotFound $
-      DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2, x3dh_pub_key_1, x3dh_pub_key_2 FROM ratchets WHERE conn_id = ?" (Only connId)
-  where
-    hasKeys = \case
-      Right (Just pk1, Just pk2, Just k1, Just k2) -> Right (pk1, pk2, k1, k2)
+    keys = \case
+      (Just k1, Just k2, pKem) -> Right (k1, k2, pKem)
       _ -> Left SEX3dhKeysNotFound
 
 -- used to remember new keys when starting ratchet re-synchronization
-setRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> C.PublicKeyX448 -> C.PublicKeyX448 -> IO ()
-setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 x3dhPubKey1 x3dhPubKey2 =
+-- TODO remove the columns for public keys in v5.7.
+-- Currently, the keys are not used but still stored to support app downgrade to the previous version.
+setRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO ()
+setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem =
   DB.execute
     db
     [sql|
       UPDATE ratchets
-      SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?
+      SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ? 
       WHERE conn_id = ?
     |]
-    (x3dhPrivKey1, x3dhPrivKey2, x3dhPubKey1, x3dhPubKey2, connId)
+    (x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, pqPrivKem, connId)
 
+-- TODO remove the columns for public keys in v5.7.
 createRatchet :: DB.Connection -> ConnId -> RatchetX448 -> IO ()
 createRatchet db connId rc =
   DB.executeNamed
@@ -1228,7 +1232,8 @@ createRatchet db connId rc =
         x3dh_priv_key_1 = NULL,
         x3dh_priv_key_2 = NULL,
         x3dh_pub_key_1 = NULL,
-        x3dh_pub_key_2 = NULL
+        x3dh_pub_key_2 = NULL,
+        pq_priv_kem = NULL
     |]
     [":conn_id" := connId, ":ratchet_state" := rc]
 
@@ -1767,6 +1772,10 @@ instance ToField MsgReceiptStatus where toField = toField . decodeLatin1 . strEn
 
 instance FromField MsgReceiptStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
 
+instance ToField (Version v) where toField (Version v) = toField v
+
+instance FromField (Version v) where fromField f = Version <$> fromField f
+
 listToEither :: e -> [a] -> Either e a
 listToEither _ (x : _) = Right x
 listToEither e _ = Left e
@@ -1917,26 +1926,39 @@ getConnData db connId' =
       db
       [sql|
         SELECT
-          user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake,
-          last_external_snd_msg_id, deleted, ratchet_sync_state
+          user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs,
+          last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support
         FROM connections
         WHERE conn_id = ?
       |]
       (Only connId')
   where
-    cData (userId, connId, cMode, connAgentVersion, enableNtfs_, duplexHandshake, lastExternalSndId, deleted, ratchetSyncState) =
-      (ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, duplexHandshake, lastExternalSndId, deleted, ratchetSyncState}, cMode)
+    cData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport) =
+      (ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport}, cMode)
 
-setConnDeleted :: DB.Connection -> ConnId -> IO ()
-setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
+setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO ()
+setConnDeleted db waitDelivery connId
+  | waitDelivery = do
+      currentTs <- getCurrentTime
+      DB.execute db "UPDATE connections SET deleted_at_wait_delivery = ? WHERE conn_id = ?" (currentTs, connId)
+  | otherwise =
+      DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
 
-setConnAgentVersion :: DB.Connection -> ConnId -> Version -> IO ()
+setConnAgentVersion :: DB.Connection -> ConnId -> VersionSMPA -> IO ()
 setConnAgentVersion db connId aVersion =
   DB.execute db "UPDATE connections SET smp_agent_version = ? WHERE conn_id = ?" (aVersion, connId)
 
+setConnPQSupport :: DB.Connection -> ConnId -> PQSupport -> IO ()
+setConnPQSupport db connId pqSupport =
+  DB.execute db "UPDATE connections SET pq_support = ? WHERE conn_id = ?" (pqSupport, connId)
+
 getDeletedConnIds :: DB.Connection -> IO [ConnId]
 getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True)
 
+getDeletedWaitingDeliveryConnIds :: DB.Connection -> IO [ConnId]
+getDeletedWaitingDeliveryConnIds db =
+  map fromOnly <$> DB.query_ db "SELECT conn_id FROM connections WHERE deleted_at_wait_delivery IS NOT NULL"
+
 setConnRatchetSync :: DB.Connection -> ConnId -> RatchetSyncState -> IO ()
 setConnRatchetSync db connId ratchetSyncState =
   DB.execute db "UPDATE connections SET ratchet_sync_state = ? WHERE conn_id = ?" (ratchetSyncState, connId)
@@ -1984,13 +2006,13 @@ rcvQueueQuery =
   |]
 
 toRcvQueue ::
-  (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus)
-    :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe Version, Int)
-    :. (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) ->
+  (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)
+    :. (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_)) =
   let server = SMPServer host port keyHash
-      smpClientVersion = fromMaybe 1 smpClientVersion_
+      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
@@ -2025,8 +2047,8 @@ sndQueueQuery =
 
 toSndQueue ::
   (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId)
-    :. (Maybe C.APublicVerifyKey, SndPrivateSignKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus)
-    :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, Version) ->
+    :. (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)
@@ -2075,23 +2097,15 @@ updateLastIdsRcv_ dbConn connId newInternalId newInternalRcvId =
 
 insertRcvMsgBase_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
 insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgFlags, msgBody, internalRcvId} = do
-  let MsgMeta {recipient = (internalId, internalTs)} = msgMeta
-  DB.executeNamed
+  let MsgMeta {recipient = (internalId, internalTs), pqEncryption} = msgMeta
+  DB.execute
     dbConn
     [sql|
       INSERT INTO messages
-        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body)
-      VALUES
-        (:conn_id,:internal_id,:internal_ts,:internal_rcv_id,            NULL,:msg_type,:msg_flags,:msg_body);
+        (conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body, pq_encryption)
+        VALUES (?,?,?,?,?,?,?,?,?);
     |]
-    [ ":conn_id" := connId,
-      ":internal_id" := internalId,
-      ":internal_ts" := internalTs,
-      ":internal_rcv_id" := internalRcvId,
-      ":msg_type" := msgType,
-      ":msg_flags" := msgFlags,
-      ":msg_body" := msgBody
-    ]
+    (connId, internalId, internalTs, internalRcvId, Nothing :: Maybe Int64, msgType, msgFlags, msgBody, pqEncryption)
 
 insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO ()
 insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash, encryptedMsgHash} = do
@@ -2172,23 +2186,16 @@ updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId =
 -- * createSndMsg helpers
 
 insertSndMsgBase_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
-insertSndMsgBase_ dbConn connId SndMsgData {..} = do
-  DB.executeNamed
-    dbConn
+insertSndMsgBase_ db connId SndMsgData {internalId, internalTs, internalSndId, msgType, msgFlags, msgBody, pqEncryption} = do
+  DB.execute
+    db
     [sql|
       INSERT INTO messages
-        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body)
+        (conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body, pq_encryption)
       VALUES
-        (:conn_id,:internal_id,:internal_ts,            NULL,:internal_snd_id,:msg_type,:msg_flags,:msg_body);
+        (?,?,?,?,?,?,?,?,?);
     |]
-    [ ":conn_id" := connId,
-      ":internal_id" := internalId,
-      ":internal_ts" := internalTs,
-      ":internal_snd_id" := internalSndId,
-      ":msg_type" := msgType,
-      ":msg_flags" := msgFlags,
-      ":msg_body" := msgBody
-    ]
+    (connId, internalId, internalTs, Nothing :: Maybe Int64, internalSndId, msgType, msgFlags, msgBody, pqEncryption)
 
 insertSndMsgDetails_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
 insertSndMsgDetails_ dbConn connId SndMsgData {..} =
@@ -2263,38 +2270,67 @@ getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do
     DB.query db "SELECT xftp_server_id FROM xftp_servers WHERE xftp_host = ? AND xftp_port = ? AND xftp_key_hash = ?" (host, port, keyHash)
 
 createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> IO (Either StoreError RcvFileId)
-createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath (CryptoFile savePath cfArgs) = runExceptT $ do
-  (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile fd
+createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file = runExceptT $ do
+  (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile db gVar userId fd prefixPath tmpPath file Nothing Nothing
   liftIO $
     forM_ chunks $ \fc@FileChunk {replicas} -> do
-      chunkId <- insertChunk fc rcvFileId
-      forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertReplica rno replica chunkId
+      chunkId <- insertRcvFileChunk db fc rcvFileId
+      forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId
   pure rcvFileEntityId
+
+createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> IO (Either StoreError RcvFileId)
+createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect"
+createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile = runExceptT $ do
+  (dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing
+  (_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId)
+  liftIO $
+    forM_ redirectChunks $ \fc@FileChunk {replicas} -> do
+      chunkId <- insertRcvFileChunk db fc redirectId
+      forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId
+  pure dstEntityId
   where
-    insertRcvFile :: FileDescription 'FRecipient -> IO (Either StoreError (RcvFileId, DBRcvFileId))
-    insertRcvFile FileDescription {size, digest, key, nonce, chunkSize} = runExceptT $ do
-      rcvFileEntityId <- ExceptT $
-        createWithRandomId gVar $ \rcvFileEntityId ->
-          DB.execute
-            db
-            "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
-            ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize) :. (prefixPath, tmpPath, savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving))
-      rcvFileId <- liftIO $ insertedRowId db
-      pure (rcvFileEntityId, rcvFileId)
-    insertChunk :: FileChunk -> DBRcvFileId -> IO Int64
-    insertChunk FileChunk {chunkNo, chunkSize, digest} rcvFileId = do
+    dummyDst =
+      FileDescription
+        { party = SFRecipient,
+          size,
+          digest,
+          redirect = Nothing,
+          -- updated later with updateRcvFileRedirect
+          key = C.unsafeSbKey $ B.replicate 32 '#',
+          nonce = C.cbNonce "",
+          chunkSize = FileSize 0,
+          chunks = []
+        }
+
+insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> IO (Either StoreError (RcvFileId, DBRcvFileId))
+insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ = runExceptT $ do
+  let (redirectDigest_, redirectSize_) = case redirect of
+        Just RedirectFileInfo {digest = d, size = s} -> (Just d, Just s)
+        Nothing -> (Nothing, Nothing)
+  rcvFileEntityId <- ExceptT $
+    createWithRandomId gVar $ \rcvFileEntityId ->
       DB.execute
         db
-        "INSERT INTO rcv_file_chunks (rcv_file_id, chunk_no, chunk_size, digest) VALUES (?,?,?,?)"
-        (rcvFileId, chunkNo, chunkSize, digest)
-      insertedRowId db
-    insertReplica :: Int -> FileChunkReplica -> Int64 -> IO ()
-    insertReplica replicaNo FileChunkReplica {server, replicaId, replicaKey} chunkId = do
-      srvId <- createXFTPServer_ db server
-      DB.execute
-        db
-        "INSERT INTO rcv_file_chunk_replicas (replica_number, rcv_file_chunk_id, xftp_server_id, replica_id, replica_key) VALUES (?,?,?,?,?)"
-        (replicaNo, chunkId, srvId, replicaId, replicaKey)
+        "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
+        ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_))
+  rcvFileId <- liftIO $ insertedRowId db
+  pure (rcvFileEntityId, rcvFileId)
+
+insertRcvFileChunk :: DB.Connection -> FileChunk -> DBRcvFileId -> IO Int64
+insertRcvFileChunk db FileChunk {chunkNo, chunkSize, digest} rcvFileId = do
+  DB.execute
+    db
+    "INSERT INTO rcv_file_chunks (rcv_file_id, chunk_no, chunk_size, digest) VALUES (?,?,?,?)"
+    (rcvFileId, chunkNo, chunkSize, digest)
+  insertedRowId db
+
+insertRcvFileChunkReplica :: DB.Connection -> Int -> FileChunkReplica -> Int64 -> IO ()
+insertRcvFileChunkReplica db replicaNo FileChunkReplica {server, replicaId, replicaKey} chunkId = do
+  srvId <- createXFTPServer_ db server
+  DB.execute
+    db
+    "INSERT INTO rcv_file_chunk_replicas (replica_number, rcv_file_chunk_id, xftp_server_id, replica_id, replica_key) VALUES (?,?,?,?,?)"
+    (replicaNo, chunkId, srvId, replicaId, replicaKey)
 
 getRcvFileByEntityId :: DB.Connection -> RcvFileId -> IO (Either StoreError RcvFile)
 getRcvFileByEntityId db rcvFileEntityId = runExceptT $ do
@@ -2306,6 +2342,11 @@ getRcvFileIdByEntityId_ db rcvFileEntityId =
   firstRow fromOnly SEFileNotFound $
     DB.query db "SELECT rcv_file_id FROM rcv_files WHERE rcv_file_entity_id = ?" (Only rcvFileEntityId)
 
+getRcvFileRedirects :: DB.Connection -> DBRcvFileId -> IO [RcvFile]
+getRcvFileRedirects db rcvFileId = do
+  redirects <- fromOnly <$$> DB.query db "SELECT rcv_file_id FROM rcv_files WHERE redirect_id = ?" (Only rcvFileId)
+  fmap catMaybes . forM redirects $ getRcvFile db >=> either (const $ pure Nothing) (pure . Just)
+
 getRcvFile :: DB.Connection -> DBRcvFileId -> IO (Either StoreError RcvFile)
 getRcvFile db rcvFileId = runExceptT $ do
   f@RcvFile {rcvFileEntityId, userId, tmpPath} <- ExceptT getFile
@@ -2318,17 +2359,22 @@ getRcvFile db rcvFileId = runExceptT $ do
         DB.query
           db
           [sql|
-            SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, deleted
+            SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, deleted, redirect_id, redirect_entity_id, redirect_size, redirect_digest
             FROM rcv_files
             WHERE rcv_file_id = ?
           |]
           (Only rcvFileId)
       where
-        toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, Maybe FilePath) :. (FilePath, Maybe C.SbKey, Maybe C.CbNonce, RcvFileStatus, Bool) -> RcvFile
-        toFile ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, saveKey_, saveNonce_, status, deleted)) =
+        toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, Maybe FilePath) :. (FilePath, Maybe C.SbKey, Maybe C.CbNonce, RcvFileStatus, Bool, Maybe DBRcvFileId, Maybe RcvFileId, Maybe (FileSize Int64), Maybe FileDigest) -> RcvFile
+        toFile ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, saveKey_, saveNonce_, status, deleted, redirectDbId, redirectEntityId, redirectSize_, redirectDigest_)) =
           let cfArgs = CFArgs <$> saveKey_ <*> saveNonce_
               saveFile = CryptoFile savePath cfArgs
-           in RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath, saveFile, status, deleted, chunks = []}
+              redirect =
+                RcvFileRedirect
+                  <$> redirectDbId
+                  <*> redirectEntityId
+                  <*> (RedirectFileInfo <$> redirectSize_ <*> redirectDigest_)
+           in RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, redirect, prefixPath, tmpPath, saveFile, status, deleted, chunks = []}
     getChunks :: RcvFileId -> UserId -> FilePath -> IO [RcvFileChunk]
     getChunks rcvFileEntityId userId fileTmpPath = do
       chunks <-
@@ -2363,7 +2409,7 @@ getRcvFile db rcvFileId = runExceptT $ do
           |]
           (Only chunkId)
       where
-        toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica
+        toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica
         toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries, host, port, keyHash) =
           let server = XFTPServer host port keyHash
            in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}
@@ -2394,6 +2440,14 @@ updateRcvFileComplete db rcvFileId = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE rcv_files SET tmp_path = NULL, status = ?, updated_at = ? WHERE rcv_file_id = ?" (RFSComplete, updatedAt, rcvFileId)
 
+updateRcvFileRedirect :: DB.Connection -> DBRcvFileId -> FileDescription 'FRecipient -> IO (Either StoreError ())
+updateRcvFileRedirect db rcvFileId FileDescription {key, nonce, chunkSize, chunks} = runExceptT $ do
+  updatedAt <- liftIO getCurrentTime
+  liftIO $ DB.execute db "UPDATE rcv_files SET key = ?, nonce = ?, chunk_size = ?, updated_at = ? WHERE rcv_file_id = ?" (key, nonce, chunkSize, updatedAt, rcvFileId)
+  liftIO $ forM_ chunks $ \fc@FileChunk {replicas} -> do
+    chunkId <- insertRcvFileChunk db fc rcvFileId
+    forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId
+
 updateRcvFileNoTmpPath :: DB.Connection -> DBRcvFileId -> IO ()
 updateRcvFileNoTmpPath db rcvFileId = do
   updatedAt <- getCurrentTime
@@ -2449,7 +2503,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
           |]
           (Only rcvFileChunkReplicaId)
       where
-        toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int64, Int)) -> RcvFileChunk
+        toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int)) -> RcvFileChunk
         toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries)) =
           RcvFileChunk
             { rcvFileId,
@@ -2541,13 +2595,18 @@ getRcvFilesExpired db ttl = do
     |]
     (Only cutoffTs)
 
-createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> IO (Either StoreError SndFileId)
-createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce =
+createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId)
+createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ =
   createWithRandomId gVar $ \sndFileEntityId ->
     DB.execute
       db
-      "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status) VALUES (?,?,?,?,?,?,?,?,?,?)"
-      (sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients, prefixPath, key, nonce, SFSNew)
+      "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
+      ((sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_))
+  where
+    (redirectSize_, redirectDigest_) =
+      case redirect_ of
+        Nothing -> (Nothing, Nothing)
+        Just RedirectFileInfo {size, digest} -> (Just size, Just digest)
 
 getSndFileByEntityId :: DB.Connection -> SndFileId -> IO (Either StoreError SndFile)
 getSndFileByEntityId db sndFileEntityId = runExceptT $ do
@@ -2571,17 +2630,18 @@ getSndFile db sndFileId = runExceptT $ do
         DB.query
           db
           [sql|
-            SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted
+            SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest
             FROM snd_files
             WHERE snd_file_id = ?
           |]
           (Only sndFileId)
       where
-        toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce, SndFileStatus, Bool) -> SndFile
-        toFile (sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce, status, deleted) =
+        toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, Bool, Maybe (FileSize Int64), Maybe FileDigest) -> SndFile
+        toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, deleted, redirectSize_, redirectDigest_)) =
           let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_
               srcFile = CryptoFile srcPath cfArgs
-           in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, chunks = []}
+              redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_
+           in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, chunks = []}
     getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk]
     getChunks sndFileEntityId userId numRecipients filePrefixPath = do
       chunks <-
@@ -2621,12 +2681,12 @@ getSndFile db sndFileId = runExceptT $ do
         rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId
         pure (replica :: SndFileChunkReplica) {rcvIdsKeys}
       where
-        toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica
+        toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica
         toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, host, port, keyHash) =
           let server = XFTPServer host port keyHash
            in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}
 
-getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateSignKey)]
+getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateAuthKey)]
 getChunkReplicaRecipients_ db replicaId =
   DB.query
     db
@@ -2774,7 +2834,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
           pure (replica :: SndFileChunkReplica) {rcvIdsKeys}
         pure (chunk {replicas = replicas'} :: SndFileChunk)
       where
-        toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateSignKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk
+        toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk
         toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) =
           let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize}
            in SndFileChunk
@@ -2795,7 +2855,7 @@ updateSndChunkReplicaDelay db replicaId delay = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE snd_file_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE snd_file_chunk_replica_id = ?" (delay, updatedAt, replicaId)
 
-addSndChunkReplicaRecipients :: DB.Connection -> SndFileChunkReplica -> [(ChunkReplicaId, C.APrivateSignKey)] -> IO SndFileChunkReplica
+addSndChunkReplicaRecipients :: DB.Connection -> SndFileChunkReplica -> [(ChunkReplicaId, C.APrivateAuthKey)] -> IO SndFileChunkReplica
 addSndChunkReplicaRecipients db r@SndFileChunkReplica {sndChunkReplicaId} rcvIdsKeys = do
   forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do
     DB.execute
@@ -2888,7 +2948,7 @@ getDeletedSndChunkReplica db deletedSndChunkReplicaId =
       |]
       (Only deletedSndChunkReplicaId)
   where
-    toReplica :: (UserId, ChunkReplicaId, C.APrivateSignKey, FileDigest, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> DeletedSndChunkReplica
+    toReplica :: (UserId, ChunkReplicaId, C.APrivateAuthKey, FileDigest, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> DeletedSndChunkReplica
     toReplica (userId, replicaId, replicaKey, chunkDigest, delay, retries, host, port, keyHash) =
       let server = XFTPServer host port keyHash
        in DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, replicaId, replicaKey, chunkDigest, delay, retries}

src/Simplex/Messaging/Agent/Store/SQLite/Common.hs

@@ -71,7 +71,8 @@ dbBusyLoop action = loop 500 3000000
     loop :: Int -> Int -> IO a
     loop t tLim =
       action `E.catch` \(e :: SQLError) ->
-        if tLim > t && SQL.sqlError e == SQL.ErrorBusy
+        let se = SQL.sqlError e in
+        if tLim > t && (se == SQL.ErrorBusy || se == SQL.ErrorLocked)
           then do
             threadDelay t
             loop (t * 9 `div` 8) (tLim - t)

src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs

@@ -68,6 +68,9 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
+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.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -104,7 +107,10 @@ schemaMigrations =
     ("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files),
     ("m20231222_command_created_at", m20231222_command_created_at, Just down_m20231222_command_created_at),
     ("m20231225_failed_work_items", m20231225_failed_work_items, Just down_m20231225_failed_work_items),
-    ("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes)
+    ("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes),
+    ("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)
   ]
 
 -- | The list of migrations in ascending order by date

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240124_file_redirect.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20240124_file_redirect :: Query
+m20240124_file_redirect =
+    [sql|
+ALTER TABLE snd_files ADD COLUMN redirect_size INTEGER;
+ALTER TABLE snd_files ADD COLUMN redirect_digest BLOB;
+
+ALTER TABLE rcv_files ADD COLUMN redirect_id INTEGER REFERENCES rcv_files ON DELETE SET NULL;
+ALTER TABLE rcv_files ADD COLUMN redirect_entity_id BLOB;
+ALTER TABLE rcv_files ADD COLUMN redirect_size INTEGER;
+ALTER TABLE rcv_files ADD COLUMN redirect_digest BLOB;
+
+CREATE INDEX idx_rcv_files_redirect_id on rcv_files(redirect_id);
+|]
+
+down_m20240124_file_redirect :: Query
+down_m20240124_file_redirect =
+    [sql|
+DROP INDEX idx_rcv_files_redirect_id;
+
+ALTER TABLE snd_files DROP COLUMN redirect_size;
+ALTER TABLE snd_files DROP COLUMN redirect_digest;
+
+ALTER TABLE rcv_files DROP COLUMN redirect_id;
+ALTER TABLE rcv_files DROP COLUMN redirect_entity_id;
+ALTER TABLE rcv_files DROP COLUMN redirect_size;
+ALTER TABLE rcv_files DROP COLUMN redirect_digest;
+|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240223_connections_wait_delivery.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20240223_connections_wait_delivery :: Query
+m20240223_connections_wait_delivery =
+  [sql|
+ALTER TABLE connections ADD COLUMN deleted_at_wait_delivery TEXT;
+|]
+
+down_m20240223_connections_wait_delivery :: Query
+down_m20240223_connections_wait_delivery =
+  [sql|
+ALTER TABLE connections DROP COLUMN deleted_at_wait_delivery;
+|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240225_ratchet_kem.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20240225_ratchet_kem :: Query
+m20240225_ratchet_kem =
+    [sql|
+ALTER TABLE ratchets ADD COLUMN pq_priv_kem BLOB;
+ALTER TABLE connections ADD COLUMN pq_support INTEGER NOT NULL DEFAULT 0;
+ALTER TABLE messages ADD COLUMN pq_encryption INTEGER NOT NULL DEFAULT 0;
+|]
+
+down_m20240225_ratchet_kem :: Query
+down_m20240225_ratchet_kem =
+    [sql|
+ALTER TABLE ratchets DROP COLUMN pq_priv_kem;
+ALTER TABLE connections DROP COLUMN pq_support;
+ALTER TABLE messages DROP COLUMN pq_encryption;
+|]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql

@@ -26,7 +26,9 @@ CREATE TABLE connections(
   deleted INTEGER DEFAULT 0 CHECK(deleted NOT NULL),
   user_id INTEGER CHECK(user_id NOT NULL)
   REFERENCES users ON DELETE CASCADE,
-  ratchet_sync_state TEXT NOT NULL DEFAULT 'ok'
+  ratchet_sync_state TEXT NOT NULL DEFAULT 'ok',
+  deleted_at_wait_delivery TEXT,
+  pq_support INTEGER NOT NULL DEFAULT 0
 ) WITHOUT ROWID;
 CREATE TABLE rcv_queues(
   host TEXT NOT NULL,
@@ -89,6 +91,7 @@ CREATE TABLE messages(
   msg_type BLOB NOT NULL, --(H)ELLO,(R)EPLY,(D)ELETE. Should SMP confirmation be saved too?
   msg_body BLOB NOT NULL DEFAULT x'',
   msg_flags TEXT NULL,
+  pq_encryption INTEGER NOT NULL DEFAULT 0,
   PRIMARY KEY(conn_id, internal_id),
   FOREIGN KEY(conn_id, internal_rcv_id) REFERENCES rcv_messages
   ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED,
@@ -159,7 +162,8 @@ CREATE TABLE ratchets(
   e2e_version INTEGER NOT NULL DEFAULT 1
   ,
   x3dh_pub_key_1 BLOB,
-  x3dh_pub_key_2 BLOB
+  x3dh_pub_key_2 BLOB,
+  pq_priv_kem BLOB
 ) WITHOUT ROWID;
 CREATE TABLE skipped_messages(
   skipped_message_id INTEGER PRIMARY KEY,
@@ -279,6 +283,10 @@ CREATE TABLE rcv_files(
   save_file_key BLOB,
   save_file_nonce BLOB,
   failed INTEGER DEFAULT 0,
+  redirect_id INTEGER REFERENCES rcv_files ON DELETE SET NULL,
+  redirect_entity_id BLOB,
+  redirect_size INTEGER,
+  redirect_digest BLOB,
   UNIQUE(rcv_file_entity_id)
 );
 CREATE TABLE rcv_file_chunks(
@@ -322,7 +330,9 @@ CREATE TABLE snd_files(
   ,
   src_file_key BLOB,
   src_file_nonce BLOB,
-  failed INTEGER DEFAULT 0
+  failed INTEGER DEFAULT 0,
+  redirect_size INTEGER,
+  redirect_digest BLOB
 );
 CREATE TABLE snd_file_chunks(
   snd_file_chunk_id INTEGER PRIMARY KEY,
@@ -508,3 +518,4 @@ CREATE INDEX idx_snd_message_deliveries_expired ON snd_message_deliveries(
   failed,
   internal_id
 );
+CREATE INDEX idx_rcv_files_redirect_id on rcv_files(redirect_id);

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -1,11 +1,13 @@
+{-# LANGUAGE LambdaCase #-}
+
 module Simplex.Messaging.Agent.TRcvQueues
-  ( TRcvQueues (getRcvQueues),
+  ( TRcvQueues (getRcvQueues, getConnections),
     empty,
     clear,
     deleteConn,
     hasConn,
-    getConns,
     addQueue,
+    batchAddQueues,
     deleteQueue,
     getSessQueues,
     getDelSessQueues,
@@ -14,49 +16,85 @@ module Simplex.Messaging.Agent.TRcvQueues
 where
 
 import Control.Concurrent.STM
+import Data.Foldable (foldl')
+import Data.List.NonEmpty (NonEmpty (..), (<|))
+import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
-import Data.Set (Set)
-import qualified Data.Set as S
 import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
 import Simplex.Messaging.Agent.Store (RcvQueue, StoredRcvQueue (..))
 import Simplex.Messaging.Protocol (RecipientId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 
-newtype TRcvQueues = TRcvQueues {getRcvQueues :: TMap (UserId, SMPServer, RecipientId) RcvQueue}
+-- the fields in this record have the same data with swapped keys for lookup efficiency,
+-- and all methods must maintain this invariant.
+data TRcvQueues = TRcvQueues
+  { getRcvQueues :: TMap (UserId, SMPServer, RecipientId) RcvQueue,
+    getConnections :: TMap ConnId (NonEmpty (UserId, SMPServer, RecipientId))
+  }
 
 empty :: STM TRcvQueues
-empty = TRcvQueues <$> TM.empty
+empty = TRcvQueues <$> TM.empty <*> TM.empty
 
 clear :: TRcvQueues -> STM ()
-clear (TRcvQueues qs) = TM.clear qs
+clear (TRcvQueues qs cs) = TM.clear qs >> TM.clear cs
 
 deleteConn :: ConnId -> TRcvQueues -> STM ()
-deleteConn cId (TRcvQueues qs) = modifyTVar' qs $ M.filter (\rq -> cId /= connId rq)
+deleteConn cId (TRcvQueues qs cs) =
+  TM.lookupDelete cId cs >>= \case
+    Just ks -> modifyTVar' qs $ \qs' -> foldl' (flip M.delete) qs' ks
+    Nothing -> pure ()
 
 hasConn :: ConnId -> TRcvQueues -> STM Bool
-hasConn cId (TRcvQueues qs) = any (\rq -> cId == connId rq) <$> readTVar qs
-
-getConns :: TRcvQueues -> STM (Set ConnId)
-getConns (TRcvQueues qs) = M.foldr' (S.insert . connId) S.empty <$> readTVar qs
+hasConn cId (TRcvQueues _ cs) = TM.member cId cs
 
 addQueue :: RcvQueue -> TRcvQueues -> STM ()
-addQueue rq (TRcvQueues qs) = TM.insert (qKey rq) rq qs
+addQueue rq (TRcvQueues qs cs) = do
+  TM.insert k rq qs
+  TM.alter addQ (connId rq) cs
+  where
+    addQ = Just . maybe (k :| []) (k <|)
+    k = qKey rq
+
+-- Save time by aggregating modifyTVar
+batchAddQueues :: Foldable t => TRcvQueues -> t RcvQueue -> STM ()
+batchAddQueues (TRcvQueues qs cs) rqs = do
+  modifyTVar' qs $ \now -> foldl' (\rqs' rq -> M.insert (qKey rq) rq rqs') now rqs
+  modifyTVar' cs $ \now -> foldl' (\cs' rq -> M.alter (addQ $ qKey rq) (connId rq) cs') now rqs
+  where
+    addQ k = Just . maybe (k :| []) (k <|)
 
 deleteQueue :: RcvQueue -> TRcvQueues -> STM ()
-deleteQueue rq (TRcvQueues qs) = TM.delete (qKey rq) qs
+deleteQueue rq (TRcvQueues qs cs) = do
+  TM.delete k qs
+  TM.update delQ (connId rq) cs
+  where
+    delQ = L.nonEmpty . L.filter (/= k)
+    k = qKey rq
 
 getSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM [RcvQueue]
-getSessQueues tSess (TRcvQueues qs) = M.foldl' addQ [] <$> readTVar qs
+getSessQueues tSess (TRcvQueues qs _) = M.foldl' addQ [] <$> readTVar qs
   where
     addQ qs' rq = if rq `isSession` tSess then rq : qs' else qs'
 
-getDelSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM [RcvQueue]
-getDelSessQueues tSess (TRcvQueues qs) = stateTVar qs $ M.foldl' addQ ([], M.empty)
+getDelSessQueues :: (UserId, SMPServer, Maybe ConnId) -> TRcvQueues -> STM ([RcvQueue], [ConnId])
+getDelSessQueues tSess (TRcvQueues qs cs) = do
+  (removedQs, qs'') <- (\qs' -> M.foldl' delQ ([], qs') qs') <$> readTVar qs
+  writeTVar qs $! qs''
+  removedConns <- stateTVar cs $ \cs' -> foldl' delConn ([], cs') removedQs
+  pure (removedQs, removedConns)
   where
-    addQ (removed, qs') rq
-      | rq `isSession` tSess = (rq : removed, qs')
-      | otherwise = (removed, M.insert (qKey rq) rq qs')
+    delQ acc@(removed, qs') rq
+      | rq `isSession` tSess = (rq : removed, M.delete (qKey rq) qs')
+      | otherwise = acc
+    delConn (removed, cs') rq = M.alterF f cId cs'
+      where
+        cId = connId rq
+        f = \case
+          Just ks -> case L.nonEmpty $ L.filter (qKey rq /=) ks of
+            Just ks' -> (removed, Just ks')
+            Nothing -> (cId : removed, Nothing)
+          Nothing -> (removed, Nothing) -- "impossible" in invariant holds, because we get keys from the known queues
 
 isSession :: RcvQueue -> (UserId, SMPServer, Maybe ConnId) -> Bool
 isSession rq (uId, srv, connId_) =

src/Simplex/Messaging/Client.hs

@@ -28,7 +28,7 @@
 module Simplex.Messaging.Client
   ( -- * Connect (disconnect) client to (from) SMP server
     TransportSession,
-    ProtocolClient (thVersion, sessionId, sessionTs),
+    ProtocolClient (thParams, sessionTs),
     SMPClient,
     getProtocolClient,
     closeProtocolClient,
@@ -63,6 +63,7 @@ module Simplex.Messaging.Client
     NetworkConfig (..),
     TransportSessionMode (..),
     defaultClientConfig,
+    defaultSMPClientConfig,
     defaultNetworkConfig,
     transportClientConfig,
     chooseTransportHost,
@@ -74,7 +75,8 @@ module Simplex.Messaging.Client
     -- * For testing
     PCTransmission,
     mkTransmission,
-    clientStub,
+    authTransmission,
+    smpClientStub,
   )
 where
 
@@ -83,7 +85,9 @@ import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Except
 import Control.Monad.Trans.Except
+import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson.TH as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -113,47 +117,47 @@ 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 err msg = ProtocolClient
+data ProtocolClient v err msg = ProtocolClient
   { action :: Maybe (Async ()),
-    sessionId :: SessionId,
+    thParams :: THandleParams v,
     sessionTs :: UTCTime,
-    thVersion :: Version,
-    timeoutPerBlock :: Int,
-    blockSize :: Int,
-    batch :: Bool,
-    client_ :: PClient err msg
+    client_ :: PClient v err msg
   }
 
-data PClient err msg = PClient
+data PClient v err msg = PClient
   { connected :: TVar Bool,
     transportSession :: TransportSession msg,
     transportHost :: TransportHost,
     tcpTimeout :: Int,
     batchDelay :: Maybe Int,
     pingErrorCount :: TVar Int,
-    clientCorrId :: TVar Natural,
+    clientCorrId :: TVar ChaChaDRG,
     sentCommands :: TMap CorrId (Request err msg),
     sndQ :: TBQueue ByteString,
     rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
-    msgQ :: Maybe (TBQueue (ServerTransmission msg))
+    msgQ :: Maybe (TBQueue (ServerTransmission v msg))
   }
 
-clientStub :: ByteString -> STM (ProtocolClient err msg)
-clientStub sessionId = do
+smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe THandleAuth -> STM (ProtocolClient SMPVersion err msg)
+smpClientStub g sessionId thVersion thAuth = do
   connected <- newTVar False
-  clientCorrId <- newTVar 0
+  clientCorrId <- C.newRandomDRG g
   sentCommands <- TM.empty
   sndQ <- newTBQueue 100
   rcvQ <- newTBQueue 100
   return
     ProtocolClient
       { action = Nothing,
-        sessionId,
+        thParams =
+          THandleParams
+            { sessionId,
+              thVersion,
+              thAuth,
+              blockSize = smpBlockSize,
+              implySessId = thVersion >= authCmdsSMPVersion,
+              batch = True
+            },
         sessionTs = undefined,
-        thVersion = 5,
-        timeoutPerBlock = undefined,
-        blockSize = smpBlockSize,
-        batch = undefined,
         client_ =
           PClient
             { connected,
@@ -170,13 +174,13 @@ clientStub sessionId = do
             }
       }
 
-type SMPClient = ProtocolClient ErrorType BrokerMsg
+type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg
 
 -- | Type for client command data
-type ClientCommand msg = (Maybe C.APrivateSignKey, EntityId, ProtoCommand msg)
+type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg)
 
 -- | Type synonym for transmission from some SPM server queue.
-type ServerTransmission msg = (TransportSession msg, Version, SessionId, EntityId, msg)
+type ServerTransmission v msg = (TransportSession msg, Version v, SessionId, EntityId, msg)
 
 data HostMode
   = -- | prefer (or require) onion hosts when connecting via SOCKS proxy
@@ -237,7 +241,7 @@ transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
   TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing}
 
 -- | protocol client configuration.
-data ProtocolClientConfig = ProtocolClientConfig
+data ProtocolClientConfig v = ProtocolClientConfig
   { -- | size of TBQueue to use for server commands and responses
     qSize :: Natural,
     -- | default server port if port is not specified in ProtocolServer
@@ -245,22 +249,25 @@ data ProtocolClientConfig = ProtocolClientConfig
     -- | network configuration
     networkConfig :: NetworkConfig,
     -- | client-server protocol version range
-    serverVRange :: VersionRange,
+    serverVRange :: VersionRange v,
     -- | delay between sending batches of commands (microseconds)
     batchDelay :: Maybe Int
   }
 
 -- | Default protocol client configuration.
-defaultClientConfig :: ProtocolClientConfig
-defaultClientConfig =
+defaultClientConfig :: VersionRange v -> ProtocolClientConfig v
+defaultClientConfig serverVRange =
   ProtocolClientConfig
     { qSize = 64,
       defaultTransport = ("443", transport @TLS),
       networkConfig = defaultNetworkConfig,
-      serverVRange = supportedSMPServerVRange,
+      serverVRange,
       batchDelay = Nothing
     }
 
+defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
+defaultSMPClientConfig = defaultClientConfig supportedClientSMPRelayVRange
+
 data Request err msg = Request
   { entityId :: EntityId,
     responseVar :: TMVar (Either (ProtocolClientError err) msg)
@@ -285,15 +292,15 @@ chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts
     onionHost = find isOnionHost hosts
     publicHost = find (not . isOnionHost) hosts
 
-protocolClientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient err msg -> String
+protocolClientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient v err msg -> String
 protocolClientServer = B.unpack . strEncode . snd3 . transportSession . client_
   where
     snd3 (_, s, _) = s
 
-transportHost' :: ProtocolClient err msg -> TransportHost
+transportHost' :: ProtocolClient v err msg -> TransportHost
 transportHost' = transportHost . client_
 
-transportSession' :: ProtocolClient err msg -> TransportSession msg
+transportSession' :: ProtocolClient v err msg -> TransportSession msg
 transportSession' = transportSession . client_
 
 type UserId = Int64
@@ -306,20 +313,20 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
 --
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
-getProtocolClient :: forall err msg. Protocol err msg => TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient err msg))
-getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, batchDelay} msgQ disconnected = do
+getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmission v msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
+getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, batchDelay} msgQ disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
       (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
         `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
     Left e -> pure $ Left e
   where
-    NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpTimeoutPerKb, smpPingInterval} = networkConfig
-    mkProtocolClient :: TransportHost -> STM (PClient err msg)
+    NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
+    mkProtocolClient :: TransportHost -> STM (PClient v err msg)
     mkProtocolClient transportHost = do
       connected <- newTVar False
       pingErrorCount <- newTVar 0
-      clientCorrId <- newTVar 0
+      clientCorrId <- C.newRandomDRG g
       sentCommands <- TM.empty
       sndQ <- newTBQueue qSize
       rcvQ <- newTBQueue qSize
@@ -338,7 +345,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
             msgQ
           }
 
-    runClient :: (ServiceName, ATransport) -> TransportHost -> PClient err msg -> IO (Either (ProtocolClientError err) (ProtocolClient err msg))
+    runClient :: (ServiceName, ATransport) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
     runClient (port', ATransport t) useHost c = do
       cVar <- newEmptyTMVarIO
       let tcConfig = transportClientConfig networkConfig
@@ -359,30 +366,30 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
       "80" -> ("80", transport @WS)
       p -> (p, transport @TLS)
 
-    client :: forall c. Transport c => TProxy c -> PClient err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient err msg)) -> c -> IO ()
-    client _ c cVar h =
-      runExceptT (protocolClientHandshake @err @msg h (keyHash srv) serverVRange) >>= \case
+    client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO ()
+    client _ c cVar h = do
+      ks <- atomically $ C.generateKeyPair g
+      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange) >>= \case
         Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
-        Right th@THandle {sessionId, thVersion, blockSize, batch} -> do
+        Right th@THandle {params} -> do
           sessionTs <- getCurrentTime
-          let timeoutPerBlock = (blockSize * tcpTimeoutPerKb) `div` 1024
-              c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs, timeoutPerBlock, blockSize, batch}
+          let c' = ProtocolClient {action = Nothing, client_ = c, thParams = params, sessionTs}
           atomically $ do
             writeTVar (connected c) True
             putTMVar cVar $ Right c'
           raceAny_ ([send c' th, process c', receive c' th] <> [ping c' | smpPingInterval > 0])
             `finally` disconnected c'
 
-    send :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
+    send :: Transport c => ProtocolClient v err msg -> THandle v c -> IO ()
     send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPutLog h
 
-    receive :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
+    receive :: Transport c => ProtocolClient v err msg -> THandle v c -> IO ()
     receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
 
-    ping :: ProtocolClient err msg -> IO ()
+    ping :: ProtocolClient v err msg -> IO ()
     ping c@ProtocolClient {client_ = PClient {pingErrorCount}} = do
       threadDelay' smpPingInterval
-      runExceptT (sendProtocolCommand c Nothing "" $ protocolPing @err @msg) >>= \case
+      runExceptT (sendProtocolCommand c Nothing "" $ protocolPing @v @err @msg) >>= \case
         Left PCEResponseTimeout -> do
           cnt <- atomically $ stateTVar pingErrorCount $ \cnt -> (cnt + 1, cnt + 1)
           when (maxCnt == 0 || cnt < maxCnt) $ ping c
@@ -390,10 +397,10 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
       where
         maxCnt = smpPingCount networkConfig
 
-    process :: ProtocolClient err msg -> IO ()
+    process :: ProtocolClient v err msg -> IO ()
     process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c)
 
-    processMsg :: ProtocolClient err msg -> SignedTransmission err msg -> IO ()
+    processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO ()
     processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr)) =
       if B.null $ bs corrId
         then sendMsg respOrErr
@@ -421,7 +428,7 @@ proxyUsername :: TransportSession msg -> ByteString
 proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_
 
 -- | Disconnects client from the server and terminates client threads.
-closeProtocolClient :: ProtocolClient err msg -> IO ()
+closeProtocolClient :: ProtocolClient v err msg -> IO ()
 closeProtocolClient = mapM_ uninterruptibleCancel . action
 
 -- | SMP client error type.
@@ -468,13 +475,12 @@ temporaryClientError = \case
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
 createSMPQueue ::
   SMPClient ->
-  RcvPrivateSignKey ->
-  RcvPublicVerifyKey ->
+  C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair
   RcvPublicDhKey ->
   Maybe BasicAuth ->
   SubscriptionMode ->
   ExceptT SMPClientError IO QueueIdsKeys
-createSMPQueue c rpKey rKey dhKey auth subMode =
+createSMPQueue c (rKey, rpKey) dhKey auth subMode =
   sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode) >>= \case
     IDS qik -> pure qik
     r -> throwE . PCEUnexpectedResponse $ bshow r
@@ -482,7 +488,7 @@ createSMPQueue c rpKey rKey dhKey auth subMode =
 -- | Subscribe to the SMP queue.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
-subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
+subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
 subscribeSMPQueue c rpKey rId =
   sendSMPCommand c (Just rpKey) rId SUB >>= \case
     OK -> return ()
@@ -490,12 +496,12 @@ subscribeSMPQueue c rpKey rId =
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Subscribe to multiple SMP queues batching commands if supported.
-subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
+subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
 subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM (processSUBResponse c)
   where
     cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
 
-streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> ([(RecipientId, Either SMPClientError ())] -> IO ()) -> IO ()
+streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> ([(RecipientId, Either SMPClientError ())] -> IO ()) -> IO ()
 streamSubscribeSMPQueues c qs cb = streamProtocolCommands c cs $ mapM process >=> cb
   where
     cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
@@ -511,14 +517,14 @@ processSUBResponse c (Response rId r) = case r of
 writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
 writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c)
 
-serverTransmission :: ProtocolClient err msg -> RecipientId -> msg -> ServerTransmission msg
-serverTransmission ProtocolClient {thVersion, sessionId, client_ = PClient {transportSession}} entityId message =
+serverTransmission :: ProtocolClient v err msg -> RecipientId -> msg -> ServerTransmission v msg
+serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} entityId message =
   (transportSession, thVersion, sessionId, entityId, message)
 
 -- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
 --
 -- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
-getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage)
+getSMPMessage :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage)
 getSMPMessage c rpKey rId =
   sendSMPCommand c (Just rpKey) rId GET >>= \case
     OK -> pure Nothing
@@ -528,30 +534,30 @@ getSMPMessage c rpKey rId =
 -- | Subscribe to the SMP queue notifications.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
-subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()
+subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO ()
 subscribeSMPQueueNotifications = okSMPCommand NSUB
 
 -- | Subscribe to multiple SMP queues notifications batching commands if supported.
-subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateSignKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
+subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateAuthKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
 subscribeSMPQueuesNtfs = okSMPCommands NSUB
 
 -- | Secure the SMP queue by adding a sender public key.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
-secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO ()
+secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
 secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
 
 -- | Enable notifications for the queue for push notifications server.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
-enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey)
+enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey)
 enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
   sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
     NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
 -- | Enable notifications for the multiple queues for push notifications server.
-enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
+enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
 enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
   where
     cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
@@ -563,17 +569,17 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
 -- | Disable notifications for the queue for push notifications server.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
-disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
+disableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
 disableSMPQueueNotifications = okSMPCommand NDEL
 
 -- | Disable notifications for multiple queues for push notifications server.
-disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
+disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
 disableSMPQueuesNtfs = okSMPCommands NDEL
 
 -- | Send SMP message.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
-sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
+sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
 sendSMPMessage c spKey sId flags msg =
   sendSMPCommand c spKey sId (SEND flags msg) >>= \case
     OK -> pure ()
@@ -582,7 +588,7 @@ sendSMPMessage c spKey sId flags msg =
 -- | Acknowledge message delivery (server deletes the message).
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
-ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT SMPClientError IO ()
+ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO ()
 ackSMPMessage c rpKey rId msgId =
   sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
     OK -> return ()
@@ -593,26 +599,26 @@ ackSMPMessage c rpKey rId msgId =
 -- The existing messages from the queue will still be delivered.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
-suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
+suspendSMPQueue :: SMPClient -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
 suspendSMPQueue = okSMPCommand OFF
 
 -- | Irreversibly delete SMP queue and all messages in it.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
-deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
+deleteSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
 deleteSMPQueue = okSMPCommand DEL
 
 -- | Delete multiple SMP queues batching commands if supported.
-deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
+deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
 deleteSMPQueues = okSMPCommands DEL
 
-okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
+okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
 okSMPCommand cmd c pKey qId =
   sendSMPCommand c (Just pKey) qId cmd >>= \case
     OK -> return ()
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateSignKey, QueueId) -> IO (NonEmpty (Either SMPClientError ()))
+okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateAuthKey, QueueId) -> IO (NonEmpty (Either SMPClientError ()))
 okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
   where
     aCmd = Cmd sParty cmd
@@ -623,14 +629,14 @@ okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
       Left e -> Left e
 
 -- | Send SMP command
-sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
+sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
 sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
 
-type PCTransmission err msg = (SentRawTransmission, Request err msg)
+type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg)
 
 -- | Send multiple commands with batching and collect responses
-sendProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
-sendProtocolCommands c@ProtocolClient {batch, blockSize} cs = do
+sendProtocolCommands :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
+sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do
   bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
   validate . concat =<< mapM (sendBatch c) bs
   where
@@ -646,17 +652,17 @@ sendProtocolCommands c@ProtocolClient {batch, blockSize} cs = do
       where
         diff = L.length cs - length rs
 
-streamProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
-streamProtocolCommands c@ProtocolClient {batch, blockSize} cs cb = do
+streamProtocolCommands :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
+streamProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs cb = do
   bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
   mapM_ (cb <=< sendBatch c) bs
 
-sendBatch :: ProtocolClient err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
+sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
 sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
   case b of
-    TBLargeTransmission Request {entityId} -> do
+    TBError e Request {entityId} -> do
       putStrLn "send error: large message"
-      pure [Response entityId $ Left $ PCETransportError TELargeMsg]
+      pure [Response entityId $ Left $ PCETransportError e]
     TBTransmissions s n rs
       | n > 0 -> do
           atomically $ writeTBQueue sndQ s
@@ -667,22 +673,24 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
       (: []) <$> getResponse c r
 
 -- | Send Protocol command
-sendProtocolCommand :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> Maybe C.APrivateSignKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
-sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, batch, blockSize} pKey entId cmd =
+sendProtocolCommand :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
+sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} pKey entId cmd =
   ExceptT $ uncurry sendRecv =<< mkTransmission c (pKey, entId, cmd)
   where
     -- two separate "atomically" needed to avoid blocking
-    sendRecv :: SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg)
-    sendRecv t r
-      | B.length s > blockSize - 2 = pure $ Left $ PCETransportError TELargeMsg
-      | otherwise = atomically (writeTBQueue sndQ s) >> response <$> getResponse c r
-      where
-        s
-          | batch = tEncodeBatch1 t
-          | otherwise = tEncode t
+    sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg)
+    sendRecv t_ r = case t_ of
+      Left e -> pure . Left $ PCETransportError e
+      Right t
+        | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg
+        | otherwise -> atomically (writeTBQueue sndQ s) >> response <$> getResponse c r
+        where
+          s
+            | batch = tEncodeBatch1 t
+            | otherwise = tEncode t
 
 -- TODO switch to timeout or TimeManager that supports Int64
-getResponse :: ProtocolClient err msg -> Request err msg -> IO (Response err msg)
+getResponse :: ProtocolClient v err msg -> Request err msg -> IO (Response err msg)
 getResponse ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} Request {entityId, responseVar} = do
   response <-
     timeout tcpTimeout (atomically (takeTMVar responseVar)) >>= \case
@@ -690,25 +698,35 @@ getResponse ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} Requ
       Nothing -> pure $ Left PCEResponseTimeout
   pure Response {entityId, response}
 
-mkTransmission :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> ClientCommand msg -> IO (PCTransmission err msg)
-mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCorrId, sentCommands}} (pKey, entId, cmd) = do
+mkTransmission :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg)
+mkTransmission ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} (pKey_, entId, cmd) = do
   corrId <- atomically getNextCorrId
-  let t = signTransmission $ encodeTransmission thVersion sessionId (corrId, entId, cmd)
+  let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, entId, cmd)
+      auth = authTransmission (thAuth thParams) pKey_ corrId tForAuth
   r <- atomically $ mkRequest corrId
-  pure (t, r)
+  pure ((,tToSend) <$> auth, r)
   where
     getNextCorrId :: STM CorrId
-    getNextCorrId = do
-      i <- stateTVar clientCorrId $ \i -> (i, i + 1)
-      pure . CorrId $ bshow i
-    signTransmission :: ByteString -> SentRawTransmission
-    signTransmission t = ((`C.sign` t) <$> pKey, t)
+    getNextCorrId = CorrId <$> C.randomBytes 24 clientCorrId -- also used as nonce
     mkRequest :: CorrId -> STM (Request err msg)
     mkRequest corrId = do
       r <- Request entId <$> newEmptyTMVar
       TM.insert corrId r sentCommands
       pure r
 
+authTransmission :: Maybe THandleAuth -> Maybe C.APrivateAuthKey -> CorrId -> ByteString -> Either TransportError (Maybe TransmissionAuth)
+authTransmission thAuth pKey_ (CorrId corrId) t = traverse authenticate pKey_
+  where
+    authenticate :: C.APrivateAuthKey -> Either TransportError TransmissionAuth
+    authenticate (C.APrivateAuthKey a pk) = case a of
+      C.SX25519 -> case thAuth of
+        Just THandleAuth {peerPubKey} -> Right $ TAAuthenticator $ C.cbAuthenticate peerPubKey pk (C.cbNonce corrId) t
+        Nothing -> Left TENoServerAuth
+      C.SEd25519 -> sign pk
+      C.SEd448 -> sign pk
+    sign :: forall a. (C.AlgorithmI a, C.SignatureAlgorithm a) => C.PrivateKey a -> Either TransportError TransmissionAuth
+    sign pk = Right $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t)
+
 $(J.deriveJSON (enumJSON $ dropPrefix "HM") ''HostMode)
 
 $(J.deriveJSON (enumJSON $ dropPrefix "TSM") ''TransportSessionMode)

src/Simplex/Messaging/Client/Agent.hs

@@ -18,6 +18,7 @@ import Control.Monad
 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.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -36,7 +37,7 @@ import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BrokerMsg, NotifierId, NtfPrivateSignKey, ProtocolServer (..), QueueId, RcvPrivateSignKey, RecipientId, SMPServer)
+import Simplex.Messaging.Protocol (BrokerMsg, NotifierId, NtfPrivateAuthKey, ProtocolServer (..), QueueId, RcvPrivateAuthKey, RecipientId, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
@@ -64,7 +65,7 @@ type SMPSub = (SMPSubParty, QueueId)
 -- type SMPServerSub = (SMPServer, SMPSub)
 
 data SMPClientAgentConfig = SMPClientAgentConfig
-  { smpCfg :: ProtocolClientConfig,
+  { smpCfg :: ProtocolClientConfig SMPVersion,
     reconnectInterval :: RetryInterval,
     msgQSize :: Natural,
     agentQSize :: Natural,
@@ -74,7 +75,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
 defaultSMPClientAgentConfig :: SMPClientAgentConfig
 defaultSMPClientAgentConfig =
   SMPClientAgentConfig
-    { smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
+    { smpCfg = defaultSMPClientConfig {defaultTransport = ("5223", transport @TLS)},
       reconnectInterval =
         RetryInterval
           { initialInterval = second,
@@ -90,11 +91,12 @@ defaultSMPClientAgentConfig =
 
 data SMPClientAgent = SMPClientAgent
   { agentCfg :: SMPClientAgentConfig,
-    msgQ :: TBQueue (ServerTransmission BrokerMsg),
+    msgQ :: TBQueue (ServerTransmission SMPVersion BrokerMsg),
     agentQ :: TBQueue SMPClientAgentEvent,
+    randomDrg :: TVar ChaChaDRG,
     smpClients :: TMap SMPServer SMPClientVar,
-    srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey),
-    pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey),
+    srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
+    pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
     reconnections :: TVar [Async ()],
     asyncClients :: TVar [Async ()]
   }
@@ -111,8 +113,8 @@ instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where
       withRunInIO $ \run ->
         exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT)
 
-newSMPClientAgent :: SMPClientAgentConfig -> STM SMPClientAgent
-newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do
+newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> STM SMPClientAgent
+newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
   msgQ <- newTBQueue msgQSize
   agentQ <- newTBQueue agentQSize
   smpClients <- TM.empty
@@ -120,10 +122,10 @@ newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do
   pendingSrvSubs <- TM.empty
   reconnections <- newTVar []
   asyncClients <- newTVar []
-  pure SMPClientAgent {agentCfg, msgQ, agentQ, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients}
+  pure SMPClientAgent {agentCfg, msgQ, agentQ, randomDrg, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients}
 
 getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient
-getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
+getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ, randomDrg} srv =
   atomically getClientVar >>= either newSMPClient waitForSMPClient
   where
     getClientVar :: STM (Either SMPClientVar SMPClientVar)
@@ -171,14 +173,14 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
             void $ tryConnectClient (const reconnectClient) loop
 
     connectClient :: ExceptT SMPClientError IO SMPClient
-    connectClient = ExceptT $ getProtocolClient (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected
+    connectClient = ExceptT $ getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected
 
     clientDisconnected :: SMPClient -> IO ()
     clientDisconnected _ = do
       removeClientAndSubs >>= (`forM_` serverDown)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
-    removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateSignKey))
+    removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateAuthKey))
     removeClientAndSubs = atomically $ do
       TM.delete srv smpClients
       TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs
@@ -194,7 +196,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
             Just v -> TM.union ss v
             _ -> TM.insert srv sVar ps
 
-    serverDown :: Map SMPSub C.APrivateSignKey -> IO ()
+    serverDown :: Map SMPSub C.APrivateAuthKey -> IO ()
     serverDown ss = unless (M.null ss) $ do
       notify . CADisconnected srv $ M.keysSet ss
       void $ runExceptT reconnectServer
@@ -224,15 +226,15 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
           SPNotifier -> True
           SPRecipient -> False
 
-        subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateSignKey)] -> ExceptT SMPClientError IO ()
+        subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateAuthKey)] -> ExceptT SMPClientError IO ()
         subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg)
           where
             subscribeBatch subs' = do
-              let subs'' :: (NonEmpty (QueueId, C.APrivateSignKey)) = L.map (first snd) subs'
+              let subs'' :: (NonEmpty (QueueId, C.APrivateAuthKey)) = L.map (first snd) subs'
               rs <- liftIO $ smpSubscribeQueues party ca smp srv subs''
-              let rs' :: (NonEmpty ((SMPSub, C.APrivateSignKey), Either SMPClientError ())) =
+              let rs' :: (NonEmpty ((SMPSub, C.APrivateAuthKey), Either SMPClientError ())) =
                     L.zipWith (first . const) subs' rs
-                  rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateSignKey)] =
+                  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
@@ -270,7 +272,7 @@ 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.APrivateSignKey) -> ExceptT SMPClientError IO ()
+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
@@ -284,20 +286,20 @@ subscribeQueue ca srv sub = do
         removePendingSubscription ca srv (fst sub)
       throwE e
 
-subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateSignKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ()))
+subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ()))
 subscribeQueuesSMP = subscribeQueues_ SPRecipient
 
-subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateSignKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ()))
+subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ()))
 subscribeQueuesNtfs = subscribeQueues_ SPNotifier
 
-subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
+subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
 subscribeQueues_ party ca srv subs = do
   atomically $ forM_ subs $ addPendingSubscription ca srv . first (party,)
   runExceptT (getSMPServerClient' ca srv) >>= \case
     Left e -> pure $ L.map ((,Left e) . fst) subs
     Right smp -> smpSubscribeQueues party ca smp srv subs
 
-smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
+smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
 smpSubscribeQueues party ca smp srv subs = do
   rs <- L.zip subs <$> subscribe smp (L.map swap subs)
   atomically $ forM rs $ \(sub, r) ->
@@ -318,22 +320,22 @@ showServer :: SMPServer -> ByteString
 showServer ProtocolServer {host, port} =
   strEncode host <> B.pack (if null port then "" else ':' : port)
 
-smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO ()
+smpSubscribe :: SMPClient -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO ()
 smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId
   where
     subscribe_ = case party of
       SPRecipient -> subscribeSMPQueue
       SPNotifier -> subscribeSMPQueueNotifications
 
-addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
+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.APrivateSignKey) -> STM ()
+addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM ()
 addPendingSubscription = addSub_ . pendingSrvSubs
 
-addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM ()
+addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM ()
 addSub_ subs srv (s, key) =
   TM.lookup srv subs >>= \case
     Just m -> TM.insert s key m
@@ -345,11 +347,11 @@ removeSubscription = removeSub_ . srvSubs
 removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM ()
 removePendingSubscription = removeSub_ . pendingSrvSubs
 
-removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM ()
+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.APrivateSignKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateSignKey)
+getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateAuthKey)
 getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s
 
-hasSub :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM Bool
+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

src/Simplex/Messaging/Compression.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Compression where
+
+import qualified Codec.Compression.Zstd as Z1
+import qualified Codec.Compression.Zstd.FFI as Z
+import Control.Monad (forM)
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as B
+import Data.Either (fromRight)
+import Data.List.NonEmpty (NonEmpty)
+import Foreign
+import Foreign.C.Types
+import GHC.IO (unsafePerformIO)
+import Simplex.Messaging.Encoding
+import UnliftIO.Exception (bracket)
+
+data Compressed
+  = -- | Short messages are left intact to skip copying and FFI festivities.
+    Passthrough ByteString
+  | -- | Generic compression using no extra context.
+    Compressed Large
+
+-- | Messages below this length are not encoded to avoid compression overhead.
+maxLengthPassthrough :: Int
+maxLengthPassthrough = 180 -- Sampled from real client data. Messages with length > 180 rapidly gain compression ratio.
+
+compressionLevel :: Num a => a
+compressionLevel = 3
+
+instance Encoding Compressed where
+  smpEncode = \case
+    Passthrough bytes -> "0" <> smpEncode bytes
+    Compressed bytes -> "1" <> smpEncode bytes
+  smpP =
+    smpP >>= \case
+      '0' -> Passthrough <$> smpP
+      '1' -> Compressed <$> smpP
+      x -> fail $ "unknown Compressed tag: " <> show x
+
+-- | Compress as single chunk using stack-allocated context.
+compress1 :: ByteString -> Compressed
+compress1 bs
+  | B.length bs <= maxLengthPassthrough = Passthrough bs
+  | otherwise = Compressed . Large $ Z1.compress compressionLevel bs
+
+type CompressCtx = (Ptr Z.CCtx, Ptr CChar, CSize)
+
+withCompressCtx :: CSize -> (CompressCtx -> IO a) -> IO a
+withCompressCtx scratchSize action =
+  bracket Z.createCCtx Z.freeCCtx $ \cctx ->
+    allocaBytes (fromIntegral scratchSize) $ \scratchPtr ->
+      action (cctx, scratchPtr, scratchSize)
+
+-- | Compress bytes, falling back to Passthrough in case of some internal error.
+compress :: CompressCtx -> ByteString -> IO Compressed
+compress ctx bs = fromRight (Passthrough bs) <$> compress_ ctx bs
+
+compress_ :: CompressCtx -> ByteString -> IO (Either String Compressed)
+compress_ (cctx, scratchPtr, scratchSize) bs
+  | B.length bs <= maxLengthPassthrough = pure . Right $ Passthrough bs
+  | otherwise =
+      B.unsafeUseAsCStringLen bs $ \(sourcePtr, sourceSize) -> runExceptT $ do
+        -- should not fail, unless input buffer is too short
+        dstSize <- ExceptT $ Z.checkError $ Z.compressCCtx cctx scratchPtr scratchSize sourcePtr (fromIntegral sourceSize) compressionLevel
+        liftIO $ Compressed . Large <$> B.packCStringLen (scratchPtr, fromIntegral dstSize)
+
+type DecompressCtx = (Ptr Z.DCtx, Ptr CChar, CSize)
+
+withDecompressCtx :: Int -> (DecompressCtx -> IO a) -> IO a
+withDecompressCtx maxUnpackedSize action =
+  bracket Z.createDCtx Z.freeDCtx $ \dctx ->
+    allocaBytes maxUnpackedSize $ \scratchPtr ->
+      action (dctx, scratchPtr, fromIntegral maxUnpackedSize)
+
+decompress :: DecompressCtx -> Compressed -> IO (Either String ByteString)
+decompress (dctx, scratchPtr, scratchSize) = \case
+  Passthrough bs -> pure $ Right bs
+  Compressed (Large bs) ->
+    B.unsafeUseAsCStringLen bs $ \(sourcePtr, sourceSize) -> do
+      res <- Z.checkError $ Z.decompressDCtx dctx scratchPtr scratchSize sourcePtr (fromIntegral sourceSize)
+      forM res $ \dstSize -> B.packCStringLen (scratchPtr, fromIntegral dstSize)
+
+decompressBatch :: Int -> NonEmpty Compressed -> NonEmpty (Either String ByteString)
+decompressBatch maxUnpackedSize items = unsafePerformIO $ withDecompressCtx maxUnpackedSize $ forM items . decompress
+{-# NOINLINE decompressBatch #-} -- prevent double-evaluation under unsafePerformIO

src/Simplex/Messaging/Crypto.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
@@ -36,7 +37,7 @@ module Simplex.Messaging.Crypto
     Algorithm (..),
     SAlgorithm (..),
     Alg (..),
-    SignAlg (..),
+    AuthAlg (..),
     DhAlg (..),
     DhAlgorithm,
     PrivateKey (..),
@@ -53,23 +54,32 @@ module Simplex.Messaging.Crypto
     APublicVerifyKey (..),
     APrivateDhKey (..),
     APublicDhKey (..),
+    APrivateAuthKey (..),
+    APublicAuthKey (..),
     CryptoPublicKey (..),
     CryptoPrivateKey (..),
+    AAuthKeyPair,
     KeyPair,
+    KeyPairX25519,
     ASignatureKeyPair,
     DhSecret (..),
     DhSecretX25519,
     ADhSecret (..),
     KeyHash (..),
     newRandom,
+    newRandomDRG,
     generateAKeyPair,
     generateKeyPair,
     generateSignatureKeyPair,
+    generateAuthKeyPair,
     generateDhKeyPair,
     privateToX509,
+    x509ToPublic,
+    x509ToPrivate,
     publicKey,
     signatureKeyPair,
     publicToX509,
+    encodeASNObj,
 
     -- * key encoding/decoding
     encodePubKey,
@@ -84,12 +94,20 @@ module Simplex.Messaging.Crypto
     CryptoSignature (..),
     SignatureSize (..),
     SignatureAlgorithm,
+    AuthAlgorithm,
     AlgorithmI (..),
     sign,
     sign',
     verify,
     verify',
     validSignatureSize,
+    checkAlgorithm,
+
+    -- * crypto_box authenticator, as discussed in https://groups.google.com/g/sci.crypt/c/73yb5a9pz2Y/m/LNgRO7IYXOwJ
+    CbAuthenticator (..),
+    cbAuthenticatorSize,
+    cbAuthenticate,
+    cbVerify,
 
     -- * DH derivation
     dh',
@@ -115,8 +133,10 @@ module Simplex.Messaging.Crypto
     CbNonce (unCbNonce),
     pattern CbNonce,
     cbEncrypt,
+    cbEncryptNoPad,
     cbEncryptMaxLenBS,
     cbDecrypt,
+    cbDecryptNoPad,
     sbDecrypt_,
     sbEncrypt_,
     cbNonce,
@@ -147,10 +167,13 @@ module Simplex.Messaging.Crypto
     Certificate,
     signCertificate,
     signX509,
+    verifyX509,
     certificateFingerprint,
     signedFingerprint,
     SignatureAlgorithmX509 (..),
     SignedObject (..),
+    encodeCertChain,
+    certChainP,
 
     -- * Cryptography error type
     CryptoError (..),
@@ -173,7 +196,7 @@ import Crypto.Cipher.AES (AES256)
 import qualified Crypto.Cipher.Types as AES
 import qualified Crypto.Cipher.XSalsa as XSalsa
 import qualified Crypto.Error as CE
-import Crypto.Hash (Digest, SHA256 (..), SHA512, hash)
+import Crypto.Hash (Digest, SHA256 (..), SHA512 (..), hash, hashDigestSize)
 import qualified Crypto.MAC.Poly1305 as Poly1305
 import qualified Crypto.PubKey.Curve25519 as X25519
 import qualified Crypto.PubKey.Curve448 as X448
@@ -188,13 +211,12 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (bimap, first)
 import Data.ByteArray (ByteArrayAccess)
 import qualified Data.ByteArray as BA
-import Data.ByteString.Base64 (decode, encode)
-import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.ByteString.Lazy (fromStrict, toStrict)
 import Data.Constraint (Dict (..))
 import Data.Kind (Constraint, Type)
+import qualified Data.List.NonEmpty as L
 import Data.String
 import Data.Type.Equality
 import Data.Typeable (Proxy (Proxy), Typeable)
@@ -206,6 +228,8 @@ import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
 import Network.Transport.Internal (decodeWord16, encodeWord16)
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.Base64 (decode, encode)
+import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString)
 import Simplex.Messaging.Util ((<$?>))
@@ -220,16 +244,14 @@ data SAlgorithm :: Algorithm -> Type where
   SX25519 :: SAlgorithm X25519
   SX448 :: SAlgorithm X448
 
-deriving instance Eq (SAlgorithm a)
-
 deriving instance Show (SAlgorithm a)
 
 data Alg = forall a. AlgorithmI a => Alg (SAlgorithm a)
 
-data SignAlg
+data AuthAlg
   = forall a.
-    (AlgorithmI a, SignatureAlgorithm a) =>
-    SignAlg (SAlgorithm a)
+    (AlgorithmI a, AuthAlgorithm a) =>
+    AuthAlg (SAlgorithm a)
 
 data DhAlg
   = forall a.
@@ -274,10 +296,11 @@ data APublicKey
     AlgorithmI a =>
     APublicKey (SAlgorithm a) (PublicKey a)
 
-instance Eq APublicKey where
-  APublicKey a k == APublicKey a' k' = case testEquality a a' of
-    Just Refl -> k == k'
-    Nothing -> False
+instance Encoding APublicKey where
+  smpEncode = smpEncode . encodePubKey
+  {-# INLINE smpEncode #-}
+  smpDecode = decodePubKey
+  {-# INLINE smpDecode #-}
 
 deriving instance Show APublicKey
 
@@ -313,11 +336,6 @@ data APrivateKey
     AlgorithmI a =>
     APrivateKey (SAlgorithm a) (PrivateKey a)
 
-instance Eq APrivateKey where
-  APrivateKey a k == APrivateKey a' k' = case testEquality a a' of
-    Just Refl -> k == k'
-    Nothing -> False
-
 deriving instance Show APrivateKey
 
 type PrivateKeyEd25519 = PrivateKey Ed25519
@@ -343,11 +361,6 @@ data APrivateSignKey
     (AlgorithmI a, SignatureAlgorithm a) =>
     APrivateSignKey (SAlgorithm a) (PrivateKey a)
 
-instance Eq APrivateSignKey where
-  APrivateSignKey a k == APrivateSignKey a' k' = case testEquality a a' of
-    Just Refl -> k == k'
-    Nothing -> False
-
 deriving instance Show APrivateSignKey
 
 instance Encoding APrivateSignKey where
@@ -367,11 +380,6 @@ data APublicVerifyKey
     (AlgorithmI a, SignatureAlgorithm a) =>
     APublicVerifyKey (SAlgorithm a) (PublicKey a)
 
-instance Eq APublicVerifyKey where
-  APublicVerifyKey a k == APublicVerifyKey a' k' = case testEquality a a' of
-    Just Refl -> k == k'
-    Nothing -> False
-
 deriving instance Show APublicVerifyKey
 
 data APrivateDhKey
@@ -379,11 +387,6 @@ data APrivateDhKey
     (AlgorithmI a, DhAlgorithm a) =>
     APrivateDhKey (SAlgorithm a) (PrivateKey a)
 
-instance Eq APrivateDhKey where
-  APrivateDhKey a k == APrivateDhKey a' k' = case testEquality a a' of
-    Just Refl -> k == k'
-    Nothing -> False
-
 deriving instance Show APrivateDhKey
 
 data APublicDhKey
@@ -391,11 +394,6 @@ data APublicDhKey
     (AlgorithmI a, DhAlgorithm a) =>
     APublicDhKey (SAlgorithm a) (PublicKey a)
 
-instance Eq APublicDhKey where
-  APublicDhKey a k == APublicDhKey a' k' = case testEquality a a' of
-    Just Refl -> k == k'
-    Nothing -> False
-
 deriving instance Show APublicDhKey
 
 data DhSecret (a :: Algorithm) where
@@ -425,6 +423,57 @@ dhAlgorithm = \case
   SX448 -> Just Dict
   _ -> Nothing
 
+data APrivateAuthKey
+  = forall a.
+    (AlgorithmI a, AuthAlgorithm a) =>
+    APrivateAuthKey (SAlgorithm a) (PrivateKey a)
+
+instance Eq APrivateAuthKey where
+  APrivateAuthKey a k == APrivateAuthKey a' k' = case testEquality a a' of
+    Just Refl -> k == k'
+    Nothing -> False
+
+deriving instance Show APrivateAuthKey
+
+instance Encoding APrivateAuthKey where
+  smpEncode = smpEncode . encodePrivKey
+  {-# INLINE smpEncode #-}
+  smpDecode = decodePrivKey
+  {-# INLINE smpDecode #-}
+
+instance StrEncoding APrivateAuthKey where
+  strEncode = strEncode . encodePrivKey
+  {-# INLINE strEncode #-}
+  strDecode = decodePrivKey
+  {-# INLINE strDecode #-}
+
+data APublicAuthKey
+  = forall a.
+    (AlgorithmI a, AuthAlgorithm a) =>
+    APublicAuthKey (SAlgorithm a) (PublicKey a)
+
+instance Eq APublicAuthKey where
+  APublicAuthKey a k == APublicAuthKey a' k' = case testEquality a a' of
+    Just Refl -> k == k'
+    Nothing -> False
+
+deriving instance Show APublicAuthKey
+
+-- either X25519 or Ed algorithm that can be used to authorize commands to SMP server
+type family AuthAlgorithm (a :: Algorithm) :: Constraint where
+  AuthAlgorithm Ed25519 = ()
+  AuthAlgorithm Ed448 = ()
+  AuthAlgorithm X25519 = ()
+  AuthAlgorithm a =
+    (Int ~ Bool, TypeError (Text "Algorithm " :<>: ShowType a :<>: Text " cannot be used for authorization"))
+
+authAlgorithm :: SAlgorithm a -> Maybe (Dict (AuthAlgorithm a))
+authAlgorithm = \case
+  SEd25519 -> Just Dict
+  SEd448 -> Just Dict
+  SX25519 -> Just Dict
+  _ -> Nothing
+
 dhBytes' :: DhSecret a -> ByteString
 dhBytes' = \case
   DhSecretX25519 s -> BA.convert s
@@ -464,6 +513,12 @@ instance CryptoPublicKey APublicVerifyKey where
     Just Dict -> Right $ APublicVerifyKey a k
     _ -> Left "key does not support signature algorithms"
 
+instance CryptoPublicKey APublicAuthKey where
+  toPubKey f (APublicAuthKey _ k) = f k
+  pubKey (APublicKey a k) = case authAlgorithm a of
+    Just Dict -> Right $ APublicAuthKey a k
+    _ -> Left "key does not support auth algorithms"
+
 instance CryptoPublicKey APublicDhKey where
   toPubKey f (APublicDhKey _ k) = f k
   pubKey (APublicKey a k) = case dhAlgorithm a of
@@ -480,6 +535,12 @@ instance Encoding APublicVerifyKey where
   smpDecode = decodePubKey
   {-# INLINE smpDecode #-}
 
+instance Encoding APublicAuthKey where
+  smpEncode = smpEncode . encodePubKey
+  {-# INLINE smpEncode #-}
+  smpDecode = decodePubKey
+  {-# INLINE smpDecode #-}
+
 instance Encoding APublicDhKey where
   smpEncode = smpEncode . encodePubKey
   {-# INLINE smpEncode #-}
@@ -498,6 +559,12 @@ instance StrEncoding APublicVerifyKey where
   strDecode = decodePubKey
   {-# INLINE strDecode #-}
 
+instance StrEncoding APublicAuthKey where
+  strEncode = strEncode . encodePubKey
+  {-# INLINE strEncode #-}
+  strDecode = decodePubKey
+  {-# INLINE strDecode #-}
+
 instance StrEncoding APublicDhKey where
   strEncode = strEncode . encodePubKey
   {-# INLINE strEncode #-}
@@ -545,6 +612,13 @@ instance CryptoPrivateKey APrivateSignKey where
     Just Dict -> Right $ APrivateSignKey a k
     _ -> Left "key does not support signature algorithms"
 
+instance CryptoPrivateKey APrivateAuthKey where
+  type PublicKeyType APrivateAuthKey = APublicAuthKey
+  toPrivKey f (APrivateAuthKey _ k) = f k
+  privKey (APrivateKey a k) = case authAlgorithm a of
+    Just Dict -> Right $ APrivateAuthKey a k
+    _ -> Left "key does not support auth algorithms"
+
 instance CryptoPrivateKey APrivateDhKey where
   type PublicKeyType APrivateDhKey = APublicDhKey
   toPrivKey f (APrivateDhKey _ k) = f k
@@ -588,21 +662,32 @@ type KeyPairType pk = (PublicKeyType pk, pk)
 
 type KeyPair a = KeyPairType (PrivateKey a)
 
+type KeyPairX25519 = KeyPair X25519
+
+-- TODO narrow key pair types to have the same algorithm in both keys
 type AKeyPair = KeyPairType APrivateKey
 
 type ASignatureKeyPair = KeyPairType APrivateSignKey
 
 type ADhKeyPair = KeyPairType APrivateDhKey
 
+type AAuthKeyPair = KeyPairType APrivateAuthKey
+
 newRandom :: IO (TVar ChaChaDRG)
 newRandom = newTVarIO =<< drgNew
 
+newRandomDRG :: TVar ChaChaDRG -> STM (TVar ChaChaDRG)
+newRandomDRG g = newTVar =<< stateTVar g (`withDRG` drgNew)
+
 generateAKeyPair :: AlgorithmI a => SAlgorithm a -> TVar ChaChaDRG -> STM AKeyPair
 generateAKeyPair a g = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair g
 
 generateSignatureKeyPair :: (AlgorithmI a, SignatureAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ASignatureKeyPair
 generateSignatureKeyPair a g = bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair g
 
+generateAuthKeyPair :: (AlgorithmI a, AuthAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
+generateAuthKeyPair a g = bimap (APublicAuthKey a) (APrivateAuthKey a) <$> generateKeyPair g
+
 generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ADhKeyPair
 generateDhKeyPair a g = bimap (APublicDhKey a) (APrivateDhKey a) <$> generateKeyPair g
 
@@ -632,6 +717,10 @@ instance ToField APrivateSignKey where toField = toField . encodePrivKey
 
 instance ToField APublicVerifyKey where toField = toField . encodePubKey
 
+instance ToField APrivateAuthKey where toField = toField . encodePrivKey
+
+instance ToField APublicAuthKey where toField = toField . encodePubKey
+
 instance ToField APrivateDhKey where toField = toField . encodePrivKey
 
 instance ToField APublicDhKey where toField = toField . encodePubKey
@@ -646,6 +735,10 @@ instance FromField APrivateSignKey where fromField = blobFieldDecoder decodePriv
 
 instance FromField APublicVerifyKey where fromField = blobFieldDecoder decodePubKey
 
+instance FromField APrivateAuthKey where fromField = blobFieldDecoder decodePrivKey
+
+instance FromField APublicAuthKey where fromField = blobFieldDecoder decodePubKey
+
 instance FromField APrivateDhKey where fromField = blobFieldDecoder decodePrivKey
 
 instance FromField APublicDhKey where fromField = blobFieldDecoder decodePubKey
@@ -656,15 +749,13 @@ instance (Typeable a, AlgorithmI a) => FromField (PublicKey a) where fromField =
 
 instance (Typeable a, AlgorithmI a) => FromField (DhSecret a) where fromField = blobFieldDecoder strDecode
 
-instance IsString (Maybe ASignature) where
+instance IsString ASignature where
   fromString = parseString $ decode >=> decodeSignature
 
 data Signature (a :: Algorithm) where
   SignatureEd25519 :: Ed25519.Signature -> Signature Ed25519
   SignatureEd448 :: Ed448.Signature -> Signature Ed448
 
-deriving instance Eq (Signature a)
-
 deriving instance Show (Signature a)
 
 data ASignature
@@ -672,11 +763,6 @@ data ASignature
     (AlgorithmI a, SignatureAlgorithm a) =>
     ASignature (SAlgorithm a) (Signature a)
 
-instance Eq ASignature where
-  ASignature a s == ASignature a' s' = case testEquality a a' of
-    Just Refl -> s == s'
-    _ -> False
-
 deriving instance Show ASignature
 
 class CryptoSignature s where
@@ -761,6 +847,8 @@ data CryptoError
     CryptoHeaderError String
   | -- | no sending chain key in ratchet state
     CERatchetState
+  | -- | no decapsulation key in ratchet state
+    CERatchetKEMState
   | -- | header decryption error (could indicate that another key should be tried)
     CERatchetHeader
   | -- | too many skipped messages
@@ -1021,6 +1109,18 @@ signX509 key = fst . objectToSignedExact f
         signatureAlgorithmX509 key,
         ()
       )
+{-# INLINE signX509 #-}
+
+verifyX509 :: (ASN1Object o, Eq o, Show o) => APublicVerifyKey -> SignedExact o -> Either String o
+verifyX509 key exact = do
+  signature <- case signedAlg of
+    SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> ASignature SEd25519 <$> decodeSignature signedSignature
+    SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> ASignature SEd448 <$> decodeSignature signedSignature
+    _ -> Left "unknown x509 signature algorithm"
+  if verify key signature $ getSignedData exact then Right signedObject else Left "bad signature"
+  where
+    Signed {signedObject, signedAlg, signedSignature} = getSigned exact
+{-# INLINE verifyX509 #-}
 
 certificateFingerprint :: SignedCertificate -> KeyHash
 certificateFingerprint = signedFingerprint
@@ -1049,7 +1149,7 @@ instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where
   signatureAlgorithmX509 = signatureAlgorithmX509 . snd
 
 -- | A wrapper to marshall signed ASN1 objects, like certificates.
-newtype SignedObject a = SignedObject (SignedExact a)
+newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a}
 
 instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) where
   fromField = fmap SignedObject . blobFieldDecoder decodeSignedObject
@@ -1057,6 +1157,20 @@ instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a)
 instance (Eq a, Show a, ASN1Object a) => ToField (SignedObject a) where
   toField (SignedObject s) = toField $ encodeSignedObject s
 
+instance (Eq a, Show a, ASN1Object a) => Encoding (SignedObject a) where
+  smpEncode (SignedObject exact) = smpEncode . Large $ encodeSignedObject exact
+  smpP = fmap SignedObject . decodeSignedObject . unLarge <$?> smpP
+
+encodeCertChain :: CertificateChain -> L.NonEmpty Large
+encodeCertChain cc = L.fromList $ map Large blobs
+  where
+    CertificateChainRaw blobs = encodeCertificateChain cc
+
+certChainP :: A.Parser CertificateChain
+certChainP = do
+  rawChain <- CertificateChainRaw . map unLarge . L.toList <$> smpP
+  either (fail . show) pure $ decodeCertificateChain rawChain
+
 -- | Signature verification.
 --
 -- Used by SMP servers to authorize SMP commands and by SMP agents to verify messages.
@@ -1073,10 +1187,14 @@ dh' :: DhAlgorithm a => PublicKey a -> PrivateKey a -> DhSecret a
 dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk _) = DhSecretX25519 $ X25519.dh k pk
 dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
 
--- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
+-- | NaCl @crypto_box@ encrypt with padding with a shared DH secret and 192-bit nonce.
 cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
 cbEncrypt (DhSecretX25519 secret) = sbEncrypt_ secret
 
+-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce (without padding).
+cbEncryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> ByteString
+cbEncryptNoPad (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce
+
 -- | NaCl @secret_box@ encrypt with a symmetric 256-bit key and 192-bit nonce.
 sbEncrypt :: SbKey -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
 sbEncrypt (SbKey key) = sbEncrypt_ key
@@ -1098,21 +1216,43 @@ cryptoBox secret nonce s = BA.convert tag <> c
 cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
 cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret
 
+-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
+cbDecryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
+cbDecryptNoPad (DhSecretX25519 secret) = sbDecryptNoPad_ secret
+
 -- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce.
 sbDecrypt :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString
 sbDecrypt (SbKey key) = sbDecrypt_ key
 
 -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
 sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
-sbDecrypt_ secret (CbNonce nonce) packet
+sbDecrypt_ secret nonce = unPad <=< sbDecryptNoPad_ secret nonce
+
+-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
+sbDecryptNoPad_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
+sbDecryptNoPad_ secret (CbNonce nonce) packet
   | B.length packet < 16 = Left CBDecryptError
-  | BA.constEq tag' tag = unPad msg
+  | BA.constEq tag' tag = Right msg
   | otherwise = Left CBDecryptError
   where
     (tag', c) = B.splitAt 16 packet
     (rs, msg) = xSalsa20 secret nonce c
     tag = Poly1305.auth rs c
 
+-- type for authentication scheme using NaCl @crypto_box@ over the sha512 digest of the message.
+newtype CbAuthenticator = CbAuthenticator ByteString deriving (Eq, Show)
+
+cbAuthenticatorSize :: Int
+cbAuthenticatorSize = hashDigestSize SHA512 + authTagSize -- 64 + 16 = 80 bytes
+
+-- create crypto_box authenticator for a message.
+cbAuthenticate :: PublicKeyX25519 -> PrivateKeyX25519 -> CbNonce -> ByteString -> CbAuthenticator
+cbAuthenticate k pk nonce msg = CbAuthenticator $ cbEncryptNoPad (dh' k pk) nonce (sha512Hash msg)
+
+-- verify crypto_box authenticator for a message.
+cbVerify :: PublicKeyX25519 -> PrivateKeyX25519 -> CbNonce -> CbAuthenticator -> ByteString -> Bool
+cbVerify k pk nonce (CbAuthenticator s) authorized = cbDecryptNoPad (dh' k pk) nonce s == Right (sha512Hash authorized)
+
 newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString}
   deriving (Eq, Show)
 

src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs

@@ -19,16 +19,20 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 
 newtype KEMPublicKey = KEMPublicKey ByteString
-  deriving (Show)
+  deriving (Eq, Show)
 
 newtype KEMSecretKey = KEMSecretKey ScrubbedBytes
-  deriving (Show)
+  deriving (Eq, Show)
 
 newtype KEMCiphertext = KEMCiphertext ByteString
-  deriving (Show)
+  deriving (Eq, Show)
 
 newtype KEMSharedKey = KEMSharedKey ScrubbedBytes
-  deriving (Show)
+  deriving (Eq, Show)
+
+unsafeRevealKEMSharedKey :: KEMSharedKey -> String
+unsafeRevealKEMSharedKey (KEMSharedKey scrubbed) = show (BA.convert scrubbed :: ByteString)
+{-# DEPRECATED unsafeRevealKEMSharedKey "unsafeRevealKEMSharedKey left in code" #-}
 
 type KEMKeyPair = (KEMPublicKey, KEMSecretKey)
 
@@ -60,6 +64,18 @@ sntrup761Dec (KEMCiphertext c) (KEMSecretKey sk) =
       KEMSharedKey
         <$> BA.alloc c_SNTRUP761_SIZE (\kPtr -> c_sntrup761_dec kPtr cPtr skPtr)
 
+instance Encoding KEMSecretKey where
+  smpEncode (KEMSecretKey c) = smpEncode . Large $ BA.convert c
+  smpP = KEMSecretKey . BA.convert . unLarge <$> smpP
+
+instance StrEncoding KEMSecretKey where
+  strEncode (KEMSecretKey pk) = strEncode (BA.convert pk :: ByteString)
+  strP = KEMSecretKey . BA.convert <$> strP @ByteString
+
+instance Encoding KEMPublicKey where
+  smpEncode (KEMPublicKey pk) = smpEncode . Large $ BA.convert pk
+  smpP = KEMPublicKey . BA.convert . unLarge <$> smpP
+
 instance StrEncoding KEMPublicKey where
   strEncode (KEMPublicKey pk) = strEncode (BA.convert pk :: ByteString)
   strP = KEMPublicKey . BA.convert <$> strP @ByteString
@@ -68,6 +84,25 @@ instance Encoding KEMCiphertext where
   smpEncode (KEMCiphertext c) = smpEncode . Large $ BA.convert c
   smpP = KEMCiphertext . BA.convert . unLarge <$> smpP
 
+instance Encoding KEMSharedKey where
+  smpEncode (KEMSharedKey c) = smpEncode (BA.convert c :: ByteString)
+  smpP = KEMSharedKey . BA.convert <$> smpP @ByteString
+
+instance StrEncoding KEMCiphertext where
+  strEncode (KEMCiphertext pk) = strEncode (BA.convert pk :: ByteString)
+  strP = KEMCiphertext . BA.convert <$> strP @ByteString
+
+instance StrEncoding KEMSharedKey where
+  strEncode (KEMSharedKey pk) = strEncode (BA.convert pk :: ByteString)
+  strP = KEMSharedKey . BA.convert <$> strP @ByteString
+
+instance ToJSON KEMSecretKey where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON KEMSecretKey where
+  parseJSON = strParseJSON "KEMSecretKey"
+
 instance ToJSON KEMPublicKey where
   toJSON = strToJSON
   toEncoding = strToJEncoding
@@ -75,8 +110,22 @@ instance ToJSON KEMPublicKey where
 instance FromJSON KEMPublicKey where
   parseJSON = strParseJSON "KEMPublicKey"
 
+instance ToJSON KEMCiphertext where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON KEMCiphertext where
+  parseJSON = strParseJSON "KEMCiphertext"
+
 instance ToField KEMSharedKey where
   toField (KEMSharedKey k) = toField (BA.convert k :: ByteString)
 
 instance FromField KEMSharedKey where
   fromField f = KEMSharedKey . BA.convert @ByteString <$> fromField f
+
+instance ToJSON KEMSharedKey where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON KEMSharedKey where
+  parseJSON = strParseJSON "KEMSharedKey"

src/Simplex/Messaging/Encoding.hs

@@ -110,7 +110,7 @@ lenP = fromIntegral . c2w <$> A.anyChar
 {-# INLINE lenP #-}
 
 instance Encoding a => Encoding (Maybe a) where
-  smpEncode = maybe "0" (("1" <>) . smpEncode)
+  smpEncode = maybe "0" (('1' `B.cons`) . smpEncode)
   {-# INLINE smpEncode #-}
   smpP =
     smpP >>= \case

src/Simplex/Messaging/Encoding/Base64.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Compatibility wrappers for base64 package, Base64 (padded) variant.
+module Simplex.Messaging.Encoding.Base64 where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Base64.Types (extractBase64)
+import Data.Bifunctor (first)
+import Data.ByteString.Base64 (decodeBase64Untyped, encodeBase64')
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Text as T
+
+encode :: ByteString -> ByteString
+encode = extractBase64 . encodeBase64'
+{-# INLINE encode #-}
+
+decode :: ByteString -> Either String ByteString
+decode = first T.unpack . decodeBase64Untyped
+{-# INLINE decode #-}
+
+base64P :: A.Parser ByteString
+base64P = do
+  str <- A.takeWhile1 (`B.elem` base64Alphabet)
+  pad <- A.takeWhile (== '=') -- correct amount of padding can be derived from str length
+  either (fail . T.unpack) pure $ decodeBase64Untyped (str <> pad)
+
+base64Alphabet :: ByteString
+base64Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

src/Simplex/Messaging/Encoding/Base64/URL.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Compatibility wrappers for base64 package, Base64URL-padded variant.
+module Simplex.Messaging.Encoding.Base64.URL where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Base64.Types (extractBase64)
+import Data.Bifunctor (first)
+import Data.ByteString.Base64.URL (decodeBase64Lenient, decodeBase64UnpaddedUntyped, decodeBase64Untyped, encodeBase64')
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Text as T
+
+encode :: ByteString -> ByteString
+encode = extractBase64 . encodeBase64'
+{-# INLINE encode #-}
+
+decode :: ByteString -> Either String ByteString
+decode = first T.unpack . decodeBase64Untyped
+{-# INLINE decode #-}
+
+decodeLenient :: ByteString -> ByteString
+decodeLenient = decodeBase64Lenient
+{-# INLINE decodeLenient #-}
+
+base64urlP :: A.Parser ByteString
+base64urlP = do
+  str <- A.takeWhile1 (`B.elem` base64AlphabetURL)
+  _pad <- A.takeWhile (== '=') -- correct amount of padding can be derived from str length
+  either (fail . T.unpack) pure $ decodeBase64UnpaddedUntyped str
+
+base64AlphabetURL :: ByteString
+base64AlphabetURL = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"

src/Simplex/Messaging/Encoding/String.hs

@@ -10,7 +10,6 @@ module Simplex.Messaging.Encoding.String
     strToJSON,
     strToJEncoding,
     strParseJSON,
-    base64urlP,
     strEncodeList,
     strListP,
   )
@@ -23,10 +22,8 @@ import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.Types as JT
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (isAlphaNum)
 import Data.Int (Int64)
 import qualified Data.List.NonEmpty as L
 import Data.Set (Set)
@@ -38,6 +35,7 @@ import Data.Time.Clock.System (SystemTime (..))
 import Data.Time.Format.ISO8601
 import Data.Word (Word16, Word32)
 import Simplex.Messaging.Encoding
+import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util ((<$?>))
 
@@ -54,19 +52,16 @@ class StrEncoding a where
   strDecode :: ByteString -> Either String a
   strDecode = parseAll strP
   strP :: Parser a
-  strP = strDecode <$?> base64urlP
+  strP = strDecode <$?> U.base64urlP
 
 -- base64url encoding/decoding of ByteStrings - the parser only allows non-empty strings
 instance StrEncoding ByteString where
   strEncode = U.encode
+  {-# INLINE strEncode #-}
   strDecode = U.decode
-  strP = base64urlP
-
-base64urlP :: Parser ByteString
-base64urlP = do
-  str <- A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')
-  pad <- A.takeWhile (== '=')
-  either fail pure $ U.decode (str <> pad)
+  {-# INLINE strDecode #-}
+  strP = U.base64urlP
+  {-# INLINE strP #-}
 
 newtype Str = Str {unStr :: ByteString}
   deriving (Eq, Show)
@@ -179,6 +174,12 @@ instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncodin
   strP = (,,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP
   {-# INLINE strP #-}
 
+instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncoding e, StrEncoding f) => StrEncoding (a, b, c, d, e, f) where
+  strEncode (a, b, c, d, e, f) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d, strEncode e, strEncode f]
+  {-# INLINE strEncode #-}
+  strP = (,,,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP
+  {-# INLINE strP #-}
+
 strP_ :: StrEncoding a => Parser a
 strP_ = strP <* A.space
 

src/Simplex/Messaging/Notifications/Client.hs

@@ -10,57 +10,61 @@ import Data.Word (Word16)
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange)
 import Simplex.Messaging.Protocol (ErrorType)
 import Simplex.Messaging.Util (bshow)
 
-type NtfClient = ProtocolClient ErrorType NtfResponse
+type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse
 
 type NtfClientError = ProtocolClientError ErrorType
 
-ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
+defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
+defaultNTFClientConfig = defaultClientConfig supportedClientNTFVRange
+
+ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
 ntfRegisterToken c pKey newTkn =
   sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
     NRTknId tknId dhKey -> pure (tknId, dhKey)
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
+ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
 ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
 
-ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
+ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
 ntfCheckToken c pKey tknId =
   sendNtfCommand c (Just pKey) tknId TCHK >>= \case
     NRTkn stat -> pure stat
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-ntfReplaceToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
+ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
 ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
 
-ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT NtfClientError IO ()
+ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
 ntfDeleteToken = okNtfCommand TDEL
 
-ntfEnableCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
+ntfEnableCron :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
 ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
 
-ntfCreateSubscription :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
+ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
 ntfCreateSubscription c pKey newSub =
   sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
     NRSubId subId -> pure subId
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
+ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
 ntfCheckSubscription c pKey subId =
   sendNtfCommand c (Just pKey) subId SCHK >>= \case
     NRSub stat -> pure stat
     r -> throwE . PCEUnexpectedResponse $ bshow r
 
-ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
+ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
 ntfDeleteSubscription = okNtfCommand SDEL
 
 -- | Send notification server command
-sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateSignKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
+sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
 sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
 
-okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -> NtfEntityId -> ExceptT NtfClientError IO ()
+okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
 okNtfCommand cmd c pKey entId =
   sendNtfCommand c (Just pKey) entId cmd >>= \case
     NROk -> return ()

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -28,7 +28,7 @@ import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
+import Simplex.Messaging.Notifications.Transport (NTFVersion, ntfClientHandshake)
 import Simplex.Messaging.Parsers (fromTextField_)
 import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
 import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
@@ -124,8 +124,8 @@ instance ToJSON NtfRegCode where
   toEncoding = strToJEncoding
 
 data NewNtfEntity (e :: NtfEntity) where
-  NewNtfTkn :: DeviceToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
-  NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateSignKey -> NewNtfEntity 'Subscription
+  NewNtfTkn :: DeviceToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
+  NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription
 
 deriving instance Show (NewNtfEntity e)
 
@@ -147,7 +147,7 @@ instance Encoding ANewNtfEntity where
       'S' -> ANE SSubscription <$> (NewNtfSub <$> smpP <*> smpP <*> smpP)
       _ -> fail "bad ANewNtfEntity"
 
-instance Protocol ErrorType NtfResponse where
+instance Protocol NTFVersion ErrorType NtfResponse where
   type ProtoCommand NtfResponse = NtfCmd
   type ProtoType NtfResponse = 'PNTF
   protocolClientHandshake = ntfClientHandshake
@@ -184,7 +184,7 @@ data NtfCmd = forall e. NtfEntityI e => NtfCmd (SNtfEntity e) (NtfCommand e)
 
 deriving instance Show NtfCmd
 
-instance NtfEntityI e => ProtocolEncoding ErrorType (NtfCommand e) where
+instance NtfEntityI e => ProtocolEncoding NTFVersion ErrorType (NtfCommand e) where
   type Tag (NtfCommand e) = NtfCommandTag e
   encodeProtocol _v = \case
     TNEW newTkn -> e (TNEW_, ' ', newTkn)
@@ -203,27 +203,27 @@ instance NtfEntityI e => ProtocolEncoding ErrorType (NtfCommand e) where
 
   protocolP _v tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP _v (NCT (sNtfEntity @e) tag)
 
-  fromProtocolError = fromProtocolError @ErrorType @NtfResponse
+  fromProtocolError = fromProtocolError @NTFVersion @ErrorType @NtfResponse
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (sig, _, entityId, _) cmd = case cmd of
+  checkCredentials (auth, _, entityId, _) cmd = case cmd of
     -- TNEW and SNEW must have signature but NOT token/subscription IDs
     TNEW {} -> sigNoEntity
     SNEW {} -> sigNoEntity
     PING
-      | isNothing sig && B.null entityId -> Right cmd
+      | isNothing auth && B.null entityId -> Right cmd
       | otherwise -> Left $ CMD HAS_AUTH
     -- other client commands must have both signature and entity ID
     _
-      | isNothing sig || B.null entityId -> Left $ CMD NO_AUTH
+      | isNothing auth || B.null entityId -> Left $ CMD NO_AUTH
       | otherwise -> Right cmd
     where
       sigNoEntity
-        | isNothing sig = Left $ CMD NO_AUTH
+        | isNothing auth = Left $ CMD NO_AUTH
         | not (B.null entityId) = Left $ CMD HAS_AUTH
         | otherwise = Right cmd
 
-instance ProtocolEncoding ErrorType NtfCmd where
+instance ProtocolEncoding NTFVersion ErrorType NtfCmd where
   type Tag NtfCmd = NtfCmdTag
   encodeProtocol _v (NtfCmd _ c) = encodeProtocol _v c
 
@@ -243,7 +243,7 @@ instance ProtocolEncoding ErrorType NtfCmd where
         SDEL_ -> pure SDEL
         PING_ -> pure PING
 
-  fromProtocolError = fromProtocolError @ErrorType @NtfResponse
+  fromProtocolError = fromProtocolError @NTFVersion @ErrorType @NtfResponse
   {-# INLINE fromProtocolError #-}
 
   checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
@@ -290,7 +290,7 @@ data NtfResponse
   | NRPong
   deriving (Show)
 
-instance ProtocolEncoding ErrorType NtfResponse where
+instance ProtocolEncoding NTFVersion ErrorType NtfResponse where
   type Tag NtfResponse = NtfResponseTag
   encodeProtocol _v = \case
     NRTknId entId dhKey -> e (NRTknId_, ' ', entId, dhKey)
@@ -358,7 +358,11 @@ instance StrEncoding SMPQueueNtf where
     notifierId <- A.char '/' *> strP
     pure SMPQueueNtf {smpServer, notifierId}
 
-data PushProvider = PPApnsDev | PPApnsProd | PPApnsTest
+data PushProvider
+  = PPApnsDev -- provider for Apple development environment
+  | PPApnsProd -- production environment, including TestFlight
+  | PPApnsTest -- used for tests, to use APNS mock server
+  | PPApnsNull -- used to test servers from the client - does not communicate with APNS
   deriving (Eq, Ord, Show)
 
 instance Encoding PushProvider where
@@ -366,11 +370,13 @@ instance Encoding PushProvider where
     PPApnsDev -> "AD"
     PPApnsProd -> "AP"
     PPApnsTest -> "AT"
+    PPApnsNull -> "AN"
   smpP =
     A.take 2 >>= \case
       "AD" -> pure PPApnsDev
       "AP" -> pure PPApnsProd
       "AT" -> pure PPApnsTest
+      "AN" -> pure PPApnsNull
       _ -> fail "bad PushProvider"
 
 instance StrEncoding PushProvider where
@@ -378,11 +384,13 @@ instance StrEncoding PushProvider where
     PPApnsDev -> "apns_dev"
     PPApnsProd -> "apns_prod"
     PPApnsTest -> "apns_test"
+    PPApnsNull -> "apns_null"
   strP =
     A.takeTill (== ' ') >>= \case
       "apns_dev" -> pure PPApnsDev
       "apns_prod" -> pure PPApnsProd
       "apns_test" -> pure PPApnsTest
+      "apns_null" -> pure PPApnsNull
       _ -> fail "bad PushProvider"
 
 instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8

src/Simplex/Messaging/Notifications/Server.hs

@@ -23,7 +23,6 @@ import Data.Int (Int64)
 import Data.List (intercalate, sort)
 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 (catMaybes)
 import qualified Data.Text as T
@@ -48,8 +47,8 @@ import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
 import Simplex.Messaging.Server.Stats
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..))
-import Simplex.Messaging.Transport.Server (runTransportServer)
+import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..))
+import Simplex.Messaging.Transport.Server (runTransportServer, tlsServerCredentials)
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
 import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
@@ -75,19 +74,22 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
   restoreServerStats
   s <- asks subscriber
   ps <- asks pushServer
-  subs <- readTVarIO =<< asks (subscriptions . store)
-  void . forkIO $ resubscribe s subs
+  resubscribe s
   raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
   where
     runServer :: (ServiceName, ATransport) -> M ()
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams tCfg (runClient t)
+      serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams
+      runTransportServer started tcpPort serverParams tCfg (runClient serverSignKey t)
+    fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
 
-    runClient :: Transport c => TProxy c -> c -> M ()
-    runClient _ h = do
+    runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
+    runClient signKey _ h = do
       kh <- asks serverIdentity
-      liftIO (runExceptT $ ntfServerHandshake h kh supportedNTFServerVRange) >>= \case
+      ks <- atomically . C.generateKeyPair =<< asks random
+      NtfServerConfig {ntfServerVRange} <- asks config
+      liftIO (runExceptT $ ntfServerHandshake signKey h ks kh ntfServerVRange) >>= \case
         Right th -> runNtfClientTransport th
         Left _ -> pure ()
 
@@ -143,11 +145,13 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
               ]
         liftIO $ threadDelay' interval
 
-resubscribe :: NtfSubscriber -> Map NtfSubscriptionId NtfSubData -> M ()
-resubscribe NtfSubscriber {newSubQ} subs = do
-  subs' <- atomically $ filterM (fmap ntfShouldSubscribe . readTVar . subStatus) $ M.elems subs
+resubscribe :: NtfSubscriber -> M ()
+resubscribe NtfSubscriber {newSubQ} = do
+  logInfo "Preparing SMP resubscriptions..."
+  subs <- readTVarIO =<< asks (subscriptions . store)
+  subs' <- filterM (fmap ntfShouldSubscribe . readTVarIO . subStatus) $ M.elems subs
   atomically . writeTBQueue newSubQ $ map NtfSub subs'
-  liftIO $ logInfo $ "SMP resubscriptions queued (" <> tshow (length subs') <> " subscriptions)"
+  logInfo $ "SMP resubscriptions queued (" <> tshow (length subs') <> " subscriptions)"
 
 ntfSubscriber :: NtfSubscriber -> M ()
 ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
@@ -334,11 +338,11 @@ updateTknStatus NtfTknData {ntfTknId, tknStatus} status = do
   old <- atomically $ stateTVar tknStatus (,status)
   when (old /= status) $ withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
 
-runNtfClientTransport :: Transport c => THandle c -> M ()
-runNtfClientTransport th@THandle {sessionId} = do
+runNtfClientTransport :: Transport c => THandleNTF c -> M ()
+runNtfClientTransport th@THandle {params} = do
   qSize <- asks $ clientQSize . config
   ts <- liftIO getSystemTime
-  c <- atomically $ newNtfServerClient qSize sessionId ts
+  c <- atomically $ newNtfServerClient qSize params ts
   s <- asks subscriber
   ps <- asks pushServer
   expCfg <- asks $ inactiveClientExpiration . config
@@ -351,8 +355,8 @@ runNtfClientTransport th@THandle {sessionId} = do
 clientDisconnected :: NtfServerClient -> IO ()
 clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
 
-receive :: Transport c => THandle c -> NtfServerClient -> M ()
-receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
+receive :: Transport c => THandleNTF c -> NtfServerClient -> M ()
+receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
   ts <- liftIO $ tGet th
   forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
     atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime
@@ -360,16 +364,16 @@ receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
     case cmdOrError of
       Left e -> write sndQ (corrId, entId, NRErr e)
       Right cmd ->
-        verifyNtfTransmission t cmd >>= \case
+        verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd >>= \case
           VRVerified req -> write rcvQ req
           VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
   where
     write q t = atomically $ writeTBQueue q t
 
-send :: Transport c => THandle c -> NtfServerClient -> IO ()
-send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} = forever $ do
+send :: Transport c => THandleNTF c -> NtfServerClient -> IO ()
+send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
   t <- atomically $ readTBQueue sndQ
-  void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
+  void . liftIO $ tPut h [Right (Nothing, encodeTransmission params t)]
   atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
 
 -- instance Show a => Show (TVar a) where
@@ -377,14 +381,14 @@ send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} =
 
 data VerificationResult = VRVerified NtfRequest | VRFailed
 
-verifyNtfTransmission :: SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
-verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
+verifyNtfTransmission :: Maybe (THandleAuth, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
+verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do
   st <- asks store
   case cmd of
     NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do
       r_ <- atomically $ getNtfTokenRegistration st tkn
       pure $
-        if verifyCmdSignature sig_ signed k
+        if verifyCmdAuthorization auth_ tAuth authorized k
           then case r_ of
             Just t@NtfTknData {tknVerifyKey}
               | k == tknVerifyKey -> verifiedTknCmd t c
@@ -405,7 +409,7 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
             then do
               t_ <- atomically $ getActiveNtfToken st subTknId
               verifyToken' t_ $ verifiedSubCmd s c
-            else pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+            else pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed
     NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId
     NtfCmd SSubscription c -> do
       s_ <- atomically $ getNtfSubscription st entId
@@ -413,7 +417,7 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
         Just s@NtfSubData {tokenId = subTknId} -> do
           t_ <- atomically $ getActiveNtfToken st subTknId
           verifyToken' t_ $ verifiedSubCmd s c
-        _ -> pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+        _ -> pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed
   where
     verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
     verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c))
@@ -421,10 +425,10 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
     verifyToken t_ positiveVerificationResult =
       pure $ case t_ of
         Just t@NtfTknData {tknVerifyKey} ->
-          if verifyCmdSignature sig_ signed tknVerifyKey
+          if verifyCmdAuthorization auth_ tAuth authorized tknVerifyKey
             then positiveVerificationResult t
             else VRFailed
-        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
+        _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed
     verifyToken' :: Maybe NtfTknData -> VerificationResult -> M VerificationResult
     verifyToken' t_ = verifyToken t_ . const
 

src/Simplex/Messaging/Notifications/Server/Env.hs

@@ -12,7 +12,6 @@ import Control.Concurrent.Async (Async)
 import Control.Logger.Simple
 import Control.Monad.IO.Unlift
 import Crypto.Random
-import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Time.Clock (getCurrentTime)
@@ -25,6 +24,7 @@ import Numeric.Natural
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
@@ -33,7 +33,7 @@ import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ATransport)
+import Simplex.Messaging.Transport (ATransport, THandleParams)
 import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
 import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
@@ -60,6 +60,7 @@ data NtfServerConfig = NtfServerConfig
     logStatsStartTime :: Int64,
     serverStatsLogFile :: FilePath,
     serverStatsBackupFile :: Maybe FilePath,
+    ntfServerVRange :: VersionRangeNTF,
     transportConfig :: TransportServerConfig
   }
 
@@ -89,7 +90,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
   logInfo "restoring subscriptions..."
   storeLog <- liftIO $ mapM (`readWriteNtfStore` store) storeLogFile
   logInfo "restored subscriptions"
-  subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg
+  subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg random
   pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
   tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
   Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
@@ -102,11 +103,11 @@ data NtfSubscriber = NtfSubscriber
     smpAgent :: SMPClientAgent
   }
 
-newNtfSubscriber :: Natural -> SMPClientAgentConfig -> STM NtfSubscriber
-newNtfSubscriber qSize smpAgentCfg = do
+newNtfSubscriber :: Natural -> SMPClientAgentConfig -> TVar ChaChaDRG -> STM NtfSubscriber
+newNtfSubscriber qSize smpAgentCfg random = do
   smpSubscribers <- TM.empty
   newSubQ <- newTBQueue qSize
-  smpAgent <- newSMPClientAgent smpAgentCfg
+  smpAgent <- newSMPClientAgent smpAgentCfg random
   pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent}
 
 data SMPSubscriber = SMPSubscriber
@@ -142,7 +143,9 @@ newNtfPushServer qSize apnsConfig = do
 
 newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
 newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
-  c <- apnsPushProviderClient <$> createAPNSPushClient (apnsProviderHost pp) apnsConfig
+  c <- case apnsProviderHost pp of
+    Nothing -> pure $ \_ _ -> pure ()
+    Just host -> apnsPushProviderClient <$> createAPNSPushClient host apnsConfig
   atomically $ TM.insert pp c pushClients
   pure c
 
@@ -158,17 +161,17 @@ data NtfRequest
 data NtfServerClient = NtfServerClient
   { rcvQ :: TBQueue NtfRequest,
     sndQ :: TBQueue (Transmission NtfResponse),
-    sessionId :: ByteString,
+    ntfThParams :: THandleParams NTFVersion,
     connected :: TVar Bool,
     rcvActiveAt :: TVar SystemTime,
     sndActiveAt :: TVar SystemTime
   }
 
-newNtfServerClient :: Natural -> ByteString -> SystemTime -> STM NtfServerClient
-newNtfServerClient qSize sessionId ts = do
+newNtfServerClient :: Natural -> THandleParams NTFVersion -> SystemTime -> STM NtfServerClient
+newNtfServerClient qSize ntfThParams ts = do
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
   connected <- newTVar True
   rcvActiveAt <- newTVar ts
   sndActiveAt <- newTVar ts
-  return NtfServerClient {rcvQ, sndQ, sessionId, connected, rcvActiveAt, sndActiveAt}
+  return NtfServerClient {rcvQ, sndQ, ntfThParams, connected, rcvActiveAt, sndActiveAt}

src/Simplex/Messaging/Notifications/Server/Main.hs

@@ -19,9 +19,11 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Server (runNtfServer)
 import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
 import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
+import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
 import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
@@ -29,9 +31,6 @@ import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 import Text.Read (readMaybe)
 
-ntfServerVersion :: String
-ntfServerVersion = "1.7.2.0"
-
 defaultSMPBatchDelay :: Int
 defaultSMPBatchDelay = 10000
 
@@ -42,6 +41,10 @@ ntfServerCLI cfgPath logPath =
       doesFileExist iniFile >>= \case
         True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
         _ -> initializeServer opts
+    OnlineCert certOpts ->
+      doesFileExist iniFile >>= \case
+        True -> genOnline cfgPath certOpts
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
     Start ->
       doesFileExist iniFile >>= \case
         True -> readIniFile iniFile >>= either exitError runServer
@@ -53,7 +56,7 @@ ntfServerCLI cfgPath logPath =
       putStrLn "Deleted configuration and log files"
   where
     iniFile = combine cfgPath "ntf-server.ini"
-    serverVersion = "SMP notifications server v" <> ntfServerVersion
+    serverVersion = "SMP notifications server v" <> simplexMQVersion
     defaultServerPort = "443"
     executableName = "ntf-server"
     storeLogFilePath = combine logPath "ntf-server-store.log"
@@ -135,6 +138,7 @@ ntfServerCLI cfgPath logPath =
               logStatsStartTime = 0, -- seconds from 00:00 UTC
               serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log",
+              ntfServerVRange = supportedServerNTFVRange,
               transportConfig =
                 defaultTransportServerConfig
                   { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
@@ -143,6 +147,7 @@ ntfServerCLI cfgPath logPath =
 
 data CliCommand
   = Init InitOptions
+  | OnlineCert CertOptions
   | Start
   | Delete
 
@@ -158,6 +163,7 @@ cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
 cliCommandP cfgPath logPath iniFile =
   hsubparser
     ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
+        <> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")"))
         <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
     )

src/Simplex/Messaging/Notifications/Server/Push/APNS.hs

@@ -27,8 +27,9 @@ import Data.Aeson (ToJSON, (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.TH as JQ
+import Data.Base64.Types (extractBase64)
 import Data.Bifunctor (first)
-import qualified Data.ByteString.Base64.URL as U
+import qualified Data.ByteString.Base64.URL as UP
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -46,6 +47,7 @@ import Network.HTTP2.Client (Request)
 import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
@@ -91,8 +93,8 @@ signedJWTToken pk (JWTToken hdr claims) = do
   pure $ hc <> "." <> serialize sig
   where
     jwtEncode :: ToJSON a => a -> ByteString
-    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
-    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
+    jwtEncode = extractBase64 . UP.encodeBase64Unpadded' . LB.toStrict . J.encode
+    serialize sig = extractBase64 . UP.encodeBase64Unpadded' $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
 
 readECPrivateKey :: FilePath -> IO EC.PrivateKey
 readECPrivateKey f = do
@@ -193,11 +195,12 @@ data APNSPushClientConfig = APNSPushClientConfig
     caStoreFile :: FilePath
   }
 
-apnsProviderHost :: PushProvider -> HostName
+apnsProviderHost :: PushProvider -> Maybe HostName
 apnsProviderHost = \case
-  PPApnsTest -> "localhost"
-  PPApnsDev -> "api.sandbox.push.apple.com"
-  PPApnsProd -> "api.push.apple.com"
+  PPApnsNull -> Nothing
+  PPApnsTest -> Just "localhost"
+  PPApnsDev -> Just "api.sandbox.push.apple.com"
+  PPApnsProd -> Just "api.push.apple.com"
 
 defaultAPNSPushClientConfig :: APNSPushClientConfig
 defaultAPNSPushClientConfig =

src/Simplex/Messaging/Notifications/Server/Store.hs

@@ -19,7 +19,7 @@ import qualified Data.Set as S
 import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Protocol (NtfPrivateSignKey, SMPServer)
+import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (whenM, ($>>=))
@@ -46,7 +46,7 @@ data NtfTknData = NtfTknData
   { ntfTknId :: NtfTokenId,
     token :: DeviceToken,
     tknStatus :: TVar NtfTknStatus,
-    tknVerifyKey :: C.APublicVerifyKey,
+    tknVerifyKey :: NtfPublicAuthKey,
     tknDhKeys :: C.KeyPair 'C.X25519,
     tknDhSecret :: C.DhSecretX25519,
     tknRegCode :: NtfRegCode,
@@ -62,7 +62,7 @@ mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tkn
 data NtfSubData = NtfSubData
   { ntfSubId :: NtfSubscriptionId,
     smpQueue :: SMPQueueNtf,
-    notifierKey :: NtfPrivateSignKey,
+    notifierKey :: NtfPrivateAuthKey,
     tokenId :: NtfTokenId,
     subStatus :: TVar NtfSubStatus
   }

src/Simplex/Messaging/Notifications/Server/StoreLog.hs

@@ -32,7 +32,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store
-import Simplex.Messaging.Protocol (NtfPrivateSignKey)
+import Simplex.Messaging.Protocol (NtfPrivateAuthKey)
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Util (whenM)
 import System.Directory (doesFileExist, renameFile)
@@ -52,7 +52,7 @@ data NtfTknRec = NtfTknRec
   { ntfTknId :: NtfTokenId,
     token :: DeviceToken,
     tknStatus :: NtfTknStatus,
-    tknVerifyKey :: C.APublicVerifyKey,
+    tknVerifyKey :: C.APublicAuthKey,
     tknDhKeys :: C.KeyPair 'C.X25519,
     tknDhSecret :: C.DhSecretX25519,
     tknRegCode :: NtfRegCode,
@@ -74,7 +74,7 @@ mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKey
 data NtfSubRec = NtfSubRec
   { ntfSubId :: NtfSubscriptionId,
     smpQueue :: SMPQueueNtf,
-    notifierKey :: NtfPrivateSignKey,
+    notifierKey :: NtfPrivateAuthKey,
     tokenId :: NtfTokenId,
     subStatus :: NtfSubStatus
   }

src/Simplex/Messaging/Notifications/Transport.hs

@@ -1,72 +1,155 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Notifications.Transport where
 
+import Control.Monad (forM)
 import Control.Monad.Except
+import Data.Attoparsec.ByteString.Char8 (Parser)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Word (Word16)
+import qualified Data.X509 as X
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Version
+import Simplex.Messaging.Version.Internal
+import Simplex.Messaging.Util (liftEitherWith)
 
 ntfBlockSize :: Int
 ntfBlockSize = 512
 
-supportedNTFServerVRange :: VersionRange
-supportedNTFServerVRange = mkVersionRange 1 1
+data NTFVersion
+
+instance VersionScope NTFVersion
+
+type VersionNTF = Version NTFVersion
+
+type VersionRangeNTF = VersionRange NTFVersion
+
+pattern VersionNTF :: Word16 -> VersionNTF
+pattern VersionNTF v = Version v
+
+initialNTFVersion :: VersionNTF
+initialNTFVersion = VersionNTF 1
+
+authBatchCmdsNTFVersion :: VersionNTF
+authBatchCmdsNTFVersion = VersionNTF 2
+
+currentClientNTFVersion :: VersionNTF
+currentClientNTFVersion = VersionNTF 1
+
+currentServerNTFVersion :: VersionNTF
+currentServerNTFVersion = VersionNTF 1
+
+supportedClientNTFVRange :: VersionRangeNTF
+supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion
+
+supportedServerNTFVRange :: VersionRangeNTF
+supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion
+
+type THandleNTF c = THandle NTFVersion c
 
 data NtfServerHandshake = NtfServerHandshake
-  { ntfVersionRange :: VersionRange,
-    sessionId :: SessionId
+  { ntfVersionRange :: VersionRangeNTF,
+    sessionId :: SessionId,
+    -- pub key to agree shared secrets for command authorization and entity ID encryption.
+    authPubKey :: Maybe (X.SignedExact X.PubKey)
   }
 
 data NtfClientHandshake = NtfClientHandshake
   { -- | agreed SMP notifications server protocol version
-    ntfVersion :: Version,
+    ntfVersion :: VersionNTF,
     -- | server identity - CA certificate fingerprint
-    keyHash :: C.KeyHash
+    keyHash :: C.KeyHash,
+    -- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
+    authPubKey :: Maybe C.PublicKeyX25519
   }
 
 instance Encoding NtfServerHandshake where
-  smpEncode NtfServerHandshake {ntfVersionRange, sessionId} =
-    smpEncode (ntfVersionRange, sessionId)
+  smpEncode NtfServerHandshake {ntfVersionRange, sessionId, authPubKey} =
+    B.concat
+      [ smpEncode (ntfVersionRange, sessionId),
+        encodeAuthEncryptCmds (maxVersion ntfVersionRange) $ C.SignedObject <$> authPubKey
+      ]
+
   smpP = do
     (ntfVersionRange, sessionId) <- smpP
-    pure NtfServerHandshake {ntfVersionRange, sessionId}
+    -- TODO drop SMP v6: remove special parser and make key non-optional
+    authPubKey <- authEncryptCmdsP (maxVersion ntfVersionRange) $ C.getSignedExact <$> smpP
+    pure NtfServerHandshake {ntfVersionRange, sessionId, authPubKey}
+
+encodeAuthEncryptCmds :: Encoding a => VersionNTF -> Maybe a -> ByteString
+encodeAuthEncryptCmds v k
+  | v >= authBatchCmdsNTFVersion = maybe "" smpEncode k
+  | otherwise = ""
+
+authEncryptCmdsP :: VersionNTF -> Parser a -> Parser (Maybe a)
+authEncryptCmdsP v p = if v >= authBatchCmdsNTFVersion then Just <$> p else pure Nothing
 
 instance Encoding NtfClientHandshake where
-  smpEncode NtfClientHandshake {ntfVersion, keyHash} = smpEncode (ntfVersion, keyHash)
+  smpEncode NtfClientHandshake {ntfVersion, keyHash, authPubKey} =
+    smpEncode (ntfVersion, keyHash) <> encodeNtfAuthPubKey ntfVersion authPubKey
   smpP = do
     (ntfVersion, keyHash) <- smpP
-    pure NtfClientHandshake {ntfVersion, keyHash}
+    -- TODO drop SMP v6: remove special parser and make key non-optional
+    authPubKey <- ntfAuthPubKeyP ntfVersion
+    pure NtfClientHandshake {ntfVersion, keyHash, authPubKey}
+
+ntfAuthPubKeyP :: VersionNTF -> Parser (Maybe C.PublicKeyX25519)
+ntfAuthPubKeyP v = if v >= authBatchCmdsNTFVersion then Just <$> smpP else pure Nothing
+
+encodeNtfAuthPubKey :: VersionNTF -> Maybe C.PublicKeyX25519 -> ByteString
+encodeNtfAuthPubKey v k
+  | v >= authBatchCmdsNTFVersion = maybe "" smpEncode k
+  | otherwise = ""
 
 -- | Notifcations server transport handshake.
-ntfServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-ntfServerHandshake c kh ntfVRange = do
-  let th@THandle {sessionId} = ntfTHandle c
-  sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange}
+ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c)
+ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
+  let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
+  let sk = C.signX509 serverSignKey $ C.publicToX509 k
+  sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange, authPubKey = Just sk}
   getHandshake th >>= \case
-    NtfClientHandshake {ntfVersion, keyHash}
+    NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = k'}
       | keyHash /= kh ->
           throwError $ TEHandshake IDENTITY
-      | ntfVersion `isCompatible` ntfVRange ->
-          pure (th :: THandle c) {thVersion = ntfVersion}
+      | v `isCompatible` ntfVRange ->
+          pure $ ntfThHandle th v pk k'
       | otherwise -> throwError $ TEHandshake VERSION
 
 -- | Notifcations server client transport handshake.
-ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-ntfClientHandshake c keyHash ntfVRange = do
-  let th@THandle {sessionId} = ntfTHandle c
-  NtfServerHandshake {sessionId = sessId, ntfVersionRange} <- getHandshake th
+ntfClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c)
+ntfClientHandshake c (k, pk) keyHash ntfVRange = do
+  let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
+  NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
   if sessionId /= sessId
     then throwError TEBadSession
     else case ntfVersionRange `compatibleVersion` ntfVRange of
-      Just (Compatible ntfVersion) -> do
-        sendHandshake th $ NtfClientHandshake {ntfVersion, keyHash}
-        pure (th :: THandle c) {thVersion = ntfVersion}
+      Just (Compatible v) -> do
+        sk_ <- forM sk' $ \exact -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
+          serverKey <- getServerVerifyKey c
+          pubKey <- C.verifyX509 serverKey exact
+          C.x509ToPublic (pubKey, []) >>= C.pubKey
+        sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = Just k}
+        pure $ ntfThHandle th v pk sk_
       Nothing -> throwError $ TEHandshake VERSION
 
-ntfTHandle :: Transport c => c -> THandle c
-ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, batch = False}
+ntfThHandle :: forall c. THandleNTF c -> VersionNTF -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleNTF c
+ntfThHandle th@THandle {params} v privKey k_ =
+  -- TODO drop SMP v6: make thAuth non-optional
+  let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
+      v3 = v >= authBatchCmdsNTFVersion
+      params' = params {thVersion = v, thAuth, implySessId = v3, batch = v3}
+   in (th :: THandleNTF c) {params = params'}
+
+ntfTHandle :: Transport c => c -> THandleNTF c
+ntfTHandle c = THandle {connection = c, params}
+  where
+    params = THandleParams {sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = VersionNTF 0, thAuth = Nothing, implySessId = False, batch = False}

src/Simplex/Messaging/Notifications/Types.hs

@@ -47,10 +47,11 @@ data NtfToken = NtfToken
   { deviceToken :: DeviceToken,
     ntfServer :: NtfServer,
     ntfTokenId :: Maybe NtfTokenId,
+    -- TODO combine keys to key pair as the types should match
     -- | key used by the ntf server to verify transmissions
-    ntfPubKey :: C.APublicVerifyKey,
+    ntfPubKey :: C.APublicAuthKey,
     -- | key used by the ntf client to sign transmissions
-    ntfPrivKey :: C.APrivateSignKey,
+    ntfPrivKey :: C.APrivateAuthKey,
     -- | client's DH keys (to repeat registration if necessary)
     ntfDhKeys :: C.KeyPair 'C.X25519,
     -- | shared DH secret used to encrypt/decrypt notifications e2e
@@ -63,7 +64,7 @@ data NtfToken = NtfToken
   }
   deriving (Show)
 
-newNtfToken :: DeviceToken -> NtfServer -> C.ASignatureKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken
+newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken
 newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode =
   NtfToken
     { deviceToken,

src/Simplex/Messaging/Parsers.hs

@@ -10,10 +10,9 @@ import qualified Data.Aeson as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
-import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (isAlphaNum, toLower)
+import Data.Char (toLower)
 import Data.String
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -24,23 +23,8 @@ import Database.SQLite.Simple (ResultError (..), SQLData (..))
 import Database.SQLite.Simple.FromField (FieldParser, returnError)
 import Database.SQLite.Simple.Internal (Field (..))
 import Database.SQLite.Simple.Ok (Ok (Ok))
-import Simplex.Messaging.Util ((<$?>))
 import Text.Read (readMaybe)
 
-base64P :: Parser ByteString
-base64P = decode <$?> paddedBase64 rawBase64P
-
-paddedBase64 :: Parser ByteString -> Parser ByteString
-paddedBase64 raw = (<>) <$> raw <*> pad
-  where
-    pad = A.takeWhile (== '=')
-
-rawBase64P :: Parser ByteString
-rawBase64P = A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
-
--- rawBase64UriP :: Parser ByteString
--- rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')
-
 tsISO8601P :: Parser UTCTime
 tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill wordEnd
 

src/Simplex/Messaging/Protocol.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
@@ -46,6 +47,10 @@ module Simplex.Messaging.Protocol
     e2eEncMessageLength,
 
     -- * SMP protocol types
+    SMPClientVersion,
+    VersionSMPC,
+    VersionRangeSMPC,
+    pattern VersionSMPC,
     ProtocolEncoding (..),
     Command (..),
     SubscriptionMode (..),
@@ -59,6 +64,7 @@ module Simplex.Messaging.Protocol
     ErrorType (..),
     CommandError (..),
     Transmission,
+    TransmissionAuth (..),
     SignedTransmission,
     SentRawTransmission,
     SignedRawTransmission,
@@ -79,6 +85,7 @@ module Simplex.Messaging.Protocol
     SMPServerWithAuth,
     NtfServer,
     pattern NtfServer,
+    NtfServerWithAuth,
     XFTPServer,
     pattern XFTPServer,
     XFTPServerWithAuth,
@@ -92,14 +99,14 @@ module Simplex.Messaging.Protocol
     RecipientId,
     SenderId,
     NotifierId,
-    RcvPrivateSignKey,
-    RcvPublicVerifyKey,
+    RcvPrivateAuthKey,
+    RcvPublicAuthKey,
     RcvPublicDhKey,
     RcvDhSecret,
-    SndPrivateSignKey,
-    SndPublicVerifyKey,
-    NtfPrivateSignKey,
-    NtfPublicVerifyKey,
+    SndPrivateAuthKey,
+    SndPublicAuthKey,
+    NtfPrivateAuthKey,
+    NtfPublicAuthKey,
     RcvNtfPublicDhKey,
     RcvNtfDhSecret,
     Message (..),
@@ -115,6 +122,7 @@ module Simplex.Messaging.Protocol
     SMPMsgMeta (..),
     NMsgMeta (..),
     MsgFlags (..),
+    initialSMPClientVersion,
     userProtocol,
     rcvMessageMeta,
     noMsgFlags,
@@ -124,6 +132,8 @@ module Simplex.Messaging.Protocol
     -- * Parse and serialize
     ProtocolMsgTag (..),
     messageTagP,
+    TransmissionForAuth (..),
+    encodeTransmissionForAuth,
     encodeTransmission,
     transmissionP,
     _smpP,
@@ -132,6 +142,7 @@ module Simplex.Messaging.Protocol
     legacyEncodeServer,
     legacyServerP,
     legacyStrEncodeServer,
+    srvHostnamesSMPClientVersion,
     sameSrvAddr,
     sameSrvAddr',
     noAuthSrv,
@@ -147,6 +158,7 @@ module Simplex.Messaging.Protocol
     tEncodeBatch1,
     batchTransmissions,
     batchTransmissions',
+    batchTransmissions_,
 
     -- * exports for tests
     CommandTag (..),
@@ -155,11 +167,13 @@ module Simplex.Messaging.Protocol
 where
 
 import Control.Applicative (optional, (<|>))
+import Control.Monad
 import Control.Monad.Except
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser, (<?>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isPrint, isSpace)
@@ -172,22 +186,47 @@ import Data.Maybe (isJust, isNothing)
 import Data.String
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Type.Equality
+import Data.Word (Word16)
 import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
-import Network.Socket (HostName, ServiceName)
+import Network.Socket (ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
+import qualified Simplex.Messaging.Encoding.Base64 as B64
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
+import Simplex.Messaging.ServiceScheme
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
 import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>))
 import Simplex.Messaging.Version
+import Simplex.Messaging.Version.Internal
 
-currentSMPClientVersion :: Version
-currentSMPClientVersion = 2
+-- SMP client protocol version history:
+-- 1 - binary protocol encoding (1/1/2022)
+-- 2 - multiple server hostnames and versioned queue addresses (8/12/2022)
 
-supportedSMPClientVRange :: VersionRange
-supportedSMPClientVRange = mkVersionRange 1 currentSMPClientVersion
+data SMPClientVersion
+
+instance VersionScope SMPClientVersion
+
+type VersionSMPC = Version SMPClientVersion
+
+type VersionRangeSMPC = VersionRange SMPClientVersion
+
+pattern VersionSMPC :: Word16 -> VersionSMPC
+pattern VersionSMPC v = Version v
+
+initialSMPClientVersion :: VersionSMPC
+initialSMPClientVersion = VersionSMPC 1
+
+srvHostnamesSMPClientVersion :: VersionSMPC
+srvHostnamesSMPClientVersion = VersionSMPC 2
+
+currentSMPClientVersion :: VersionSMPC
+currentSMPClientVersion = VersionSMPC 2
+
+supportedSMPClientVRange :: VersionRangeSMPC
+supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClientVersion
 
 maxMessageLength :: Int
 maxMessageLength = 16088
@@ -239,14 +278,14 @@ deriving instance Show Cmd
 type Transmission c = (CorrId, EntityId, c)
 
 -- | signed parsed transmission, with original raw bytes and parsing error.
-type SignedTransmission e c = (Maybe C.ASignature, Signed, Transmission (Either e c))
+type SignedTransmission e c = (Maybe TransmissionAuth, Signed, Transmission (Either e c))
 
 type Signed = ByteString
 
 -- | unparsed SMP transmission with signature.
 data RawTransmission = RawTransmission
-  { signature :: ByteString,
-    signed :: ByteString,
+  { authenticator :: ByteString, -- signature or encrypted transmission hash
+    authorized :: ByteString, -- authorized transmission
     sessId :: SessionId,
     corrId :: ByteString,
     entityId :: ByteString,
@@ -254,11 +293,32 @@ data RawTransmission = RawTransmission
   }
   deriving (Show)
 
+data TransmissionAuth
+  = TASignature C.ASignature
+  | TAAuthenticator C.CbAuthenticator
+  deriving (Show)
+
+-- this encoding is backwards compatible with v6 that used Maybe C.ASignature instead of TAuthorization
+tAuthBytes :: Maybe TransmissionAuth -> ByteString
+tAuthBytes = \case
+  Nothing -> ""
+  Just (TASignature s) -> C.signatureBytes s
+  Just (TAAuthenticator (C.CbAuthenticator s)) -> s
+
+decodeTAuthBytes :: ByteString -> Either String (Maybe TransmissionAuth)
+decodeTAuthBytes s
+  | B.null s = Right Nothing
+  | B.length s == C.cbAuthenticatorSize = Right . Just . TAAuthenticator $ C.CbAuthenticator s
+  | otherwise = Just . TASignature <$> C.decodeSignature s
+
+instance IsString (Maybe TransmissionAuth) where
+  fromString = parseString $ B64.decode >=> C.decodeSignature >=> pure . fmap TASignature
+
 -- | unparsed sent SMP transmission with signature, without session ID.
-type SignedRawTransmission = (Maybe C.ASignature, SessionId, ByteString, ByteString)
+type SignedRawTransmission = (Maybe TransmissionAuth, SessionId, ByteString, ByteString)
 
 -- | unparsed sent SMP transmission with signature.
-type SentRawTransmission = (Maybe C.ASignature, ByteString)
+type SentRawTransmission = (Maybe TransmissionAuth, ByteString)
 
 -- | SMP queue ID for the recipient.
 type RecipientId = QueueId
@@ -277,10 +337,14 @@ type EntityId = ByteString
 -- | Parameterized type for SMP protocol commands from all clients.
 data Command (p :: Party) where
   -- SMP recipient commands
-  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> Command Recipient
+  -- RcvPublicAuthKey is the key used for command authorization:
+  -- 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
   SUB :: Command Recipient
-  KEY :: SndPublicVerifyKey -> Command Recipient
-  NKEY :: NtfPublicVerifyKey -> RcvNtfPublicDhKey -> Command Recipient
+  KEY :: SndPublicAuthKey -> Command Recipient
+  NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
   NDEL :: Command Recipient
   GET :: Command Recipient
   -- ACK v1 has to be supported for encoding/decoding
@@ -298,8 +362,6 @@ data Command (p :: Party) where
 
 deriving instance Show (Command p)
 
-deriving instance Eq (Command p)
-
 data SubscriptionMode = SMSubscribe | SMOnlyCreate
   deriving (Eq, Show)
 
@@ -339,8 +401,6 @@ data BrokerMsg where
 
 data RcvMessage = RcvMessage
   { msgId :: MsgId,
-    msgTs :: SystemTime,
-    msgFlags :: MsgFlags,
     msgBody :: EncRcvMsgBody -- e2e encrypted, with extra encryption for recipient
   }
   deriving (Eq, Show)
@@ -368,21 +428,6 @@ messageTs = \case
   Message {msgTs} -> msgTs
   MessageQuota {msgTs} -> msgTs
 
-instance StrEncoding RcvMessage where
-  strEncode RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} =
-    B.unwords
-      [ strEncode msgId,
-        strEncode msgTs,
-        "flags=" <> strEncode msgFlags,
-        strEncode body
-      ]
-  strP = do
-    msgId <- strP_
-    msgTs <- strP_
-    msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
-    msgBody <- EncRcvMsgBody <$> strP
-    pure RcvMessage {msgId, msgTs, msgFlags, msgBody}
-
 newtype EncRcvMsgBody = EncRcvMsgBody ByteString
   deriving (Eq, Show)
 
@@ -621,7 +666,7 @@ data ClientMsgEnvelope = ClientMsgEnvelope
   deriving (Show)
 
 data PubHeader = PubHeader
-  { phVersion :: Version,
+  { phVersion :: VersionSMPC,
     phE2ePubDhKey :: Maybe C.PublicKeyX25519
   }
   deriving (Show)
@@ -640,7 +685,7 @@ instance Encoding ClientMsgEnvelope where
 data ClientMessage = ClientMessage PrivHeader ByteString
 
 data PrivHeader
-  = PHConfirmation C.APublicVerifyKey
+  = PHConfirmation C.APublicAuthKey
   | PHEmpty
   deriving (Show)
 
@@ -674,6 +719,8 @@ pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
 
 {-# COMPLETE NtfServer #-}
 
+type NtfServerWithAuth = ProtoServerWithAuth 'PNTF
+
 type XFTPServer = ProtocolServer 'PXFTP
 
 pattern XFTPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PXFTP
@@ -719,11 +766,11 @@ deriving instance Show (SProtocolType p)
 
 data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)
 
-deriving instance Show AProtocolType
-
 instance Eq AProtocolType where
   AProtocolType p == AProtocolType p' = isJust $ testEquality p p'
 
+deriving instance Show AProtocolType
+
 instance TestEquality SProtocolType where
   testEquality SPSMP SPSMP = Just Refl
   testEquality SPNTF SPNTF = Just Refl
@@ -915,16 +962,6 @@ serverStrP = do
   where
     portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
 
-data SrvLoc = SrvLoc HostName ServiceName
-  deriving (Eq, Ord, Show)
-
-instance StrEncoding SrvLoc where
-  strEncode (SrvLoc host port) = B.pack $ host <> if null port then "" else ':' : port
-  strP = SrvLoc <$> host <*> (port <|> pure "")
-    where
-      host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
-      port = show <$> (A.char ':' *> (A.decimal :: Parser Int))
-
 -- | Transmission correlation ID.
 newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
 
@@ -951,13 +988,13 @@ data QueueIdsKeys = QIK
   }
   deriving (Eq, Show)
 
--- | Recipient's private key used by the recipient to authorize (sign) SMP commands.
+-- | Recipient's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands.
 --
 -- Only used by SMP agent, kept here so its definition is close to respective public key.
-type RcvPrivateSignKey = C.APrivateSignKey
+type RcvPrivateAuthKey = C.APrivateAuthKey
 
 -- | Recipient's public key used by SMP server to verify authorization of SMP commands.
-type RcvPublicVerifyKey = C.APublicVerifyKey
+type RcvPublicAuthKey = C.APublicAuthKey
 
 -- | Public key used for DH exchange to encrypt message bodies from server to recipient
 type RcvPublicDhKey = C.PublicKeyX25519
@@ -965,19 +1002,19 @@ type RcvPublicDhKey = C.PublicKeyX25519
 -- | DH Secret used to encrypt message bodies from server to recipient
 type RcvDhSecret = C.DhSecretX25519
 
--- | Sender's private key used by the recipient to authorize (sign) SMP commands.
+-- | Sender's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands.
 --
 -- Only used by SMP agent, kept here so its definition is close to respective public key.
-type SndPrivateSignKey = C.APrivateSignKey
+type SndPrivateAuthKey = C.APrivateAuthKey
 
 -- | Sender's public key used by SMP server to verify authorization of SMP commands.
-type SndPublicVerifyKey = C.APublicVerifyKey
+type SndPublicAuthKey = C.APublicAuthKey
 
--- | Private key used by push notifications server to authorize (sign) NSUB command.
-type NtfPrivateSignKey = C.APrivateSignKey
+-- | Private key used by push notifications server to authorize (sign or encrypt hash) NSUB command.
+type NtfPrivateAuthKey = C.APrivateAuthKey
 
 -- | Public key used by SMP server to verify authorization of NSUB command sent by push notifications server.
-type NtfPublicVerifyKey = C.APublicVerifyKey
+type NtfPublicAuthKey = C.APublicAuthKey
 
 -- | Public key used for DH exchange to encrypt notification metadata from server to recipient
 type RcvNtfPublicDhKey = C.PublicKeyX25519
@@ -1038,29 +1075,30 @@ data CommandError
   deriving (Eq, Read, Show)
 
 -- | SMP transmission parser.
-transmissionP :: Parser RawTransmission
-transmissionP = do
-  signature <- smpP
-  signed <- A.takeByteString
-  either fail pure $ parseAll (trn signature signed) signed
+transmissionP :: THandleParams v -> Parser RawTransmission
+transmissionP THandleParams {sessionId, implySessId} = do
+  authenticator <- smpP
+  authorized <- A.takeByteString
+  either fail pure $ parseAll (trn authenticator authorized) authorized
   where
-    trn signature signed = do
-      sessId <- smpP
+    trn authenticator authorized = do
+      sessId <- if implySessId then pure "" else smpP
+      let authorized' = if implySessId then smpEncode sessionId <> authorized else authorized
       corrId <- smpP
       entityId <- smpP
       command <- A.takeByteString
-      pure RawTransmission {signature, signed, sessId, corrId, entityId, command}
+      pure RawTransmission {authenticator, authorized = authorized', sessId, corrId, entityId, command}
 
-class (ProtocolEncoding err msg, ProtocolEncoding err (ProtoCommand msg), Show err, Show msg) => Protocol err msg | msg -> err where
+class (ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err  where
   type ProtoCommand msg = cmd | cmd -> msg
   type ProtoType msg = (sch :: ProtocolType) | sch -> msg
-  protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
+  protocolClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c)
   protocolPing :: ProtoCommand msg
   protocolError :: msg -> Maybe err
 
 type ProtoServer msg = ProtocolServer (ProtoType msg)
 
-instance Protocol ErrorType BrokerMsg where
+instance Protocol SMPVersion ErrorType BrokerMsg where
   type ProtoCommand BrokerMsg = Cmd
   type ProtoType BrokerMsg = 'PSMP
   protocolClientHandshake = smpClientHandshake
@@ -1069,19 +1107,19 @@ instance Protocol ErrorType BrokerMsg where
     ERR e -> Just e
     _ -> Nothing
 
-class ProtocolMsgTag (Tag msg) => ProtocolEncoding err msg | msg -> err where
+class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg -> v where
   type Tag msg
-  encodeProtocol :: Version -> msg -> ByteString
-  protocolP :: Version -> Tag msg -> Parser msg
+  encodeProtocol :: Version v -> msg -> ByteString
+  protocolP :: Version v -> Tag msg -> Parser msg
   fromProtocolError :: ProtocolErrorType -> err
   checkCredentials :: SignedRawTransmission -> msg -> Either err msg
 
-instance PartyI p => ProtocolEncoding ErrorType (Command p) where
+instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
   type Tag (Command p) = CommandTag p
   encodeProtocol v = \case
     NEW rKey dhKey auth_ subMode
-      | v >= 6 -> new <> auth <> e subMode
-      | v == 5 -> new <> auth
+      | v >= subModeSMPVersion -> new <> auth <> e subMode
+      | v == basicAuthSMPVersion -> new <> auth
       | otherwise -> new
       where
         new = e (NEW_, ' ', rKey, dhKey)
@@ -1091,14 +1129,10 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where
     NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
     NDEL -> e NDEL_
     GET -> e GET_
-    ACK msgId
-      | v == 1 -> e ACK_
-      | otherwise -> e (ACK_, ' ', msgId)
+    ACK msgId -> e (ACK_, ' ', msgId)
     OFF -> e OFF_
     DEL -> e DEL_
-    SEND flags msg
-      | v == 1 -> e (SEND_, ' ', Tail msg)
-      | otherwise -> e (SEND_, ' ', flags, ' ', Tail msg)
+    SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg)
     PING -> e PING_
     NSUB -> e NSUB_
     where
@@ -1107,13 +1141,13 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where
 
   protocolP v tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP v (CT (sParty @p) tag)
 
-  fromProtocolError = fromProtocolError @ErrorType @BrokerMsg
+  fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
   {-# INLINE fromProtocolError #-}
 
-  checkCredentials (sig, _, queueId, _) cmd = case cmd of
+  checkCredentials (auth, _, queueId, _) cmd = case cmd of
     -- NEW must have signature but NOT queue ID
     NEW {}
-      | isNothing sig -> Left $ CMD NO_AUTH
+      | isNothing auth -> Left $ CMD NO_AUTH
       | not (B.null queueId) -> Left $ CMD HAS_AUTH
       | otherwise -> Right cmd
     -- SEND must have queue ID, signature is not always required
@@ -1122,14 +1156,14 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where
       | otherwise -> Right cmd
     -- PING must not have queue ID or signature
     PING
-      | isNothing sig && B.null queueId -> Right cmd
+      | isNothing auth && B.null queueId -> Right cmd
       | otherwise -> Left $ CMD HAS_AUTH
     -- other client commands must have both signature and queue ID
     _
-      | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH
+      | isNothing auth || B.null queueId -> Left $ CMD NO_AUTH
       | otherwise -> Right cmd
 
-instance ProtocolEncoding ErrorType Cmd where
+instance ProtocolEncoding SMPVersion ErrorType Cmd where
   type Tag Cmd = CmdTag
   encodeProtocol v (Cmd _ c) = encodeProtocol v c
 
@@ -1137,8 +1171,8 @@ instance ProtocolEncoding ErrorType Cmd where
     CT SRecipient tag ->
       Cmd SRecipient <$> case tag of
         NEW_
-          | v >= 6 -> new <*> auth <*> smpP
-          | v == 5 -> new <*> auth <*> pure SMSubscribe
+          | v >= subModeSMPVersion -> new <*> auth <*> smpP
+          | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe
           | otherwise -> new <*> pure Nothing <*> pure SMSubscribe
           where
             new = NEW <$> _smpP <*> smpP
@@ -1148,32 +1182,26 @@ instance ProtocolEncoding ErrorType Cmd where
         NKEY_ -> NKEY <$> _smpP <*> smpP
         NDEL_ -> pure NDEL
         GET_ -> pure GET
-        ACK_
-          | v == 1 -> pure $ ACK ""
-          | otherwise -> ACK <$> _smpP
+        ACK_ -> ACK <$> _smpP
         OFF_ -> pure OFF
         DEL_ -> pure DEL
     CT SSender tag ->
       Cmd SSender <$> case tag of
-        SEND_
-          | v == 1 -> SEND noMsgFlags <$> (unTail <$> _smpP)
-          | otherwise -> SEND <$> _smpP <*> (unTail <$> _smpP)
+        SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP)
         PING_ -> pure PING
     CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
 
-  fromProtocolError = fromProtocolError @ErrorType @BrokerMsg
+  fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
   {-# INLINE fromProtocolError #-}
 
   checkCredentials t (Cmd p c) = Cmd p <$> checkCredentials t c
 
-instance ProtocolEncoding ErrorType BrokerMsg where
+instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
   type Tag BrokerMsg = BrokerMsgTag
-  encodeProtocol v = \case
+  encodeProtocol _v = \case
     IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
-    MSG RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body}
-      | v == 1 -> e (MSG_, ' ', msgId, msgTs, Tail body)
-      | v == 2 -> e (MSG_, ' ', msgId, msgTs, msgFlags, ' ', Tail body)
-      | otherwise -> e (MSG_, ' ', msgId, Tail body)
+    MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} ->
+      e (MSG_, ' ', msgId, Tail body)
     NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
     NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta)
     END -> e END_
@@ -1184,13 +1212,10 @@ instance ProtocolEncoding ErrorType BrokerMsg where
       e :: Encoding a => a -> ByteString
       e = smpEncode
 
-  protocolP v = \case
+  protocolP _v = \case
     MSG_ -> do
       msgId <- _smpP
-      MSG <$> case v of
-        1 -> RcvMessage msgId <$> smpP <*> pure noMsgFlags <*> bodyP
-        2 -> RcvMessage msgId <$> smpP <*> smpP <*> (A.space *> bodyP)
-        _ -> RcvMessage msgId (MkSystemTime 0 0) noMsgFlags <$> bodyP
+      MSG . RcvMessage msgId <$> bodyP
       where
         bodyP = EncRcvMsgBody . unTail <$> smpP
     IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP)
@@ -1223,12 +1248,12 @@ instance ProtocolEncoding ErrorType BrokerMsg where
       | otherwise -> Right cmd
 
 -- | Parse SMP protocol commands and broker messages
-parseProtocol :: forall err msg. ProtocolEncoding err msg => Version -> ByteString -> Either err msg
+parseProtocol :: forall v err msg. ProtocolEncoding v err msg => Version v -> ByteString -> Either err msg
 parseProtocol v s =
   let (tag, params) = B.break (== ' ') s
    in case decodeTag tag of
-        Just cmd -> parse (protocolP v cmd) (fromProtocolError @err @msg $ PECmdSyntax) params
-        Nothing -> Left $ fromProtocolError @err @msg $ PECmdUnknown
+        Just cmd -> parse (protocolP v cmd) (fromProtocolError @v @err @msg $ PECmdSyntax) params
+        Nothing -> Left $ fromProtocolError @v @err @msg $ PECmdUnknown
 
 checkParty :: forall t p p'. (PartyI p, PartyI p') => t p' -> Either String (t p)
 checkParty c = case testEquality (sParty @p) (sParty @p') of
@@ -1283,16 +1308,16 @@ instance Encoding CommandError where
       _ -> fail "bad command error type"
 
 -- | Send signed SMP transmission to TCP transport.
-tPut :: Transport c => THandle c -> NonEmpty SentRawTransmission -> IO [Either TransportError ()]
-tPut th = fmap concat . mapM tPutBatch . batchTransmissions (batch th) (blockSize th)
+tPut :: Transport c => THandle v c -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
+tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (batch params) (blockSize params)
   where
     tPutBatch :: TransportBatch () -> IO [Either TransportError ()]
     tPutBatch = \case
-      TBLargeTransmission _ -> [Left TELargeMsg] <$ putStrLn "tPut error: large message"
-      TBTransmissions s n _ -> replicate n <$> (tPutLog th s)
+      TBError e _ -> [Left e] <$ putStrLn "tPut error: large message"
+      TBTransmissions s n _ -> replicate n <$> tPutLog th s
       TBTransmission s _ -> (: []) <$> tPutLog th s
 
-tPutLog :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
+tPutLog :: Transport c => THandle v c -> ByteString -> IO (Either TransportError ())
 tPutLog th s = do
   r <- tPutBlock th s
   case r of
@@ -1301,42 +1326,50 @@ tPutLog th s = do
   pure r
 
 -- ByteString in TBTransmissions includes byte with transmissions count
-data TransportBatch r = TBTransmissions ByteString Int [r] | TBTransmission ByteString r | TBLargeTransmission r
+data TransportBatch r = TBTransmissions ByteString Int [r] | TBTransmission ByteString r | TBError TransportError r
 
-batchTransmissions :: Bool -> Int -> NonEmpty SentRawTransmission -> [TransportBatch ()]
+batchTransmissions :: Bool -> Int -> NonEmpty (Either TransportError SentRawTransmission) -> [TransportBatch ()]
 batchTransmissions batch bSize = batchTransmissions' batch bSize . L.map (,())
 
--- | encodes and batches transmissions into blocks,
-batchTransmissions' :: forall r. Bool -> Int -> NonEmpty (SentRawTransmission, r) -> [TransportBatch r]
-batchTransmissions' batch bSize
-  | batch = addBatch . foldr addTransmission ([], 0, 0, [], [])
-  | otherwise = map mkBatch1 . L.toList
+-- | encodes and batches transmissions into blocks
+batchTransmissions' :: forall r. Bool -> Int -> NonEmpty (Either TransportError SentRawTransmission, r) -> [TransportBatch r]
+batchTransmissions' batch bSize ts
+  | batch = batchTransmissions_ bSize $ L.map (first $ fmap tEncodeForBatch) ts
+  | otherwise = map mkBatch1 $ L.toList ts
+  where
+    mkBatch1 :: (Either TransportError SentRawTransmission, r) -> TransportBatch r
+    mkBatch1 (t_, r) = case t_ of
+      Left e -> TBError e r
+      Right t
+        -- 2 bytes are reserved for pad size
+        | B.length s <= bSize - 2 -> TBTransmission s r
+        | otherwise -> TBError TELargeMsg r
+        where
+          s = tEncode t
+
+-- | Pack encoded transmissions into batches
+batchTransmissions_ :: Int -> NonEmpty (Either TransportError ByteString, r) -> [TransportBatch r]
+batchTransmissions_ bSize = addBatch . foldr addTransmission ([], 0, 0, [], [])
   where
-    mkBatch1 :: (SentRawTransmission, r) -> TransportBatch r
-    mkBatch1 (t, r)
-      -- 2 bytes are reserved for pad size
-      | B.length s <= bSize - 2 = TBTransmission s r
-      | otherwise = TBLargeTransmission r
-      where
-        s = tEncode t
     -- 3 = 2 bytes reserved for pad size + 1 for transmission count
     bSize' = bSize - 3
-    addTransmission :: (SentRawTransmission, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r])
-    addTransmission (t, r) acc@(bs, len, n, ss, rs)
-      | len' <= bSize' && n < 255 = (bs, len', 1 + n, s : ss, r : rs)
-      | sLen <= bSize' = (addBatch acc, sLen, 1, [s], [r])
-      | otherwise = (TBLargeTransmission r : addBatch acc, 0, 0, [], [])
-      where
-        s = tEncodeForBatch t
-        sLen = B.length s
-        len' = len + sLen
+    addTransmission :: (Either TransportError ByteString, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r])
+    addTransmission (t_, r) acc@(bs, !len, !n, ss, rs) = case t_ of
+      Left e -> (TBError e r : addBatch acc, 0, 0, [], [])
+      Right s
+        | len' <= bSize' && n < 255 -> (bs, len', 1 + n, s : ss, r : rs)
+        | sLen <= bSize' -> (addBatch acc, sLen, 1, [s], [r])
+        | otherwise -> (TBError TELargeMsg r : addBatch acc, 0, 0, [], [])
+        where
+          sLen = B.length s
+          len' = len + sLen
     addBatch :: ([TransportBatch r], Int, Int, [ByteString], [r]) -> [TransportBatch r]
     addBatch (bs, _len, n, ss, rs) = if n == 0 then bs else TBTransmissions b n rs : bs
       where
         b = B.concat $ B.singleton (lenEncode n) : ss
 
 tEncode :: SentRawTransmission -> ByteString
-tEncode (sig, t) = smpEncode (C.signatureBytes sig) <> t
+tEncode (auth, t) = smpEncode (tAuthBytes auth) <> t
 {-# INLINE tEncode #-}
 
 tEncodeForBatch :: SentRawTransmission -> ByteString
@@ -1347,46 +1380,64 @@ tEncodeBatch1 :: SentRawTransmission -> ByteString
 tEncodeBatch1 t = lenEncode 1 `B.cons` tEncodeForBatch t
 {-# INLINE tEncodeBatch1 #-}
 
-encodeTransmission :: ProtocolEncoding e c => Version -> ByteString -> Transmission c -> ByteString
-encodeTransmission v sessionId (CorrId corrId, queueId, command) =
-  smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command
+-- tForAuth is lazy to avoid computing it when there is no key to sign
+data TransmissionForAuth = TransmissionForAuth {tForAuth :: ~ByteString, tToSend :: ByteString}
+
+encodeTransmissionForAuth :: ProtocolEncoding v e c => THandleParams v -> Transmission c -> TransmissionForAuth
+encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId} t =
+  TransmissionForAuth {tForAuth, tToSend = if implySessId then t' else tForAuth}
+  where
+    tForAuth = smpEncode sessionId <> t'
+    t' = encodeTransmission_ v t
+{-# INLINE encodeTransmissionForAuth #-}
+
+encodeTransmission :: ProtocolEncoding v e c => THandleParams v -> Transmission c -> ByteString
+encodeTransmission THandleParams {thVersion = v, sessionId, implySessId} t =
+  if implySessId then t' else smpEncode sessionId <> t'
+  where
+    t' = encodeTransmission_ v t
 {-# INLINE encodeTransmission #-}
 
+encodeTransmission_ :: ProtocolEncoding v e c => Version v -> Transmission c -> ByteString
+encodeTransmission_ v (CorrId corrId, queueId, command) =
+  smpEncode (corrId, queueId) <> encodeProtocol v command
+{-# INLINE encodeTransmission_ #-}
+
 -- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
-tGetParse :: Transport c => THandle c -> IO (NonEmpty (Either TransportError RawTransmission))
-tGetParse th = eitherList (tParse $ batch th) <$> tGetBlock th
+tGetParse :: Transport c => THandle v c -> IO (NonEmpty (Either TransportError RawTransmission))
+tGetParse th@THandle {params} = eitherList (tParse params) <$> tGetBlock th
 {-# INLINE tGetParse #-}
 
-tParse :: Bool -> ByteString -> NonEmpty (Either TransportError RawTransmission)
-tParse batch s
+tParse :: THandleParams v -> ByteString -> NonEmpty (Either TransportError RawTransmission)
+tParse thParams@THandleParams {batch} s
   | batch = eitherList (L.map (\(Large t) -> tParse1 t)) ts
   | otherwise = [tParse1 s]
   where
-    tParse1 = parse transmissionP TEBadBlock
+    tParse1 = parse (transmissionP thParams) TEBadBlock
     ts = parse smpP TEBadBlock s
 
 eitherList :: (a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b)
 eitherList = either (\e -> [Left e])
 
 -- | Receive client and server transmissions (determined by `cmd` type).
-tGet :: forall err cmd c. (ProtocolEncoding err cmd, Transport c) => THandle c -> IO (NonEmpty (SignedTransmission err cmd))
-tGet th@THandle {sessionId, thVersion = v} = L.map (tDecodeParseValidate sessionId v) <$> tGetParse th
+tGet :: forall v err cmd c. (ProtocolEncoding v err cmd, Transport c) => THandle v c -> IO (NonEmpty (SignedTransmission err cmd))
+tGet th@THandle {params} = L.map (tDecodeParseValidate params) <$> tGetParse th
 
-tDecodeParseValidate :: forall err cmd. ProtocolEncoding err cmd => SessionId -> Version -> Either TransportError RawTransmission -> SignedTransmission err cmd
-tDecodeParseValidate sessionId v = \case
-  Right RawTransmission {signature, signed, sessId, corrId, entityId, command}
-    | sessId == sessionId ->
-        let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
-         in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
-    | otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PESession))
+tDecodeParseValidate :: forall v err cmd. ProtocolEncoding v err cmd => THandleParams v -> Either TransportError RawTransmission -> SignedTransmission err cmd
+tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \case
+  Right RawTransmission {authenticator, authorized, sessId, corrId, entityId, command}
+    | implySessId || sessId == sessionId ->
+        let decodedTransmission = (,corrId,entityId,command) <$> decodeTAuthBytes authenticator
+         in either (const $ tError corrId) (tParseValidate authorized) decodedTransmission
+    | otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PESession))
   Left _ -> tError ""
   where
     tError :: ByteString -> SignedTransmission err cmd
-    tError corrId = (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PEBlock))
+    tError corrId = (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PEBlock))
 
     tParseValidate :: ByteString -> SignedRawTransmission -> SignedTransmission err cmd
     tParseValidate signed t@(sig, corrId, entityId, command) =
-      let cmd = parseProtocol @err @cmd v command >>= checkCredentials t
+      let cmd = parseProtocol @v @err @cmd v command >>= checkCredentials t
        in (sig, signed, (CorrId corrId, entityId, cmd))
 
 $(J.deriveJSON defaultJSON ''MsgFlags)

src/Simplex/Messaging/Server.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- |
 -- Module      : Simplex.Messaging.Server
@@ -31,7 +32,7 @@ module Simplex.Messaging.Server
   ( runSMPServer,
     runSMPServerBlocking,
     disconnectTransport,
-    verifyCmdSignature,
+    verifyCmdAuthorization,
     dummyVerifyCmd,
     randomId,
   )
@@ -44,12 +45,12 @@ import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
 import Data.Bifunctor (first)
-import Data.ByteString.Base64 (encode)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
 import Data.Int (Int64)
+import qualified Data.IntMap.Strict as IM
 import Data.List (intercalate)
 import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
@@ -66,6 +67,7 @@ import Network.Socket (ServiceName, Socket, socketToHandle)
 import Simplex.Messaging.Agent.Lock
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding (Encoding (smpEncode))
+import Simplex.Messaging.Encoding.Base64 (encode)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Control
@@ -132,7 +134,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
       ss <- asks sockets
-      runTransportServerState ss started tcpPort serverParams tCfg (runClient t)
+      serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams
+      runTransportServerState ss started tcpPort serverParams tCfg (runClient serverSignKey t)
+    fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
 
     saveServer :: Bool -> M ()
     saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats
@@ -157,7 +161,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
         updateSubscribers = do
           (qId, clnt) <- readTQueue $ subQ s
           let clientToBeNotified c' =
-                if sameClientSession clnt c'
+                if sameClientId clnt c'
                   then pure Nothing
                   else do
                     yes <- readTVar $ connected c'
@@ -165,9 +169,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
           TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified
         endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s)
         endPreviousSubscriptions (qId, c) = do
-          void . forkIO $ do
+          tId <- atomically $ stateTVar (endThreadSeq c) $ \next -> (next, next + 1)
+          t <- forkIO $ do
             labelMyThread $ label <> ".endPreviousSubscriptions"
             atomically $ writeTBQueue (sndQ c) [(CorrId "", qId, END)]
+            atomically $ modifyTVar' (endThreads c) $ IM.delete tId
+          mkWeakThreadId t >>= atomically . modifyTVar' (endThreads c) . IM.insert tId
           atomically $ TM.lookupDelete qId (clientSubs c)
 
     expireMessagesThread_ :: ServerConfig -> [M ()]
@@ -201,7 +208,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, qDeleted, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats
+      ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats
       let interval = 1000000 * logInterval
       forever $ do
         withFile statsFilePath AppendMode $ \h -> liftIO $ do
@@ -210,7 +217,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
           fromTime' <- atomically $ swapTVar fromTime ts
           qCreated' <- atomically $ swapTVar qCreated 0
           qSecured' <- atomically $ swapTVar qSecured 0
-          qDeleted' <- atomically $ swapTVar qDeleted 0
+          qDeletedAll' <- atomically $ swapTVar qDeletedAll 0
+          qDeletedNew' <- atomically $ swapTVar qDeletedNew 0
+          qDeletedSecured' <- atomically $ swapTVar qDeletedSecured 0
           msgSent' <- atomically $ swapTVar msgSent 0
           msgRecv' <- atomically $ swapTVar msgRecv 0
           msgExpired' <- atomically $ swapTVar msgExpired 0
@@ -226,7 +235,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
               [ iso8601Show $ utctDay fromTime',
                 show qCreated',
                 show qSecured',
-                show qDeleted',
+                show qDeletedAll',
                 show msgSent',
                 show msgRecv',
                 dayCount ps,
@@ -239,16 +248,19 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
                 monthCount psNtf,
                 show qCount',
                 show msgCount',
-                show msgExpired'
+                show msgExpired',
+                show qDeletedNew',
+                show qDeletedSecured'
               ]
         liftIO $ threadDelay' interval
 
-    runClient :: Transport c => TProxy c -> c -> M ()
-    runClient tp h = do
+    runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
+    runClient signKey tp h = do
       kh <- asks serverIdentity
+      ks <- atomically . C.generateKeyPair =<< asks random
       ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config
       labelMyThread $ "smp handshake for " <> transportName tp
-      liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake h kh smpServerVRange) >>= \case
+      liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake signKey h ks kh smpServerVRange) >>= \case
         Just (Right th) -> runClientTransport th
         _ -> pure ()
 
@@ -272,21 +284,36 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
           hSetBuffering h LineBuffering
           hSetNewlineMode h universalNewlineMode
           hPutStrLn h "SMP server control port\n'help' for supported commands"
-          cpLoop h
+          role <- newTVarIO CPRNone
+          cpLoop h role
           where
-            cpLoop h = do
-              s <- B.hGetLine h
-              case strDecode $ trimCR s of
+            cpLoop h role = do
+              s <- trimCR <$> B.hGetLine h
+              case strDecode s of
                 Right CPQuit -> hClose h
-                Right cmd -> processCP h cmd >> cpLoop h
-                Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h
-            processCP h = \case
-              CPSuspend -> hPutStrLn h "suspend not implemented"
-              CPResume -> hPutStrLn h "resume not implemented"
-              CPClients -> do
+                Right cmd -> logCmd s cmd >> processCP h role cmd >> cpLoop h role
+                Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h role
+            logCmd s cmd = when shouldLog $ logWarn $ "ControlPort: " <> tshow s
+              where
+                shouldLog = case cmd of
+                  CPAuth _ -> False
+                  CPHelp -> False
+                  CPQuit -> False
+                  CPSkip -> False
+                  _ -> True
+            processCP h role = \case
+              CPAuth auth -> atomically $ writeTVar role $! newRole cfg
+                where
+                  newRole ServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
+                    | Just auth == admin = CPRAdmin
+                    | Just auth == user = CPRUser
+                    | otherwise = CPRNone
+              CPSuspend -> withAdminRole $ hPutStrLn h "suspend not implemented"
+              CPResume -> withAdminRole $ hPutStrLn h "resume not implemented"
+              CPClients -> withAdminRole $ do
                 active <- unliftIO u (asks clients) >>= readTVarIO
                 hPutStrLn h $ "clientId,sessionId,connected,createdAt,rcvActiveAt,sndActiveAt,age,subscriptions"
-                forM_ (M.toList active) $ \(cid, Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions}) -> do
+                forM_ (IM.toList active) $ \(cid, Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions}) -> do
                   connected' <- bshow <$> readTVarIO connected
                   rcvActiveAt' <- strEncode <$> readTVarIO rcvActiveAt
                   sndActiveAt' <- strEncode <$> readTVarIO sndActiveAt
@@ -294,12 +321,14 @@ 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 -> do
-                ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, msgSentNtf, msgRecvNtf, qCount, msgCount} <- unliftIO u $ asks serverStats
+              CPStats -> withAdminRole $ do
+                ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgSentNtf, msgRecvNtf, qCount, msgCount} <- unliftIO u $ asks serverStats
                 putStat "fromTime" fromTime
                 putStat "qCreated" qCreated
                 putStat "qSecured" qSecured
-                putStat "qDeleted" qDeleted
+                putStat "qDeletedAll" qDeletedAll
+                putStat "qDeletedNew" qDeletedNew
+                putStat "qDeletedSecured" qDeletedSecured
                 putStat "msgSent" msgSent
                 putStat "msgRecv" msgRecv
                 putStat "msgSentNtf" msgSentNtf
@@ -310,7 +339,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
                   putStat :: Show a => String -> TVar a -> IO ()
                   putStat label var = readTVarIO var >>= \v -> hPutStrLn h $ label <> ": " <> show v
               CPStatsRTS -> getRTSStats >>= hPrint h
-              CPThreads -> do
+              CPThreads -> withAdminRole $ do
 #if MIN_VERSION_base(4,18,0)
                 threads <- liftIO listThreads
                 hPutStrLn h $ "Threads: " <> show (length threads)
@@ -321,19 +350,19 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
 #else
                 hPutStrLn h "Not available on GHC 8.10"
 #endif
-              CPSockets -> do
+              CPSockets -> withAdminRole $ do
                 (accepted', closed', active') <- unliftIO u $ asks sockets
                 (accepted, closed, active) <- atomically $ (,,) <$> readTVar accepted' <*> readTVar closed' <*> readTVar active'
                 hPutStrLn h "Sockets: "
                 hPutStrLn h $ "accepted: " <> show accepted
                 hPutStrLn h $ "closed: " <> show closed
-                hPutStrLn h $ "active: " <> show (M.size active)
-                hPutStrLn h $ "leaked: " <> show (accepted - closed - M.size active)
-              CPSocketThreads -> do
+                hPutStrLn h $ "active: " <> show (IM.size active)
+                hPutStrLn h $ "leaked: " <> show (accepted - closed - IM.size active)
+              CPSocketThreads -> withAdminRole $ do
 #if MIN_VERSION_base(4,18,0)
                 (_, _, active') <- unliftIO u $ asks sockets
                 active <- readTVarIO active'
-                forM_ (M.toList active) $ \(sid, tid') ->
+                forM_ (IM.toList active) $ \(sid, tid') ->
                   deRefWeak tid' >>= \case
                     Nothing -> hPutStrLn h $ intercalate "," [show sid, "", "gone", ""]
                     Just tid -> do
@@ -343,40 +372,50 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
 #else
                 hPutStrLn h "Not available on GHC 8.10"
 #endif
-              CPDelete queueId' -> unliftIO u $ do
+              CPDelete queueId' -> withUserRole $ unliftIO u $ do
                 st <- asks queueStore
                 ms <- asks msgStore
-                stats <- asks serverStats
                 queueId <- atomically (getQueue st SSender queueId') >>= \case
                   Left _ -> pure queueId' -- fallback to using as recipientId directly
                   Right QueueRec {recipientId} -> pure recipientId
                 r <- atomically $
-                  deleteQueue st queueId $>>= \() ->
-                    Right <$> delMsgQueueSize ms queueId
+                  deleteQueue st queueId $>>= \q ->
+                    Right . (q,) <$> delMsgQueueSize ms queueId
                 case r of
                   Left e -> liftIO . hPutStrLn h $ "error: " <> show e
-                  Right numDeleted -> do
+                  Right (q, numDeleted) -> do
                     withLog (`logDeleteQueue` queueId)
-                    atomically $ modifyTVar' (qDeleted stats) (+ 1)
-                    atomically $ modifyTVar' (qCount stats) (subtract 1)
+                    updateDeletedStats q
                     liftIO . hPutStrLn h $ "ok, " <> show numDeleted <> " messages deleted"
-              CPSave -> withLock (savingLock srv) "control" $ do
+              CPSave -> withAdminRole $ withLock (savingLock srv) "control" $ 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"
               CPQuit -> pure ()
               CPSkip -> pure ()
+              where
+                withUserRole action = readTVarIO role >>= \case
+                  CPRAdmin -> action
+                  CPRUser -> action
+                  _ -> do
+                    logError "Unauthorized control port command"
+                    hPutStrLn h "AUTH"
+                withAdminRole action = readTVarIO role >>= \case
+                  CPRAdmin -> action
+                  _ -> do
+                    logError "Unauthorized control port command"
+                    hPutStrLn h "AUTH"
 
-runClientTransport :: Transport c => THandle c -> M ()
-runClientTransport th@THandle {thVersion, sessionId} = do
+runClientTransport :: Transport c => THandleSMP c -> M ()
+runClientTransport th@THandle {params = THandleParams {thVersion, sessionId}} = do
   q <- asks $ tbqSize . config
   ts <- liftIO getSystemTime
   active <- asks clients
   nextClientId <- asks clientSeq
   c <- atomically $ do
     new@Client {clientId} <- newClient nextClientId q thVersion sessionId ts
-    TM.insert clientId new active
+    modifyTVar' active $ IM.insert clientId new
     pure new
   s <- asks server
   expCfg <- asks $ inactiveClientExpiration . config
@@ -389,23 +428,26 @@ runClientTransport th@THandle {thVersion, sessionId} = do
     noSubscriptions c = atomically $ (&&) <$> TM.null (subscriptions c) <*> TM.null (ntfSubscriptions c)
 
 clientDisconnected :: Client -> M ()
-clientDisconnected c@Client {clientId, subscriptions, connected, sessionId} = do
+clientDisconnected c@Client {clientId, subscriptions, connected, sessionId, endThreads} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disc"
-  atomically $ writeTVar connected False
-  subs <- readTVarIO subscriptions
+  subs <- atomically $ do
+    writeTVar connected False
+    swapTVar subscriptions M.empty
   liftIO $ mapM_ cancelSub subs
-  atomically $ writeTVar subscriptions M.empty
-  cs <- asks $ subscribers . server
-  atomically . mapM_ (\rId -> TM.update deleteCurrentClient rId cs) $ M.keys subs
-  asks clients >>= atomically . TM.delete clientId
+  srvSubs <- asks $ subscribers . server
+  atomically $ modifyTVar' srvSubs $ \cs ->
+    M.foldrWithKey (\sub _ -> M.update deleteCurrentClient sub) cs subs
+  asks clients >>= atomically . (`modifyTVar'` IM.delete clientId)
+  tIds <- atomically $ swapTVar endThreads IM.empty
+  liftIO $ mapM_ (mapM_ killThread <=< deRefWeak) tIds
   where
     deleteCurrentClient :: Client -> Maybe Client
     deleteCurrentClient c'
-      | sameClientSession c c' = Nothing
+      | sameClientId c c' = Nothing
       | otherwise = Just c'
 
-sameClientSession :: Client -> Client -> Bool
-sameClientSession Client {sessionId} Client {sessionId = s'} = sessionId == s'
+sameClientId :: Client -> Client -> Bool
+sameClientId Client {clientId} Client {clientId = cId'} = clientId == cId'
 
 cancelSub :: TVar Sub -> IO ()
 cancelSub sub =
@@ -413,8 +455,8 @@ cancelSub sub =
     Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
     _ -> return ()
 
-receive :: Transport c => THandle c -> Client -> M ()
-receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
+receive :: Transport c => THandleSMP c -> Client -> M ()
+receive th@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
   forever $ do
     ts <- L.toList <$> liftIO (tGet th)
@@ -424,22 +466,23 @@ receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
     write rcvQ $ snd as
   where
     cmdAction :: SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
-    cmdAction (sig, signed, (corrId, queueId, cmdOrError)) =
+    cmdAction (tAuth, authorized, (corrId, queueId, cmdOrError)) =
       case cmdOrError of
         Left e -> pure $ Left (corrId, queueId, ERR e)
-        Right cmd -> verified <$> verifyTransmission sig signed queueId cmd
+        Right cmd -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) tAuth authorized queueId cmd
           where
             verified = \case
               VRVerified qr -> Right (qr, (corrId, queueId, cmd))
               VRFailed -> Left (corrId, queueId, ERR AUTH)
     write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
 
-send :: Transport c => THandle c -> Client -> IO ()
-send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do
+send :: Transport c => THandleSMP c -> Client -> IO ()
+send h@THandle {params} Client {sndQ, sessionId, sndActiveAt} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
   forever $ do
     ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
-    void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
+    -- TODO we can authorize responses as well
+    void . liftIO . tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts
     atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
   where
     tOrder :: Transmission BrokerMsg -> Int
@@ -448,8 +491,8 @@ send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do
       NMSG {} -> 0
       _ -> 1
 
-disconnectTransport :: Transport c => THandle c -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
-disconnectTransport THandle {connection, sessionId} rcvActiveAt sndActiveAt expCfg noSubscriptions = do
+disconnectTransport :: Transport c => THandle v c -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
+disconnectTransport THandle {connection, params = THandleParams {sessionId}} rcvActiveAt sndActiveAt expCfg noSubscriptions = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disconnectTransport"
   loop
   where
@@ -463,44 +506,69 @@ disconnectTransport THandle {connection, sessionId} rcvActiveAt sndActiveAt expC
 
 data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
 
-verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult
-verifyTransmission sig_ signed queueId cmd =
+-- This function verifies queue command authorization, with the objective to have constant time between the three AUTH error scenarios:
+-- - the queue and party key exist, and the provided authorization has type matching queue key, but it is made with the different key.
+-- - the queue and party key exist, but the provided authorization has incorrect type.
+-- - the queue or party key do not exist.
+-- In all cases, the time of the verification should depend only on the provided authorization type,
+-- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result.
+verifyTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult
+verifyTransmission auth_ tAuth authorized queueId cmd =
   case cmd of
-    Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
-    Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
-    Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
+    Cmd 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
+    Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender
     Cmd SSender PING -> pure $ VRVerified Nothing
-    Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
+    -- NSUB will not be accepted without authorization
+    Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (Just q `verifiedWith`) (notifierKey <$> notifier q)) <$> get SNotifier
   where
-    verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult
-    verifyCmd party f = do
-      st <- asks queueStore
-      q_ <- atomically $ getQueue st party queueId
-      pure $ case q_ of
-        Right q -> Just q `verified` f q
-        _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
-    verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
-    verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
+    verify = verifyCmdAuthorization auth_ tAuth authorized
+    dummyVerify = verify (dummyAuthKey tAuth) `seq` VRFailed
+    verifyQueue :: (QueueRec -> VerificationResult) -> Either ErrorType QueueRec -> VerificationResult
+    verifyQueue = either (\_ -> dummyVerify)
     verified q cond = if cond then VRVerified q else VRFailed
+    verifiedWith q k = q `verified` verify k
+    get :: SParty p -> M (Either ErrorType QueueRec)
+    get party = do
+      st <- asks queueStore
+      atomically $ getQueue st party queueId
 
-verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
-verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
+verifyCmdAuthorization :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool
+verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth
   where
-    verify :: C.APublicVerifyKey -> C.ASignature -> Bool
-    verify (C.APublicVerifyKey a k) sig@(C.ASignature a' s) =
-      case (testEquality a a', C.signatureSize k == C.signatureSize s) of
-        (Just Refl, True) -> C.verify' k s signed
-        _ -> dummyVerifyCmd signed sig `seq` False
+    verify :: C.APublicAuthKey -> TransmissionAuth -> Bool
+    verify (C.APublicAuthKey a k) = \case
+      TASignature (C.ASignature a' s) -> case testEquality a a' of
+        Just Refl -> C.verify' k s authorized
+        _ -> C.verify' (dummySignKey a') s authorized `seq` False
+      TAAuthenticator s -> case a of
+        C.SX25519 -> verifyCmdAuth auth_ k s authorized
+        _ -> verifyCmdAuth auth_ dummyKeyX25519 s authorized `seq` False
 
-dummyVerifyCmd :: ByteString -> C.ASignature -> Bool
-dummyVerifyCmd signed (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed
+verifyCmdAuth :: Maybe (THandleAuth, C.CbNonce) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> Bool
+verifyCmdAuth auth_ k authenticator authorized = case auth_ of
+  Just (THandleAuth {privKey}, nonce) -> C.cbVerify k privKey nonce authenticator authorized
+  Nothing -> False
+
+dummyVerifyCmd :: Maybe (THandleAuth, C.CbNonce) -> ByteString -> TransmissionAuth -> Bool
+dummyVerifyCmd auth_ authorized = \case
+  TASignature (C.ASignature a s) -> C.verify' (dummySignKey a) s authorized
+  TAAuthenticator s -> verifyCmdAuth auth_ dummyKeyX25519 s authorized
 
 -- These dummy keys are used with `dummyVerify` function to mitigate timing attacks
 -- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes
-dummyPublicKey :: C.Signature a -> C.PublicKey a
-dummyPublicKey = \case
-  C.SignatureEd25519 _ -> dummyKeyEd25519
-  C.SignatureEd448 _ -> dummyKeyEd448
+dummySignKey :: C.SignatureAlgorithm a => C.SAlgorithm a -> C.PublicKey a
+dummySignKey = \case
+  C.SEd25519 -> dummyKeyEd25519
+  C.SEd448 -> dummyKeyEd448
+
+dummyAuthKey :: Maybe TransmissionAuth -> C.APublicAuthKey
+dummyAuthKey = \case
+  Just (TASignature (C.ASignature a _)) -> case a of
+    C.SEd25519 -> C.APublicAuthKey C.SEd25519 dummyKeyEd25519
+    C.SEd448 -> C.APublicAuthKey C.SEd448 dummyKeyEd448
+  _ -> C.APublicAuthKey C.SX25519 dummyKeyX25519
 
 dummyKeyEd25519 :: C.PublicKey 'C.Ed25519
 dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs="
@@ -508,8 +576,11 @@ dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs="
 dummyKeyEd448 :: C.PublicKey 'C.Ed448
 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
 
+dummyKeyX25519 :: C.PublicKey 'C.X25519
+dummyKeyX25519 = "MCowBQYDK2VuAyEA4JGSMYht18H4mas/jHeBwfcM7jLwNYJNOAhi2/g4RXg="
+
 client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
-client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Server {subscribedQ, ntfSubscribedQ, notifiers} = do
+client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Server {subscribedQ, ntfSubscribedQ, notifiers} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
   forever $
     atomically (readTBQueue rcvQ)
@@ -545,7 +616,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
             OFF -> suspendQueue_ st
             DEL -> delQueueAndMsgs st
       where
-        createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> SubscriptionMode -> m (Transmission BrokerMsg)
+        createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> m (Transmission BrokerMsg)
         createQueue st recipientKey dhKey subMode = time "NEW" $ do
           (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
           let rcvDhSecret = C.dh' dhKey privDhKey
@@ -593,14 +664,14 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
               n <- asks $ queueIdBytes . config
               liftM2 (,) (randomId n) (randomId n)
 
-        secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg)
+        secureQueue_ :: QueueStore -> SndPublicAuthKey -> m (Transmission BrokerMsg)
         secureQueue_ st sKey = time "KEY" $ do
           withLog $ \s -> logSecureQueue s queueId sKey
           stats <- asks serverStats
           atomically $ modifyTVar' (qSecured stats) (+ 1)
           atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
 
-        addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg)
+        addQueueNotifier_ :: QueueStore -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg)
         addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do
           (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
           let rcvNtfDhSecret = C.dh' dhKey privDhKey
@@ -724,7 +795,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
               Message {msgFlags} -> do
                 stats <- asks serverStats
                 atomically $ modifyTVar' (msgRecv stats) (+ 1)
-                atomically $ modifyTVar' (msgCount stats) (+ 1)
+                atomically $ modifyTVar' (msgCount stats) (subtract 1)
                 atomically $ updatePeriodStats (activeQueues stats) queueId
                 when (notification msgFlags) $ do
                   atomically $ modifyTVar' (msgRecvNtf stats) (+ 1)
@@ -752,7 +823,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
                           atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
                           atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
                         atomically $ modifyTVar' (msgSent stats) (+ 1)
-                        atomically $ modifyTVar' (msgCount stats) (subtract 1)
+                        atomically $ modifyTVar' (msgCount stats) (+ 1)
                         atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
                         pure ok
           where
@@ -823,17 +894,12 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
         time name = timed name queueId
 
         encryptMsg :: QueueRec -> Message -> RcvMessage
-        encryptMsg qr msg = case msg of
-          Message {msgFlags, msgBody}
-            | thVersion == 1 || thVersion == 2 -> encrypt msgFlags msgBody
-            | otherwise -> encrypt msgFlags $ encodeRcvMsgBody RcvMsgBody {msgTs = msgTs', msgFlags, msgBody}
-          MessageQuota {} ->
-            encrypt noMsgFlags $ encodeRcvMsgBody (RcvMsgQuota msgTs')
+        encryptMsg qr msg = encrypt . encodeRcvMsgBody $ case msg of
+          Message {msgFlags, msgBody} -> RcvMsgBody {msgTs = msgTs', msgFlags, msgBody}
+          MessageQuota {} -> RcvMsgQuota msgTs'
           where
-            encrypt :: KnownNat i => MsgFlags -> C.MaxLenBS i -> RcvMessage
-            encrypt msgFlags body =
-              let encBody = EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId') body
-               in RcvMessage msgId' msgTs' msgFlags encBody
+            encrypt :: KnownNat i => C.MaxLenBS i -> RcvMessage
+            encrypt body = RcvMessage msgId' . EncRcvMsgBody $ C.cbEncryptMaxLenBS (rcvDhSecret qr) (C.cbNonce msgId') body
             msgId' = messageId msg
             msgTs' = messageTs msg
 
@@ -850,13 +916,9 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
         delQueueAndMsgs st = do
           withLog (`logDeleteQueue` queueId)
           ms <- asks msgStore
-          stats <- asks serverStats
-          atomically $ modifyTVar' (qDeleted stats) (+ 1)
-          atomically $ modifyTVar' (qCount stats) (subtract 1)
-          atomically $
-            deleteQueue st queueId >>= \case
-              Left e -> pure $ err e
-              Right _ -> delMsgQueue ms queueId $> ok
+          atomically (deleteQueue st queueId $>>= \q -> delMsgQueue ms queueId $> Right q) >>= \case
+            Right q -> updateDeletedStats q $> ok
+            Left e -> pure $ err e
 
         ok :: Transmission BrokerMsg
         ok = (corrId, queueId, OK)
@@ -867,6 +929,14 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess
         okResp :: Either ErrorType () -> Transmission BrokerMsg
         okResp = either err $ const ok
 
+updateDeletedStats :: (MonadUnliftIO m, MonadReader Env m) => 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)
+
 withLog :: (MonadUnliftIO m, MonadReader Env m) => (StoreLog 'WriteMode -> IO a) -> m ()
 withLog action = do
   env <- ask
@@ -909,11 +979,10 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= \case
   where
     restoreMessages f = do
       logInfo $ "restoring messages from file " <> T.pack f
-      st <- asks queueStore
       ms <- asks msgStore
       quota <- asks $ msgQueueQuota . config
       old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch)
-      runExceptT (liftIO (B.readFile f) >>= foldM (\expired -> restoreMsg expired st ms quota old_) 0 . B.lines) >>= \case
+      runExceptT (liftIO (B.readFile f) >>= foldM (\expired -> restoreMsg expired ms quota old_) 0 . B.lines) >>= \case
         Left e -> do
           logError . T.pack $ "error restoring messages: " <> e
           liftIO exitFailure
@@ -922,14 +991,9 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= \case
           logInfo "messages restored"
           pure expired
       where
-        restoreMsg !expired st ms quota old_ s = do
-          r <- liftEither . first (msgErr "parsing") $ strDecode s
-          case r of
-            MLRv3 rId msg -> addToMsgQueue rId msg
-            MLRv1 rId encMsg -> do
-              qr <- liftEitherError (msgErr "queue unknown") . atomically $ getQueue st SRecipient rId
-              msg' <- updateMsgV1toV3 qr encMsg
-              addToMsgQueue rId msg'
+        restoreMsg !expired ms quota old_ s = do
+          MLRv3 rId msg <- liftEither . first (msgErr "parsing") $ strDecode s
+          addToMsgQueue rId msg
           where
             addToMsgQueue rId msg = do
               (isExpired, logFull) <- atomically $ do
@@ -941,10 +1005,6 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= \case
                   MessageQuota {} -> writeMsg q msg $> (False, False)
               when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg)
               pure $ if isExpired then expired + 1 else expired
-            updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do
-              let nonce = C.cbNonce msgId
-              msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body
-              pure Message {msgId, msgTs, msgFlags, msgBody}
             msgErr :: Show e => String -> e -> String
             msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s)
 

src/Simplex/Messaging/Server/CLI.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -10,6 +11,7 @@
 module Simplex.Messaging.Server.CLI where
 
 import Control.Monad
+import Data.ASN1.Types (asn1CharacterToString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Either (fromRight)
@@ -17,6 +19,8 @@ import Data.Ini (Ini, lookupValue)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
+import qualified Data.X509 as X
+import qualified Data.X509.File as XF
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (HostName, ServiceName)
 import Options.Applicative
@@ -27,12 +31,14 @@ import Simplex.Messaging.Transport.Server (loadFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (eitherToMaybe, whenM)
 import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
+import System.Environment (lookupEnv)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
 import System.IO (IOMode (..), hFlush, hGetLine, stdout, withFile)
 import System.Process (readCreateProcess, shell)
+import Text.Read (readMaybe)
 
-exitError :: String -> IO ()
+exitError :: String -> IO a
 exitError msg = putStrLn msg >> exitFailure
 
 confirmOrExit :: String -> IO ()
@@ -84,14 +90,18 @@ getCliCommand' cmdP version =
     versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
 
 createServerX509 :: FilePath -> X509Config -> IO ByteString
-createServerX509 cfgPath x509cfg = do
-  createOpensslCaConf
-  createOpensslServerConf
+createServerX509 = createServerX509_ True
+
+createServerX509_ :: Bool -> FilePath -> X509Config -> IO ByteString
+createServerX509_ createCA cfgPath x509cfg = do
   let alg = show $ signAlgorithm (x509cfg :: X509Config)
   -- CA certificate (identity/offline)
-  run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c caKeyFile
-  run $ "openssl req -new -x509 -days 999999 -config " <> c opensslCaConfFile <> " -extensions v3 -key " <> c caKeyFile <> " -out " <> c caCrtFile
+  when createCA $ do
+    createOpensslCaConf
+    run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c caKeyFile
+    run $ "openssl req -new -x509 -days 999999 -config " <> c opensslCaConfFile <> " -extensions v3 -key " <> c caKeyFile <> " -out " <> c caCrtFile
   -- server certificate (online)
+  createOpensslServerConf
   run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c serverKeyFile
   run $ "openssl req -new -config " <> c opensslServerConfFile <> " -reqexts v3 -key " <> c serverKeyFile <> " -out " <> c serverCsrFile
   run $ "openssl x509 -req -days 999999 -extfile " <> c opensslServerConfFile <> " -extensions v3 -in " <> c serverCsrFile <> " -CA " <> c caCrtFile <> " -CAkey " <> c caKeyFile <> " -CAcreateserial -out " <> c serverCrtFile
@@ -131,6 +141,59 @@ createServerX509 cfgPath x509cfg = do
       withFile (c fingerprintFile) WriteMode (`B.hPutStrLn` strEncode fp)
       pure fp
 
+data CertOptions = CertOptions
+  { signAlgorithm_ :: Maybe SignAlgorithm,
+    commonName_ :: Maybe HostName
+  }
+  deriving (Show)
+
+certOptionsP :: Parser CertOptions
+certOptionsP = do
+  signAlgorithm_ <-
+    optional $
+      option
+        (maybeReader readMaybe)
+        ( long "sign-algorithm"
+            <> short 'a'
+            <> help "Set new signature algorithm used for TLS certificates: ED25519, ED448"
+            <> metavar "ALG"
+        )
+  commonName_ <-
+    optional $
+      strOption
+        ( long "cn"
+            <> help
+              "Set new Common Name for TLS online certificate"
+            <> metavar "FQDN"
+        )
+  pure CertOptions {signAlgorithm_, commonName_}
+
+genOnline :: FilePath -> CertOptions -> IO ()
+genOnline cfgPath CertOptions {signAlgorithm_, commonName_} = do
+  (signAlgorithm, commonName) <-
+    case (signAlgorithm_, commonName_) of
+      (Just alg, Just cn) -> pure (alg, cn)
+      _ ->
+        XF.readSignedObject certPath >>= \case
+          [old] -> either exitError pure . fromX509 . X.signedObject $ X.getSigned old
+          [] -> exitError $ "No certificate found at " <> certPath
+          _ -> exitError $ "Too many certificates at " <> certPath
+  let x509cfg = defaultX509Config {signAlgorithm, commonName}
+  void $ createServerX509_ False cfgPath x509cfg
+  putStrLn "Generated new server credentials"
+  warnCAPrivateKeyFile cfgPath x509cfg
+  where
+    certPath = combine cfgPath $ serverCrtFile defaultX509Config
+    fromX509 X.Certificate {certSignatureAlg, certSubjectDN} = (,) <$> maybe oldAlg Right signAlgorithm_ <*> maybe oldCN Right commonName_
+      where
+        oldAlg = case certSignatureAlg of
+          X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed448 -> Right ED448
+          X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed25519 -> Right ED25519
+          alg -> Left $ "Unexpected signature algorithm " <> show alg
+        oldCN = case X.getDnElement X.DnCommonName certSubjectDN of
+          Nothing -> Left "Certificate subject has no CN element"
+          Just cn -> maybe (Left "Certificate subject CN decoding failed") Right $ asn1CharacterToString cn
+
 warnCAPrivateKeyFile :: FilePath -> X509Config -> IO ()
 warnCAPrivateKeyFile cfgPath X509Config {caKeyFile} =
   putStrLn $
@@ -235,3 +298,6 @@ printServiceInfo serverVersion srv@(ProtoServerWithAuth ProtocolServer {keyHash}
 
 clearDirIfExists :: FilePath -> IO ()
 clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= mapM_ (removePathForcibly . combine path)
+
+getEnvPath :: String -> FilePath -> IO FilePath
+getEnvPath name def = maybe def (\case "" -> def; f -> f) <$> lookupEnv name

src/Simplex/Messaging/Server/Control.hs

@@ -6,9 +6,13 @@ module Simplex.Messaging.Server.Control where
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString (ByteString)
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol (BasicAuth)
+
+data CPClientRole = CPRNone | CPRUser | CPRAdmin
 
 data ControlProtocol
-  = CPSuspend
+  = CPAuth BasicAuth
+  | CPSuspend
   | CPResume
   | CPClients
   | CPStats
@@ -24,6 +28,7 @@ data ControlProtocol
 
 instance StrEncoding ControlProtocol where
   strEncode = \case
+    CPAuth bs -> "auth " <> strEncode bs
     CPSuspend -> "suspend"
     CPResume -> "resume"
     CPClients -> "clients"
@@ -39,6 +44,7 @@ instance StrEncoding ControlProtocol where
     CPSkip -> ""
   strP =
     A.takeTill (== ' ') >>= \case
+      "auth" -> CPAuth <$> (A.space *> strP)
       "suspend" -> pure CPSuspend
       "resume" -> pure CPResume
       "clients" -> pure CPClients

src/Simplex/Messaging/Server/Env/STM.hs

@@ -10,6 +10,8 @@ import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
+import Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IM
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
@@ -31,9 +33,8 @@ import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ATransport)
+import Simplex.Messaging.Transport (ATransport, VersionSMP, VersionRangeSMP)
 import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, loadFingerprint, loadTLSServerParams, newSocketState)
-import Simplex.Messaging.Version
 import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
@@ -52,6 +53,9 @@ data ServerConfig = ServerConfig
     allowNewQueues :: Bool,
     -- | simple password that the clients need to pass in handshake to be able to create new queues
     newQueueBasicAuth :: Maybe BasicAuth,
+    -- | control port passwords,
+    controlPortUserAuth :: Maybe BasicAuth,
+    controlPortAdminAuth :: Maybe BasicAuth,
     -- | time after which the messages can be removed from the queues and check interval, seconds
     messageExpiration :: Maybe ExpirationConfig,
     -- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),
@@ -71,7 +75,7 @@ data ServerConfig = ServerConfig
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
     -- | SMP client-server protocol version range
-    smpServerVRange :: VersionRange,
+    smpServerVRange :: VersionRangeSMP,
     -- | TCP transport config
     transportConfig :: TransportServerConfig,
     -- | run listener on control port
@@ -107,7 +111,7 @@ data Env = Env
     serverStats :: ServerStats,
     sockets :: SocketState,
     clientSeq :: TVar Int,
-    clients :: TMap Int Client
+    clients :: TVar (IntMap Client)
   }
 
 data Server = Server
@@ -124,7 +128,9 @@ data Client = Client
     ntfSubscriptions :: TMap NotifierId (),
     rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
     sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
-    thVersion :: Version,
+    endThreads :: TVar (IntMap (Weak ThreadId)),
+    endThreadSeq :: TVar Int,
+    thVersion :: VersionSMP,
     sessionId :: ByteString,
     connected :: TVar Bool,
     createdAt :: SystemTime,
@@ -148,17 +154,19 @@ newServer = do
   savingLock <- createLock
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock}
 
-newClient :: TVar Int -> Natural -> Version -> ByteString -> SystemTime -> STM Client
+newClient :: TVar Int -> Natural -> VersionSMP -> ByteString -> SystemTime -> STM Client
 newClient nextClientId qSize thVersion sessionId createdAt = do
   clientId <- stateTVar nextClientId $ \next -> (next, next + 1)
   subscriptions <- TM.empty
   ntfSubscriptions <- TM.empty
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize
+  endThreads <- newTVar IM.empty
+  endThreadSeq <- newTVar 0
   connected <- newTVar True
   rcvActiveAt <- newTVar createdAt
   sndActiveAt <- newTVar createdAt
-  return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt}
+  return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt}
 
 newSubscription :: SubscriptionThread -> STM Sub
 newSubscription subThread = do
@@ -178,7 +186,7 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
   serverStats <- atomically . newServerStats =<< liftIO getCurrentTime
   sockets <- atomically newSocketState
   clientSeq <- newTVarIO 0
-  clients <- atomically TM.empty
+  clients <- newTVarIO mempty
   return Env {config, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients}
   where
     restoreQueues :: QueueStore -> FilePath -> m (StoreLog 'WriteMode)

src/Simplex/Messaging/Server/Main.hs

@@ -25,7 +25,7 @@ import Simplex.Messaging.Server (runSMPServer)
 import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration)
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
+import Simplex.Messaging.Transport (simplexMQVersion, supportedServerSMPRelayVRange)
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
 import Simplex.Messaging.Util (safeDecodeUtf8)
@@ -41,6 +41,10 @@ smpServerCLI cfgPath logPath =
       doesFileExist iniFile >>= \case
         True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
         _ -> initializeServer opts
+    OnlineCert certOpts ->
+      doesFileExist iniFile >>= \case
+        True -> genOnline cfgPath certOpts
+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
     Start ->
       doesFileExist iniFile >>= \case
         True -> readIniFile iniFile >>= either exitError runServer
@@ -56,8 +60,8 @@ smpServerCLI cfgPath logPath =
     defaultServerPort = "5223"
     executableName = "smp-server"
     storeLogFilePath = combine logPath "smp-server-store.log"
-    initializeServer opts
-      | scripted opts = initialize opts
+    initializeServer opts@InitOptions {ip, fqdn, scripted}
+      | scripted = initialize opts
       | otherwise = do
           putStrLn "Use `smp-server init -h` for available options."
           void $ withPrompt "SMP server will be initialized (press Enter)" getLine
@@ -65,9 +69,9 @@ smpServerCLI cfgPath logPath =
           logStats <- onOffPrompt "Enable logging daily statistics" False
           putStrLn "Require a password to create new messaging queues?"
           password <- withPrompt "'r' for random (default), 'n' - no password, or enter password: " serverPassword
-          let host = fromMaybe (ip opts) (fqdn opts)
+          let host = fromMaybe ip fqdn
           host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine
-          initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn opts else Just host', password}
+          initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn else Just host', password}
       where
         serverPassword =
           getLine >>= \case
@@ -78,7 +82,7 @@ smpServerCLI cfgPath logPath =
               case strDecode $ encodeUtf8 $ T.pack s of
                 Right auth -> pure . Just $ ServerPassword auth
                 _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword
-        initialize InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password} = do
+        initialize InitOptions {enableStoreLog, logStats, signAlgorithm, password} = do
           clearDirIfExists cfgPath
           clearDirIfExists logPath
           createDirectoryIfMissing True cfgPath
@@ -124,6 +128,8 @@ smpServerCLI cfgPath logPath =
                       _ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
                    )
                 <> "\n\n\
+                   \# control_port_admin_password:\n\
+                   \# control_port_user_password:\n\
                    \[TRANSPORT]\n\
                    \# host is only used to print server address on start\n"
                 <> ("host: " <> host <> "\n")
@@ -185,6 +191,8 @@ smpServerCLI cfgPath logPath =
               -- allow creating new queues by default
               allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
               newQueueBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
+              controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini,
+              controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini,
               messageExpiration =
                 Just
                   defaultMessageExpiration
@@ -200,7 +208,7 @@ smpServerCLI cfgPath logPath =
               logStatsStartTime = 0, -- seconds from 00:00 UTC
               serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
-              smpServerVRange = supportedSMPServerVRange,
+              smpServerVRange = supportedServerSMPRelayVRange,
               transportConfig =
                 defaultTransportServerConfig
                   { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
@@ -210,6 +218,7 @@ smpServerCLI cfgPath logPath =
 
 data CliCommand
   = Init InitOptions
+  | OnlineCert CertOptions
   | Start
   | Delete
 
@@ -231,6 +240,7 @@ cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
 cliCommandP cfgPath logPath iniFile =
   hsubparser
     ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files"))
+        <> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")"))
         <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
     )
@@ -255,7 +265,7 @@ cliCommandP cfgPath logPath iniFile =
           ( long "sign-algorithm"
               <> short 'a'
               <> help "Signature algorithm used for TLS certificates: ED25519, ED448"
-              <> value ED448
+              <> value ED25519
               <> showDefault
               <> metavar "ALG"
           )
@@ -295,3 +305,4 @@ cliCommandP cfgPath logPath iniFile =
       pure InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password, scripted}
     parseBasicAuth :: ReadM ServerPassword
     parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
+

src/Simplex/Messaging/Server/MsgStore.hs

@@ -3,14 +3,11 @@
 
 module Simplex.Messaging.Server.MsgStore where
 
-import Control.Applicative ((<|>))
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (Message (..), RcvMessage (..), RecipientId)
+import Simplex.Messaging.Protocol (Message (..), RecipientId)
 
-data MsgLogRecord = MLRv3 RecipientId Message | MLRv1 RecipientId RcvMessage
+data MsgLogRecord = MLRv3 RecipientId Message
 
 instance StrEncoding MsgLogRecord where
-  strEncode = \case
-    MLRv3 rId msg -> strEncode (Str "v3", rId, msg)
-    MLRv1 rId msg -> strEncode (rId, msg)
-  strP = "v3 " *> (MLRv3 <$> strP_ <*> strP) <|> MLRv1 <$> strP_ <*> strP
+  strEncode (MLRv3 rId msg) = strEncode (Str "v3", rId, msg)
+  strP = "v3 " *> (MLRv3 <$> strP_ <*> strP)

src/Simplex/Messaging/Server/QueueStore.hs

@@ -10,21 +10,21 @@ import Simplex.Messaging.Protocol
 
 data QueueRec = QueueRec
   { recipientId :: !RecipientId,
-    recipientKey :: !RcvPublicVerifyKey,
+    recipientKey :: !RcvPublicAuthKey,
     rcvDhSecret :: !RcvDhSecret,
     senderId :: !SenderId,
-    senderKey :: !(Maybe SndPublicVerifyKey),
+    senderKey :: !(Maybe SndPublicAuthKey),
     notifier :: !(Maybe NtfCreds),
     status :: !ServerQueueStatus
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 data NtfCreds = NtfCreds
   { notifierId :: !NotifierId,
-    notifierKey :: !NtfPublicVerifyKey,
+    notifierKey :: !NtfPublicAuthKey,
     rcvNtfDhSecret :: !RcvNtfDhSecret
   }
-  deriving (Eq, Show)
+  deriving (Show)
 
 instance StrEncoding NtfCreds where
   strEncode NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} = strEncode (notifierId, notifierKey, rcvNtfDhSecret)

src/Simplex/Messaging/Server/QueueStore/STM.hs

@@ -63,7 +63,7 @@ getQueue QueueStore {queues, senders, notifiers} party qId =
       SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues)
       SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues)
 
-secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec)
+secureQueue :: QueueStore -> RecipientId -> SndPublicAuthKey -> STM (Either ErrorType QueueRec)
 secureQueue QueueStore {queues} rId sKey =
   withQueue rId queues $ \qVar ->
     readTVar qVar >>= \q -> case senderKey q of
@@ -94,14 +94,14 @@ suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
 suspendQueue QueueStore {queues} rId =
   withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
 
-deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
+deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType QueueRec)
 deleteQueue QueueStore {queues, senders, notifiers} rId = do
   TM.lookupDelete rId queues >>= \case
     Just qVar ->
       readTVar qVar >>= \q -> do
         TM.delete (senderId q) senders
         forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
-        pure $ Right ()
+        pure $ Right q
     _ -> pure $ Left AUTH
 
 toResult :: Maybe a -> Either ErrorType a

src/Simplex/Messaging/Server/Stats.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.Stats where
 
@@ -22,7 +23,9 @@ data ServerStats = ServerStats
   { fromTime :: TVar UTCTime,
     qCreated :: TVar Int,
     qSecured :: TVar Int,
-    qDeleted :: TVar Int,
+    qDeletedAll :: TVar Int,
+    qDeletedNew :: TVar Int,
+    qDeletedSecured :: TVar Int,
     msgSent :: TVar Int,
     msgRecv :: TVar Int,
     msgExpired :: TVar Int,
@@ -38,7 +41,9 @@ data ServerStatsData = ServerStatsData
   { _fromTime :: UTCTime,
     _qCreated :: Int,
     _qSecured :: Int,
-    _qDeleted :: Int,
+    _qDeletedAll :: Int,
+    _qDeletedNew :: Int,
+    _qDeletedSecured :: Int,
     _msgSent :: Int,
     _msgRecv :: Int,
     _msgExpired :: Int,
@@ -56,7 +61,9 @@ newServerStats ts = do
   fromTime <- newTVar ts
   qCreated <- newTVar 0
   qSecured <- newTVar 0
-  qDeleted <- newTVar 0
+  qDeletedAll <- newTVar 0
+  qDeletedNew <- newTVar 0
+  qDeletedSecured <- newTVar 0
   msgSent <- newTVar 0
   msgRecv <- newTVar 0
   msgExpired <- newTVar 0
@@ -66,14 +73,16 @@ newServerStats ts = do
   activeQueuesNtf <- newPeriodStats
   qCount <- newTVar 0
   msgCount <- newTVar 0
-  pure ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount}
+  pure ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount}
 
 getServerStatsData :: ServerStats -> STM ServerStatsData
 getServerStatsData s = do
   _fromTime <- readTVar $ fromTime s
   _qCreated <- readTVar $ qCreated s
   _qSecured <- readTVar $ qSecured s
-  _qDeleted <- readTVar $ qDeleted s
+  _qDeletedAll <- readTVar $ qDeletedAll s
+  _qDeletedNew <- readTVar $ qDeletedNew s
+  _qDeletedSecured <- readTVar $ qDeletedSecured s
   _msgSent <- readTVar $ msgSent s
   _msgRecv <- readTVar $ msgRecv s
   _msgExpired <- readTVar $ msgExpired s
@@ -83,14 +92,16 @@ getServerStatsData s = do
   _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
   _qCount <- readTVar $ qCount s
   _msgCount <- readTVar $ msgCount s
-  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgExpired, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _qCount, _msgCount}
+  pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _qCount, _msgCount}
 
 setServerStats :: ServerStats -> ServerStatsData -> STM ()
 setServerStats s d = do
   writeTVar (fromTime s) $! _fromTime d
   writeTVar (qCreated s) $! _qCreated d
   writeTVar (qSecured s) $! _qSecured d
-  writeTVar (qDeleted s) $! _qDeleted d
+  writeTVar (qDeletedAll s) $! _qDeletedAll d
+  writeTVar (qDeletedNew s) $! _qDeletedNew d
+  writeTVar (qDeletedSecured s) $! _qDeletedSecured d
   writeTVar (msgSent s) $! _msgSent d
   writeTVar (msgRecv s) $! _msgRecv d
   writeTVar (msgExpired s) $! _msgExpired d
@@ -102,12 +113,14 @@ setServerStats s d = do
   writeTVar (msgCount s) $! _msgCount d
 
 instance StrEncoding ServerStatsData where
-  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount} =
+  strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount} =
     B.unlines
       [ "fromTime=" <> strEncode _fromTime,
         "qCreated=" <> strEncode _qCreated,
         "qSecured=" <> strEncode _qSecured,
-        "qDeleted=" <> strEncode _qDeleted,
+        "qDeletedAll=" <> strEncode _qDeletedAll,
+        "qDeletedNew=" <> strEncode _qDeletedNew,
+        "qDeletedSecured=" <> strEncode _qDeletedSecured,
         "qCount=" <> strEncode _qCount,
         "msgSent=" <> strEncode _msgSent,
         "msgRecv=" <> strEncode _msgRecv,
@@ -123,7 +136,9 @@ instance StrEncoding ServerStatsData where
     _fromTime <- "fromTime=" *> strP <* A.endOfLine
     _qCreated <- "qCreated=" *> strP <* A.endOfLine
     _qSecured <- "qSecured=" *> strP <* A.endOfLine
-    _qDeleted <- "qDeleted=" *> strP <* A.endOfLine
+    (_qDeletedAll, _qDeletedNew, _qDeletedSecured) <-
+      (,0,0) <$> ("qDeleted=" *> strP <* A.endOfLine)
+        <|> ((,,) <$> ("qDeletedAll=" *> strP <* A.endOfLine) <*> ("qDeletedNew=" *> strP <* A.endOfLine) <*> ("qDeletedSecured=" *> strP <* A.endOfLine))
     _qCount <- "qCount=" *> strP <* A.endOfLine <|> pure 0
     _msgSent <- "msgSent=" *> strP <* A.endOfLine
     _msgRecv <- "msgRecv=" *> strP <* A.endOfLine
@@ -142,7 +157,7 @@ instance StrEncoding ServerStatsData where
       optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
         Just _ -> strP <* optional A.endOfLine
         _ -> pure newPeriodStatsData
-    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeleted, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount = 0}
+    pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount = 0}
 
 data PeriodStats a = PeriodStats
   { day :: TVar (Set a),

src/Simplex/Messaging/Server/StoreLog.hs

@@ -46,7 +46,7 @@ data StoreLog (a :: IOMode) where
 
 data StoreLogRecord
   = CreateQueue QueueRec
-  | SecureQueue QueueId SndPublicVerifyKey
+  | SecureQueue QueueId SndPublicAuthKey
   | AddNotifier QueueId NtfCreds
   | SuspendQueue QueueId
   | DeleteQueue QueueId
@@ -120,7 +120,7 @@ writeStoreLogRecord (WriteStoreLog _ h) r = do
 logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO ()
 logCreateQueue s = writeStoreLogRecord s . CreateQueue
 
-logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicVerifyKey -> IO ()
+logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO ()
 logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
 
 logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NtfCreds -> IO ()

src/Simplex/Messaging/ServiceScheme.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.ServiceScheme where
+
+import Control.Applicative ((<|>))
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.ByteString.Char8 as B
+import Data.Functor (($>))
+import Network.Socket (HostName, ServiceName)
+import Simplex.Messaging.Encoding.String (StrEncoding (..))
+
+data ServiceScheme = SSSimplex | SSAppServer SrvLoc
+  deriving (Eq, Show)
+
+instance StrEncoding ServiceScheme where
+  strEncode = \case
+    SSSimplex -> "simplex:"
+    SSAppServer srv -> "https://" <> strEncode srv
+  strP =
+    "simplex:" $> SSSimplex
+      <|> "https://" *> (SSAppServer <$> strP)
+
+data SrvLoc = SrvLoc HostName ServiceName
+  deriving (Eq, Ord, Show)
+
+instance StrEncoding SrvLoc where
+  strEncode (SrvLoc host port) = B.pack $ host <> if null port then "" else ':' : port
+  strP = SrvLoc <$> host <*> (port <|> pure "")
+    where
+      host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
+      port = show <$> (A.char ':' *> (A.decimal :: A.Parser Int))
+
+simplexChat :: ServiceScheme
+simplexChat = SSAppServer $ SrvLoc "simplex.chat" ""

src/Simplex/Messaging/Transport.hs

@@ -5,9 +5,11 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
@@ -26,7 +28,18 @@
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
 module Simplex.Messaging.Transport
   ( -- * SMP transport parameters
-    supportedSMPServerVRange,
+    SMPVersion,
+    VersionSMP,
+    VersionRangeSMP,
+    THandleSMP,
+    supportedClientSMPRelayVRange,
+    supportedServerSMPRelayVRange,
+    currentClientSMPRelayVersion,
+    currentServerSMPRelayVersion,
+    batchCmdsSMPVersion,
+    basicAuthSMPVersion,
+    subModeSMPVersion,
+    authCmdsSMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -36,6 +49,7 @@ module Simplex.Messaging.Transport
     TProxy (..),
     ATransport (..),
     TransportPeer (..),
+    getServerVerifyKey,
 
     -- * TLS Transport
     TLS (..),
@@ -47,6 +61,8 @@ module Simplex.Messaging.Transport
 
     -- * SMP transport
     THandle (..),
+    THandleParams (..),
+    THandleAuth (..),
     TransportError (..),
     HandshakeError (..),
     smpServerHandshake,
@@ -61,12 +77,13 @@ module Simplex.Messaging.Transport
 where
 
 import Control.Applicative ((<|>))
+import Control.Monad (forM)
 import Control.Monad.Except
 import Control.Monad.Trans.Except (throwE)
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Bifunctor (first)
+import Data.Bifunctor (bimap, first)
 import Data.Bitraversable (bimapM)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -74,6 +91,9 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Default (def)
 import Data.Functor (($>))
 import Data.Version (showVersion)
+import Data.Word (Word16)
+import qualified Data.X509 as X
+import qualified Data.X509.Validation as XV
 import GHC.IO.Handle.Internals (ioe_EOF)
 import Network.Socket
 import qualified Network.TLS as T
@@ -83,8 +103,9 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON)
 import Simplex.Messaging.Transport.Buffer
-import Simplex.Messaging.Util (bshow, catchAll, catchAll_)
+import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith)
 import Simplex.Messaging.Version
+import Simplex.Messaging.Version.Internal
 import UnliftIO.Exception (Exception)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
@@ -94,8 +115,51 @@ import UnliftIO.STM
 smpBlockSize :: Int
 smpBlockSize = 16384
 
-supportedSMPServerVRange :: VersionRange
-supportedSMPServerVRange = mkVersionRange 1 6
+-- SMP protocol version history:
+-- 1 - binary protocol encoding (1/1/2022)
+-- 2 - message flags (used to control notifications, 6/6/2022)
+-- 3 - encrypt message timestamp and flags together with the body when delivered to the recipient (7/5/2022)
+-- 4 - support command batching (7/17/2022)
+-- 5 - basic auth for SMP servers (11/12/2022)
+-- 6 - allow creating queues without subscribing (9/10/2023)
+-- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (2/3/2024)
+
+data SMPVersion
+
+instance VersionScope SMPVersion
+
+type VersionSMP = Version SMPVersion
+
+type VersionRangeSMP = VersionRange SMPVersion
+
+pattern VersionSMP :: Word16 -> VersionSMP
+pattern VersionSMP v = Version v
+
+batchCmdsSMPVersion :: VersionSMP
+batchCmdsSMPVersion = VersionSMP 4
+
+basicAuthSMPVersion :: VersionSMP
+basicAuthSMPVersion = VersionSMP 5
+
+subModeSMPVersion :: VersionSMP
+subModeSMPVersion = VersionSMP 6
+
+authCmdsSMPVersion :: VersionSMP
+authCmdsSMPVersion = VersionSMP 7
+
+currentClientSMPRelayVersion :: VersionSMP
+currentClientSMPRelayVersion = VersionSMP 6
+
+currentServerSMPRelayVersion :: VersionSMP
+currentServerSMPRelayVersion = VersionSMP 6
+
+-- minimal supported protocol version is 4
+-- TODO remove code that supports sending commands without batching
+supportedClientSMPRelayVRange :: VersionRangeSMP
+supportedClientSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentClientSMPRelayVersion
+
+supportedServerSMPRelayVRange :: VersionRangeSMP
+supportedServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion
 
 simplexMQVersion :: String
 simplexMQVersion = showVersion SMQ.version
@@ -118,10 +182,12 @@ class Transport c where
   transportConfig :: c -> TransportConfig
 
   -- | Upgrade server TLS context to connection (used in the server)
-  getServerConnection :: TransportConfig -> T.Context -> IO c
+  getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO c
 
   -- | Upgrade client TLS context to connection (used in the client)
-  getClientConnection :: TransportConfig -> T.Context -> IO c
+  getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO c
+
+  getServerCerts :: c -> X.CertificateChain
 
   -- | tls-unique channel binding per RFC5929
   tlsUnique :: c -> SessionId
@@ -149,6 +215,12 @@ data TProxy c = TProxy
 
 data ATransport = forall c. Transport c => ATransport (TProxy c)
 
+getServerVerifyKey :: Transport c => c -> Either String C.APublicVerifyKey
+getServerVerifyKey c =
+  case getServerCerts c of
+    X.CertificateChain (server : _ca) -> C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned server, []) >>= C.pubKey
+    _ -> Left "no certificate chain"
+
 -- * TLS Transport
 
 data TLS = TLS
@@ -156,6 +228,7 @@ data TLS = TLS
     tlsPeer :: TransportPeer,
     tlsUniq :: ByteString,
     tlsBuffer :: TBuffer,
+    tlsServerCerts :: X.CertificateChain,
     tlsTransportConfig :: TransportConfig
   }
 
@@ -168,12 +241,12 @@ connectTLS host_ TransportConfig {logTLSErrors} params sock =
     logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e
     host = maybe "" (\h -> " (" <> h <> ")") host_
 
-getTLS :: TransportPeer -> TransportConfig -> T.Context -> IO TLS
-getTLS tlsPeer cfg cxt = withTlsUnique tlsPeer cxt newTLS
+getTLS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO TLS
+getTLS tlsPeer cfg tlsServerCerts cxt = withTlsUnique tlsPeer cxt newTLS
   where
     newTLS tlsUniq = do
       tlsBuffer <- atomically newTBuffer
-      pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsPeer, tlsUniq, tlsBuffer}
+      pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer}
 
 withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c
 withTlsUnique peer cxt f =
@@ -208,6 +281,7 @@ instance Transport TLS where
   transportConfig = tlsTransportConfig
   getServerConnection = getTLS TServer
   getClientConnection = getTLS TClient
+  getServerCerts = tlsServerCerts
   tlsUnique = tlsUniq
   closeConnection tls = closeTLS $ tlsContext tls
 
@@ -231,45 +305,87 @@ instance Transport TLS where
 
 -- * SMP transport
 
--- | The handle for SMP encrypted transport connection over Transport .
-data THandle c = THandle
+-- | The handle for SMP encrypted transport connection over Transport.
+data THandle v c = THandle
   { connection :: c,
-    sessionId :: SessionId,
+    params :: THandleParams v
+  }
+
+type THandleSMP c = THandle SMPVersion c
+
+data THandleParams v = THandleParams
+  { sessionId :: SessionId,
     blockSize :: Int,
     -- | agreed server protocol version
-    thVersion :: Version,
+    thVersion :: Version v,
+    -- | peer public key for command authorization and shared secrets for entity ID encryption
+    thAuth :: Maybe THandleAuth,
+    -- | do NOT send session ID in transmission, but include it into signed message
+    -- based on protocol version
+    implySessId :: Bool,
     -- | send multiple transmissions in a single block
-    -- based on protocol and protocol version
+    -- based on protocol version
     batch :: Bool
   }
 
+data THandleAuth = THandleAuth
+  { peerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key
+    privKey :: C.PrivateKeyX25519 -- used to combine with peer's per-queue key (currently only in the server)
+  }
+
 -- | TLS-unique channel binding
 type SessionId = ByteString
 
 data ServerHandshake = ServerHandshake
-  { smpVersionRange :: VersionRange,
-    sessionId :: SessionId
+  { smpVersionRange :: VersionRangeSMP,
+    sessionId :: SessionId,
+    -- pub key to agree shared secrets for command authorization and entity ID encryption.
+    authPubKey :: Maybe (X.CertificateChain, X.SignedExact X.PubKey)
   }
 
 data ClientHandshake = ClientHandshake
   { -- | agreed SMP server protocol version
-    smpVersion :: Version,
+    smpVersion :: VersionSMP,
     -- | server identity - CA certificate fingerprint
-    keyHash :: C.KeyHash
+    keyHash :: C.KeyHash,
+    -- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
+    authPubKey :: Maybe C.PublicKeyX25519
   }
 
 instance Encoding ClientHandshake where
-  smpEncode ClientHandshake {smpVersion, keyHash} = smpEncode (smpVersion, keyHash)
+  smpEncode ClientHandshake {smpVersion, keyHash, authPubKey} =
+    smpEncode (smpVersion, keyHash) <> encodeAuthEncryptCmds smpVersion authPubKey
   smpP = do
     (smpVersion, keyHash) <- smpP
-    pure ClientHandshake {smpVersion, keyHash}
+    -- TODO drop SMP v6: remove special parser and make key non-optional
+    authPubKey <- authEncryptCmdsP smpVersion smpP
+    pure ClientHandshake {smpVersion, keyHash, authPubKey}
 
 instance Encoding ServerHandshake where
-  smpEncode ServerHandshake {smpVersionRange, sessionId} =
-    smpEncode (smpVersionRange, sessionId)
+  smpEncode ServerHandshake {smpVersionRange, sessionId, authPubKey} =
+    smpEncode (smpVersionRange, sessionId) <> auth
+    where
+      auth =
+        encodeAuthEncryptCmds (maxVersion smpVersionRange) $
+          bimap C.encodeCertChain C.SignedObject <$> authPubKey
   smpP = do
     (smpVersionRange, sessionId) <- smpP
-    pure ServerHandshake {smpVersionRange, sessionId}
+    -- TODO drop SMP v6: remove special parser and make key non-optional
+    authPubKey <- authEncryptCmdsP (maxVersion smpVersionRange) authP
+    pure ServerHandshake {smpVersionRange, sessionId, authPubKey}
+    where
+      authP = do
+        cert <- C.certChainP
+        C.SignedObject key <- smpP
+        pure (cert, key)
+
+encodeAuthEncryptCmds :: Encoding a => VersionSMP -> Maybe a -> ByteString
+encodeAuthEncryptCmds v k
+  | v >= authCmdsSMPVersion = maybe "" smpEncode k
+  | otherwise = ""
+
+authEncryptCmdsP :: VersionSMP -> Parser a -> Parser (Maybe a)
+authEncryptCmdsP v p = if v >= authCmdsSMPVersion then Just <$> p else pure Nothing
 
 -- | Error of SMP encrypted transport over TCP.
 data TransportError
@@ -279,6 +395,9 @@ data TransportError
     TELargeMsg
   | -- | incorrect session ID
     TEBadSession
+  | -- | absent server key for v7 entity
+    -- This error happens when the server did not provide a DH key to authorize commands for the queue that should be authorized with a DH key.
+    TENoServerAuth
   | -- | transport handshake error
     TEHandshake {handshakeErr :: HandshakeError}
   deriving (Eq, Read, Show, Exception)
@@ -291,6 +410,8 @@ data HandshakeError
     VERSION
   | -- | incorrect server identity
     IDENTITY
+  | -- | v7 authentication failed
+    BAD_AUTH
   deriving (Eq, Read, Show, Exception)
 
 -- | SMP encrypted transport error parser.
@@ -299,6 +420,7 @@ transportErrorP =
   "BLOCK" $> TEBadBlock
     <|> "LARGE_MSG" $> TELargeMsg
     <|> "SESSION" $> TEBadSession
+    <|> "NO_AUTH" $> TENoServerAuth
     <|> "HANDSHAKE " *> (TEHandshake <$> parseRead1)
 
 -- | Serialize SMP encrypted transport error.
@@ -307,17 +429,18 @@ serializeTransportError = \case
   TEBadBlock -> "BLOCK"
   TELargeMsg -> "LARGE_MSG"
   TEBadSession -> "SESSION"
+  TENoServerAuth -> "NO_AUTH"
   TEHandshake e -> "HANDSHAKE " <> bshow e
 
 -- | Pad and send block to SMP transport.
-tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
-tPutBlock THandle {connection = c, blockSize} block =
+tPutBlock :: Transport c => THandle v c -> ByteString -> IO (Either TransportError ())
+tPutBlock THandle {connection = c, params = THandleParams {blockSize}} block =
   bimapM (const $ pure TELargeMsg) (cPut c) $
     C.pad block blockSize
 
 -- | Receive block from SMP transport.
-tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
-tGetBlock THandle {connection = c, blockSize} = do
+tGetBlock :: Transport c => THandle v c -> IO (Either TransportError ByteString)
+tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
   msg <- cGet c blockSize
   if B.length msg == blockSize
     then pure . first (const TELargeMsg) $ C.unPad msg
@@ -326,45 +449,61 @@ tGetBlock THandle {connection = c, blockSize} = do
 -- | Server SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-smpServerHandshake c kh smpVRange = do
-  let th@THandle {sessionId} = smpTHandle c
-  sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange}
+smpServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c)
+smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
+  let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
+      sk = C.signX509 serverSignKey $ C.publicToX509 k
+      certChain = getServerCerts c
+  sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange, authPubKey = Just (certChain, sk)}
   getHandshake th >>= \case
-    ClientHandshake {smpVersion, keyHash}
+    ClientHandshake {smpVersion = v, keyHash, authPubKey = k'}
       | keyHash /= kh ->
           throwE $ TEHandshake IDENTITY
-      | smpVersion `isCompatible` smpVRange -> do
-          pure $ smpThHandle th smpVersion
+      | v `isCompatible` smpVRange ->
+          pure $ smpThHandle th v pk k'
       | otherwise -> throwE $ TEHandshake VERSION
 
 -- | Client SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
-smpClientHandshake c keyHash smpVRange = do
-  let th@THandle {sessionId} = smpTHandle c
-  ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th
+smpClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c)
+smpClientHandshake c (k, pk) keyHash@(C.KeyHash kh) smpVRange = do
+  let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
+  ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
   if sessionId /= sessId
     then throwE TEBadSession
     else case smpVersionRange `compatibleVersion` smpVRange of
-      Just (Compatible smpVersion) -> do
-        sendHandshake th $ ClientHandshake {smpVersion, keyHash}
-        pure $ smpThHandle th smpVersion
+      Just (Compatible v) -> do
+        sk_ <- forM authPubKey $ \(X.CertificateChain cert, exact) ->
+          liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
+            case cert of
+              [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
+              _ -> throwError "bad certificate"
+            serverKey <- getServerVerifyKey c
+            pubKey <- C.verifyX509 serverKey exact
+            C.x509ToPublic (pubKey, []) >>= C.pubKey
+        sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = Just k}
+        pure $ smpThHandle th v pk sk_
       Nothing -> throwE $ TEHandshake VERSION
 
-smpThHandle :: forall c. THandle c -> Version -> THandle c
-smpThHandle th v = (th :: THandle c) {thVersion = v, batch = v >= 4}
+smpThHandle :: forall c. THandleSMP c -> VersionSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c
+smpThHandle th@THandle {params} v privKey k_ =
+  -- TODO drop SMP v6: make thAuth non-optional
+  let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
+      params' = params {thVersion = v, thAuth, implySessId = v >= authCmdsSMPVersion}
+   in (th :: THandleSMP c) {params = params'}
 
-sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
+sendHandshake :: (Transport c, Encoding smp) => THandle v c -> smp -> ExceptT TransportError IO ()
 sendHandshake th = ExceptT . tPutBlock th . smpEncode
 
 -- ignores tail bytes to allow future extensions
-getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportError IO smp
+getHandshake :: (Transport c, Encoding smp) => THandle v c -> ExceptT TransportError IO smp
 getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP =<<) <$> tGetBlock th
 
-smpTHandle :: Transport c => c -> THandle c
-smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False}
+smpTHandle :: Transport c => c -> THandleSMP c
+smpTHandle c = THandle {connection = c, params}
+  where
+    params = THandleParams {sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = VersionSMP 0, thAuth = Nothing, implySessId = False, batch = True}
 
 $(J.deriveJSON (sumTypeJSON id) ''HandshakeError)
 

src/Simplex/Messaging/Transport/Client.hs

@@ -22,6 +22,7 @@ where
 
 import Control.Applicative (optional)
 import Control.Logger.Simple (logError)
+import Control.Monad (when)
 import Control.Monad.IO.Unlift
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -54,6 +55,7 @@ import System.IO.Error
 import Text.Read (readMaybe)
 import UnliftIO.Exception (IOException)
 import qualified UnliftIO.Exception as E
+import UnliftIO.STM
 
 data TransportHost
   = THIPv4 (Word8, Word8, Word8, Word8)
@@ -129,8 +131,9 @@ runTransportClient = runTLSTransportClient supportedParameters Nothing
 
 runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
 runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials} proxyUsername host port keyHash client = do
+  serverCert <- newEmptyTMVarIO
   let hostName = B.unpack $ strEncode host
-      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials
+      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials serverCert
       connectTCP = case socksProxy of
         Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host
         _ -> connectTCPClient hostName
@@ -138,7 +141,13 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
     sock <- connectTCP port
     mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive" <> tshow e)
     let tCfg = clientTransportConfig cfg
-    connectTLS (Just hostName) tCfg clientParams sock >>= getClientConnection tCfg
+    connectTLS (Just hostName) tCfg clientParams sock >>= \tls -> do
+      chain <- atomically (tryTakeTMVar serverCert) >>= \case
+        Nothing -> do
+          logError "onServerCertificate didn't fire or failed to get cert chain"
+          closeTLS tls >> error "onServerCertificate failed"
+        Just c -> pure c
+      getClientConnection tCfg chain tls
   client c `E.finally` liftIO (closeConnection c)
   where
     hostAddr = \case
@@ -207,19 +216,24 @@ instance ToJSON SocksProxy where
 instance FromJSON SocksProxy where
   parseJSON = strParseJSON "SocksProxy"
 
-mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> T.ClientParams
-mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ =
+mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> TMVar X.CertificateChain -> T.ClientParams
+mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ serverCerts =
   (T.defaultParamsClient host p)
     { T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
       T.clientHooks =
         def
-          { T.onServerCertificate = maybe def (\cafp _ _ _ -> validateCertificateChain cafp host p) cafp_,
+          { T.onServerCertificate = onServerCert,
             T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_
           },
       T.clientSupported = supported
     }
   where
     p = B.pack port
+    onServerCert _ _ _ c = do
+      errs <- maybe def (\ca -> validateCertificateChain ca host p c) cafp_
+      when (null errs) $
+        atomically (putTMVar serverCerts c)
+      pure errs
 
 validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
 validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain]

src/Simplex/Messaging/Transport/Server.hs

@@ -19,6 +19,7 @@ module Simplex.Messaging.Transport.Server
     loadTLSServerParams,
     loadFingerprint,
     smpServerHandshake,
+    tlsServerCredentials
   )
 where
 
@@ -29,14 +30,14 @@ import Control.Monad.IO.Unlift
 import qualified Crypto.Store.X509 as SX
 import Data.Default (def)
 import Data.List (find)
+import Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IM
 import Data.Maybe (fromJust)
 import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..))
 import qualified Data.X509.Validation as XV
 import Network.Socket
 import qualified Network.TLS as T
-import Simplex.Messaging.TMap (TMap)
-import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow)
 import System.Exit (exitFailure)
@@ -78,13 +79,13 @@ runTransportServerState :: forall c m. (Transport c, MonadUnliftIO m) => SocketS
 runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started port) (transportName (TProxy :: TProxy c))
 
 -- | Run a transport server with provided connection setup and handler.
-runTransportServerSocket :: (MonadUnliftIO m, T.TLSParams p, Transport a) => TMVar Bool -> IO Socket -> String -> p -> TransportServerConfig -> (a -> m ()) -> m ()
+runTransportServerSocket :: (MonadUnliftIO m, Transport a) => TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> m ()) -> m ()
 runTransportServerSocket started getSocket threadLabel serverParams cfg server = do
   ss <- atomically newSocketState
   runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server
 
 -- | Run a transport server with provided connection setup and handler.
-runTransportServerSocketState :: (MonadUnliftIO m, T.TLSParams p, Transport a) => SocketState -> TMVar Bool -> IO Socket -> String -> p -> TransportServerConfig -> (a -> m ()) -> m ()
+runTransportServerSocketState :: (MonadUnliftIO m, Transport a) => SocketState -> TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> m ()) -> m ()
 runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server = do
   u <- askUnliftIO
   labelMyThread $ "transport server for " <> threadLabel
@@ -95,7 +96,12 @@ runTransportServerSocketState ss started getSocket threadLabel serverParams cfg
     setup conn = timeout (tlsSetupTimeout cfg) $ do
       labelMyThread $ threadLabel <> "/setup"
       tls <- connectTLS Nothing tCfg serverParams conn
-      getServerConnection tCfg tls
+      getServerConnection tCfg (fst $ tlsServerCredentials serverParams) tls
+
+tlsServerCredentials :: T.ServerParams -> (X.CertificateChain, X.PrivKey)
+tlsServerCredentials serverParams = case T.sharedCredentials $ T.serverShared serverParams of
+  T.Credentials [creds] -> creds
+  _ -> error "server has more than one key"
 
 -- | Run TCP server without TLS
 runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
@@ -110,18 +116,18 @@ runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket serve
     forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
       cId <- atomically $ stateTVar accepted $ \cId -> let cId' = cId + 1 in cId `seq` (cId', cId')
       let closeConn _ = do
-            atomically $ TM.delete cId clients
+            atomically $ modifyTVar' clients $ IM.delete cId 
             gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier
             atomically $ modifyTVar' gracefullyClosed (+1)
       tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
-      atomically $ TM.insert cId tId clients
+      atomically $ modifyTVar' clients $ IM.insert cId tId
 
-type SocketState = (TVar Int, TVar Int, TMap Int (Weak ThreadId))
+type SocketState = (TVar Int, TVar Int, TVar (IntMap (Weak ThreadId)))
 
 newSocketState :: STM SocketState
 newSocketState = (,,) <$> newTVar 0 <*> newTVar 0 <*> newTVar mempty
 
-closeServer :: TMVar Bool -> TMap Int (Weak ThreadId) -> Socket -> IO ()
+closeServer :: TMVar Bool -> TVar (IntMap (Weak ThreadId)) -> Socket -> IO ()
 closeServer started clients sock = do
   readTVarIO clients >>= mapM_ (deRefWeak >=> mapM_ killThread)
   close sock

src/Simplex/Messaging/Transport/WebSockets.hs

@@ -8,6 +8,7 @@ import qualified Control.Exception as E
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
+import qualified Data.X509 as X
 import qualified Network.TLS as T
 import Network.WebSockets
 import Network.WebSockets.Stream (Stream)
@@ -29,7 +30,8 @@ data WS = WS
     tlsUniq :: ByteString,
     wsStream :: Stream,
     wsConnection :: Connection,
-    wsTransportConfig :: TransportConfig
+    wsTransportConfig :: TransportConfig,
+    wsServerCerts :: X.CertificateChain
   }
 
 websocketsOpts :: ConnectionOptions
@@ -50,12 +52,15 @@ instance Transport WS where
   transportConfig :: WS -> TransportConfig
   transportConfig = wsTransportConfig
 
-  getServerConnection :: TransportConfig -> T.Context -> IO WS
+  getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS
   getServerConnection = getWS TServer
 
-  getClientConnection :: TransportConfig -> T.Context -> IO WS
+  getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS
   getClientConnection = getWS TClient
 
+  getServerCerts :: WS -> X.CertificateChain
+  getServerCerts = wsServerCerts
+
   tlsUnique :: WS -> ByteString
   tlsUnique = tlsUniq
 
@@ -79,13 +84,13 @@ instance Transport WS where
       then E.throwIO TEBadBlock
       else pure $ B.init s
 
-getWS :: TransportPeer -> TransportConfig -> T.Context -> IO WS
-getWS wsPeer cfg cxt = withTlsUnique wsPeer cxt connectWS
+getWS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO WS
+getWS wsPeer cfg wsServerCerts cxt = withTlsUnique wsPeer cxt connectWS
   where
     connectWS tlsUniq = do
       s <- makeTLSContextStream cxt
       wsConnection <- connectPeer wsPeer s
-      pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg}
+      pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts}
     connectPeer :: TransportPeer -> Stream -> IO Connection
     connectPeer TServer = acceptClientRequest
     connectPeer TClient = sendClientRequest

src/Simplex/Messaging/Version.hs

@@ -1,13 +1,16 @@
 {-# LANGUAGE ConstrainedClassMethods #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 
 module Simplex.Messaging.Version
   ( Version,
     VersionRange (minVersion, maxVersion),
+    VersionScope,
     pattern VersionRange,
     VersionI (..),
     VersionRangeI (..),
@@ -24,47 +27,61 @@ module Simplex.Messaging.Version
 where
 
 import Control.Applicative (optional)
-import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Encoding as JE
+import Data.Aeson.Types ((.:), (.=))
+import qualified Data.Aeson.Types as JT
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Word (Word16)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Util ((<$?>))
+import Simplex.Messaging.Version.Internal (Version (..))
 
-pattern VersionRange :: Word16 -> Word16 -> VersionRange
+pattern VersionRange :: Version v -> Version v -> VersionRange v
 pattern VersionRange v1 v2 <- VRange v1 v2
 
 {-# COMPLETE VersionRange #-}
 
-type Version = Word16
-
-data VersionRange = VRange
-  { minVersion :: Version,
-    maxVersion :: Version
+data VersionRange v = VRange
+  { minVersion :: Version v,
+    maxVersion :: Version v
   }
   deriving (Eq, Show)
 
+instance J.FromJSON (VersionRange v) where
+  parseJSON (J.Object v) = do
+    minVersion <- v .: "minVersion"
+    maxVersion <- v .: "maxVersion"
+    pure VRange {minVersion, maxVersion}
+  parseJSON invalid =
+    JT.prependFailure "bad VersionRange, " (JT.typeMismatch "Object" invalid)
+
+instance J.ToJSON (VersionRange v) where
+  toEncoding VRange {minVersion, maxVersion} = JE.pairs $ ("minVersion" .= minVersion) <> ("maxVersion" .= maxVersion)
+  toJSON VRange {minVersion, maxVersion} = J.object ["minVersion" .= minVersion, "maxVersion" .= maxVersion]
+
+class VersionScope v
+
 -- | construct valid version range, to be used in constants
-mkVersionRange :: Version -> Version -> VersionRange
+mkVersionRange :: Version v -> Version v -> VersionRange v
 mkVersionRange v1 v2
   | v1 <= v2 = VRange v1 v2
   | otherwise = error "invalid version range"
 
-safeVersionRange :: Version -> Version -> Maybe VersionRange
+safeVersionRange :: Version v -> Version v -> Maybe (VersionRange v)
 safeVersionRange v1 v2
   | v1 <= v2 = Just $ VRange v1 v2
   | otherwise = Nothing
 
-versionToRange :: Version -> VersionRange
+versionToRange :: Version v -> VersionRange v
 versionToRange v = VRange v v
 
-instance Encoding VersionRange where
+instance VersionScope v => Encoding (VersionRange v) where
   smpEncode (VRange v1 v2) = smpEncode (v1, v2)
   smpP =
     maybe (fail "invalid version range") pure
       =<< safeVersionRange <$> smpP <*> smpP
 
-instance StrEncoding VersionRange where
+instance VersionScope v => StrEncoding (VersionRange v) where
   strEncode (VRange v1 v2)
     | v1 == v2 = strEncode v1
     | otherwise = strEncode v1 <> "-" <> strEncode v2
@@ -73,32 +90,23 @@ instance StrEncoding VersionRange where
     v2 <- maybe (pure v1) (const strP) =<< optional (A.char '-')
     maybe (fail "invalid version range") pure $ safeVersionRange v1 v2
 
-instance ToJSON VersionRange where
-  toJSON (VRange v1 v2) = toJSON (v1, v2)
-  toEncoding (VRange v1 v2) = toEncoding (v1, v2)
+class VersionScope v => VersionI v a | a -> v where
+  type VersionRangeT v a
+  version :: a -> Version v
+  toVersionRangeT :: a -> VersionRange v -> VersionRangeT v a
 
-instance FromJSON VersionRange where
-  parseJSON v =
-    (\(v1, v2) -> maybe (Left "bad VersionRange") Right $ safeVersionRange v1 v2)
-      <$?> parseJSON v
+class VersionScope v => VersionRangeI v a | a -> v where
+  type VersionT v a
+  versionRange :: a -> VersionRange v
+  toVersionT :: a -> Version v -> VersionT v a
 
-class VersionI a where
-  type VersionRangeT a
-  version :: a -> Version
-  toVersionRangeT :: a -> VersionRange -> VersionRangeT a
-
-class VersionRangeI a where
-  type VersionT a
-  versionRange :: a -> VersionRange
-  toVersionT :: a -> Version -> VersionT a
-
-instance VersionI Version where
-  type VersionRangeT Version = VersionRange
+instance VersionScope v => VersionI v (Version v) where
+  type VersionRangeT v (Version v) = VersionRange v
   version = id
   toVersionRangeT _ vr = vr
 
-instance VersionRangeI VersionRange where
-  type VersionT VersionRange = Version
+instance VersionScope v => VersionRangeI v (VersionRange v) where
+  type VersionT v (VersionRange v) = Version v
   versionRange = id
   toVersionT _ v = v
 
@@ -109,18 +117,18 @@ pattern Compatible a <- Compatible_ a
 
 {-# COMPLETE Compatible #-}
 
-isCompatible :: VersionI a => a -> VersionRange -> Bool
+isCompatible :: VersionI v a => a -> VersionRange v -> Bool
 isCompatible x (VRange v1 v2) = let v = version x in v1 <= v && v <= v2
 
-isCompatibleRange :: VersionRangeI a => a -> VersionRange -> Bool
+isCompatibleRange :: VersionRangeI v a => a -> VersionRange v -> Bool
 isCompatibleRange x (VRange min2 max2) = min1 <= max2 && min2 <= max1
   where
     VRange min1 max1 = versionRange x
 
-proveCompatible :: VersionI a => a -> VersionRange -> Maybe (Compatible a)
+proveCompatible :: VersionI v a => a -> VersionRange v -> Maybe (Compatible a)
 proveCompatible x vr = x `mkCompatibleIf` (x `isCompatible` vr)
 
-compatibleVersion :: VersionRangeI a => a -> VersionRange -> Maybe (Compatible (VersionT a))
+compatibleVersion :: VersionRangeI v a => a -> VersionRange v -> Maybe (Compatible (VersionT v a))
 compatibleVersion x vr =
   toVersionT x (min max1 max2) `mkCompatibleIf` isCompatibleRange x vr
   where

src/Simplex/Messaging/Version/Internal.hs

@@ -0,0 +1,25 @@
+module Simplex.Messaging.Version.Internal where
+
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import Data.Word (Word16)
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+
+-- Do not use constructor of this type directry
+newtype Version v = Version Word16
+  deriving (Eq, Ord, Show)
+
+instance Encoding (Version v) where
+  smpEncode (Version v) = smpEncode v
+  smpP = Version <$> smpP
+
+instance StrEncoding (Version v) where
+  strEncode (Version v) = strEncode v
+  strP = Version <$> strP
+
+instance ToJSON (Version v) where
+  toEncoding (Version v) = toEncoding v
+  toJSON (Version v) = toJSON v
+
+instance FromJSON (Version v) where
+  parseJSON v = Version <$> parseJSON v

src/Simplex/RemoteControl/Client.hs

@@ -68,12 +68,6 @@ import Simplex.RemoteControl.Types
 import UnliftIO
 import UnliftIO.Concurrent
 
-currentRCVersion :: Version
-currentRCVersion = 1
-
-supportedRCVRange :: VersionRange
-supportedRCVRange = mkVersionRange 1 currentRCVersion
-
 xrcpBlockSize :: Int
 xrcpBlockSize = 16384
 
@@ -181,7 +175,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
               { ca = certFingerprint caCert,
                 host,
                 port = fromIntegral portNum,
-                v = supportedRCVRange,
+                v = supportedRCPVRange,
                 app = ctrlAppInfo,
                 ts,
                 skey = fst sessKeys,
@@ -220,7 +214,7 @@ prepareHostSession
     unless (ca == tlsHostFingerprint) $ throwError RCEIdentity
     (kemCiphertext, kemSharedKey) <- liftIO $ sntrup761Enc drg kemPubKey
     let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
-    unless (isCompatible v supportedRCVRange) $ throwError RCEVersion
+    unless (isCompatible v supportedRCPVRange) $ throwError RCEVersion
     let keys = HostSessKeys {hybridKey, idPrivKey, sessPrivKey}
     knownHost' <- updateKnownHost ca dhPubKey
     let ctrlHello = RCCtrlHello {}
@@ -334,7 +328,7 @@ prepareHostHello
   RCInvitation {v, dh = dhPubKey}
   hostAppInfo = do
     logDebug "Preparing session"
-    case compatibleVersion v supportedRCVRange of
+    case compatibleVersion v supportedRCPVRange of
       Nothing -> throwError RCEVersion
       Just (Compatible v') -> do
         nonce <- liftIO . atomically $ C.randomCbNonce drg

src/Simplex/RemoteControl/Invitation.hs

@@ -27,7 +27,7 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Version (VersionRange)
+import Simplex.RemoteControl.Types (VersionRangeRCP)
 
 data RCInvitation = RCInvitation
   { -- | CA TLS certificate fingerprint of the controller.
@@ -37,7 +37,7 @@ data RCInvitation = RCInvitation
     host :: TransportHost,
     port :: Word16,
     -- | Supported version range for remote control protocol
-    v :: VersionRange,
+    v :: VersionRangeRCP,
     -- | Application information
     app :: J.Value,
     -- | Session start time in seconds since epoch

src/Simplex/RemoteControl/Types.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -17,6 +18,7 @@ import Data.ByteString (ByteString)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
+import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.SNTRUP761
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
@@ -26,7 +28,8 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport (TLS)
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (safeDecodeUtf8)
-import Simplex.Messaging.Version (Version, VersionRange, mkVersionRange)
+import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange)
+import Simplex.Messaging.Version.Internal
 import UnliftIO
 
 data RCErrorType
@@ -92,24 +95,37 @@ instance StrEncoding RCErrorType where
 
 -- * Discovery
 
-ipProbeVersionRange :: VersionRange
-ipProbeVersionRange = mkVersionRange 1 1
+data RCPVersion
+
+instance VersionScope RCPVersion
+
+type VersionRCP = Version RCPVersion
+
+type VersionRangeRCP = VersionRange RCPVersion
+
+pattern VersionRCP :: Word16 -> VersionRCP
+pattern VersionRCP v = Version v
+
+currentRCPVersion :: VersionRCP
+currentRCPVersion = VersionRCP 1
+
+supportedRCPVRange :: VersionRangeRCP
+supportedRCPVRange = mkVersionRange (VersionRCP 1) currentRCPVersion
 
 data IpProbe = IpProbe
-  { versionRange :: VersionRange,
+  { versionRange :: VersionRangeRCP,
     randomNonce :: ByteString
   }
   deriving (Show)
 
 instance Encoding IpProbe where
   smpEncode IpProbe {versionRange, randomNonce} = smpEncode (versionRange, 'I', randomNonce)
-
   smpP = IpProbe <$> (smpP <* "I") *> smpP
 
 -- * Session
 
 data RCHostHello = RCHostHello
-  { v :: Version,
+  { v :: VersionRCP,
     ca :: C.KeyHash,
     app :: J.Value,
     kem :: KEMPublicKey

tests/AgentTests.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PostfixOperators #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
@@ -12,12 +13,12 @@ module AgentTests (agentTests) where
 
 import AgentTests.ConnectionRequestTests
 import AgentTests.DoubleRatchetTests (doubleRatchetTests)
-import AgentTests.FunctionalAPITests (functionalAPITests)
+import AgentTests.FunctionalAPITests (functionalAPITests, pattern Msg, pattern Msg')
 import AgentTests.MigrationTests (migrationTests)
 import AgentTests.NotificationTests (notificationTests)
 import AgentTests.SQLiteTests (storeTests)
 import Control.Concurrent
-import Control.Monad (forM_)
+import Control.Monad (forM_, when)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Maybe (fromJust)
@@ -26,15 +27,18 @@ import GHC.Stack (withFrozenCallStack)
 import Network.HTTP.Types (urlEncode)
 import SMPAgentClient
 import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
-import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.Protocol hiding (MID, CONF, INFO, REQ)
 import qualified Simplex.Messaging.Agent.Protocol as A
+import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOn, pattern IKPQOff, pattern PQEncOn, pattern PQSupportOn, pattern PQSupportOff)
+import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
+import Simplex.Messaging.Protocol (ErrorType (..))
 import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..))
 import Simplex.Messaging.Util (bshow)
 import System.Directory (removeFile)
 import System.Timeout
 import Test.Hspec
+import Util
 
 agentTests :: ATransport -> Spec
 agentTests (ATransport t) = do
@@ -46,24 +50,25 @@ agentTests (ATransport t) = do
   describe "Migration tests" migrationTests
   describe "SMP agent protocol syntax" $ syntaxTests t
   describe "Establishing duplex connection (via agent protocol)" $ do
-    -- These tests are disabled because the agent does not work correctly with multiple connected TCP clients
-    xit "should connect via one server and one agent" $ do
-      smpAgentTest2_1_1 $ testDuplexConnection t
-    xit "should connect via one server and one agent (random IDs)" $ do
-      smpAgentTest2_1_1 $ testDuplexConnRandomIds t
+    skip "These tests are disabled because the agent does not work correctly with multiple connected TCP clients" $
+      describe "one agent" $ do
+        it "should connect via one server and one agent" $ do
+          smpAgentTest2_1_1 $ testDuplexConnection t
+        it "should connect via one server and one agent (random IDs)" $ do
+          smpAgentTest2_1_1 $ testDuplexConnRandomIds t
     it "should connect via one server and 2 agents" $ do
       smpAgentTest2_2_1 $ testDuplexConnection t
     it "should connect via one server and 2 agents (random IDs)" $ do
       smpAgentTest2_2_1 $ testDuplexConnRandomIds t
-    it "should connect via 2 servers and 2 agents" $ do
-      smpAgentTest2_2_2 $ testDuplexConnection t
-    it "should connect via 2 servers and 2 agents (random IDs)" $ do
-      smpAgentTest2_2_2 $ testDuplexConnRandomIds t
+    describe "should connect via 2 servers and 2 agents" $ do
+      pqMatrix2 t smpAgentTest2_2_2 testDuplexConnection'
+    describe "should connect via 2 servers and 2 agents (random IDs)" $ do
+      pqMatrix2 t smpAgentTest2_2_2 testDuplexConnRandomIds'
   describe "Establishing connections via `contact connection`" $ do
-    it "should connect via contact connection with one server and 3 agents" $ do
-      smpAgentTest3 $ testContactConnection t
-    it "should connect via contact connection with one server and 2 agents (random IDs)" $ do
-      smpAgentTest2_2_1 $ testContactConnRandomIds t
+    describe "should connect via contact connection with one server and 3 agents" $ do
+      pqMatrix3 t smpAgentTest3 testContactConnection
+    describe "should connect via contact connection with one server and 2 agents (random IDs)" $ do
+      pqMatrix2NoInv t smpAgentTest2_2_1 testContactConnRandomIds
     it "should support rejecting contact request" $ do
       smpAgentTest2_2_1 $ testRejectContactRequest t
   describe "Connection subscriptions" $ do
@@ -72,8 +77,8 @@ agentTests (ATransport t) = do
     it "should send notifications to client when server disconnects" $ do
       smpAgentServerTest $ testSubscrNotification t
   describe "Message delivery and server reconnection" $ do
-    it "should deliver messages after losing server connection and re-connecting" $ do
-      smpAgentTest2_2_2_needs_server $ testMsgDeliveryServerRestart t
+    describe "should deliver messages after losing server connection and re-connecting" $
+      pqMatrix2 t smpAgentTest2_2_2_needs_server testMsgDeliveryServerRestart
     it "should connect to the server when server goes up if it initially was down" $ do
       smpAgentTestN [] $ testServerConnectionAfterError t
     it "should deliver pending messages after agent restarting" $ do
@@ -133,6 +138,9 @@ action #> (corrId, connId, cmd) = withFrozenCallStack $ action `shouldReturn` (c
 (=#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
 action =#> p = withFrozenCallStack $ action >>= (`shouldSatisfy` p . correctTransmission)
 
+pattern MID :: AgentMsgId -> ACommand 'Agent 'AEConn
+pattern MID msgId = A.MID msgId PQEncOn
+
 correctTransmission :: (ACorrId, ConnId, Either AgentErrorType cmd) -> (ACorrId, ConnId, cmd)
 correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of
   Right cmd -> (corrId, connId, cmd)
@@ -161,130 +169,188 @@ h #:# err = tryGet `shouldReturn` ()
         Just _ -> error err
         _ -> return ()
 
-pattern Msg :: MsgBody -> ACommand 'Agent e
-pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
+type PQMatrix2 c =
+  HasCallStack =>
+  TProxy c ->
+  (HasCallStack => (c -> c -> IO ()) -> Expectation) ->
+  (HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> IO ()) ->
+  Spec
 
-pattern Msg' :: AgentMsgId -> MsgBody -> ACommand 'Agent e
-pattern Msg' aMsgId msgBody <- MSG MsgMeta {integrity = MsgOk, recipient = (aMsgId, _)} _ msgBody
+pqMatrix2 :: PQMatrix2 c
+pqMatrix2 = pqMatrix2_ True
+
+pqMatrix2NoInv :: PQMatrix2 c
+pqMatrix2NoInv = pqMatrix2_ False
+
+pqMatrix2_ :: Bool -> PQMatrix2 c
+pqMatrix2_ pqInv _ smpTest test = do
+  it "dh/dh handshake" $ smpTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff)
+  it "dh/pq handshake" $ smpTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn)
+  it "pq/dh handshake" $ smpTest $ \a b -> test (a, IKPQOn) (b, PQSupportOff)
+  it "pq/pq handshake" $ smpTest $ \a b -> test (a, IKPQOn) (b, PQSupportOn)
+  when pqInv $ do
+    it "pq-inv/dh handshake" $ smpTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff)
+    it "pq-inv/pq handshake" $ smpTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn)
+
+pqMatrix3 ::
+  HasCallStack =>
+  TProxy c -> 
+  (HasCallStack => (c -> c -> c -> IO ()) -> Expectation) -> 
+  (HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()) ->
+  Spec
+pqMatrix3 _ smpTest test = do
+  it "dh" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff)
+  it "dh/dh/pq" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOn)
+  it "dh/pq/dh" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOff)
+  it "dh/pq/pq" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOn)
+  it "pq/dh/dh" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOff)
+  it "pq/dh/pq" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOn)
+  it "pq/pq/dh" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOff)
+  it "pq" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn)
 
 testDuplexConnection :: (HasCallStack, Transport c) => TProxy c -> c -> c -> IO ()
-testDuplexConnection _ alice bob = do
-  ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV subscribe")
+testDuplexConnection _ alice bob = testDuplexConnection' (alice, IKPQOn) (bob, PQSupportOn)
+
+testDuplexConnection' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO ()
+testDuplexConnection' (alice, aPQ) (bob, bPQ) = do
+  let pq = pqConnectionMode aPQ bPQ
+      pqSup = CR.pqEncToSupport pq
+  ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe")
   let cReq' = strEncode cReq
-  bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
-  ("", "bob", Right (CONF confId _ "bob's connInfo")) <- (alice <#:)
+  bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
+  ("", "bob", Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:)
+  pqSup' `shouldBe` pqSup
   alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
-  bob <# ("", "alice", INFO "alice's connInfo")
-  bob <# ("", "alice", CON)
-  alice <# ("", "bob", CON)
+  bob <# ("", "alice", A.INFO pqSup "alice's connInfo")
+  bob <# ("", "alice", CON pq)
+  alice <# ("", "bob", CON pq)
   -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
-  alice #: ("3", "bob", "SEND F :hello") #> ("3", "bob", MID 4)
+  alice #: ("3", "bob", "SEND F :hello") #> ("3", "bob", A.MID 4 pq)
   alice <# ("", "bob", SENT 4)
-  bob <#= \case ("", "alice", Msg' 4 "hello") -> True; _ -> False
+  bob <#= \case ("", "alice", Msg' 4 pq' "hello") -> pq == pq'; _ -> False
   bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)
-  alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", MID 5)
+  alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", A.MID 5 pq)
   alice <# ("", "bob", SENT 5)
-  bob <#= \case ("", "alice", Msg' 5 "how are you?") -> True; _ -> False
+  bob <#= \case ("", "alice", Msg' 5 pq' "how are you?") -> pq == pq'; _ -> False
   bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
-  bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 6)
+  bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", A.MID 6 pq)
   bob <# ("", "alice", SENT 6)
-  alice <#= \case ("", "bob", Msg' 6 "hello too") -> True; _ -> False
+  alice <#= \case ("", "bob", Msg' 6 pq' "hello too") -> pq == pq'; _ -> False
   alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)
-  bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", MID 7)
+  bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", A.MID 7 pq)
   bob <# ("", "alice", SENT 7)
-  alice <#= \case ("", "bob", Msg' 7 "message 1") -> True; _ -> False
+  alice <#= \case ("", "bob", Msg' 7 pq' "message 1") -> pq == pq'; _ -> False
   alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)
   alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
-  bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", MID 8)
+  bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", A.MID 8 pq)
   bob <# ("", "alice", MERR 8 (SMP AUTH))
   alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
   alice #:# "nothing else should be delivered to alice"
 
-testDuplexConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
-testDuplexConnRandomIds _ alice bob = do
-  ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV subscribe")
+testDuplexConnRandomIds :: (HasCallStack, Transport c) => TProxy c -> c -> c -> IO ()
+testDuplexConnRandomIds _ alice bob = testDuplexConnRandomIds' (alice, IKPQOn) (bob, PQSupportOn)
+
+testDuplexConnRandomIds' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO ()
+testDuplexConnRandomIds' (alice, aPQ) (bob, bPQ) = do
+  let pq = pqConnectionMode aPQ bPQ
+      pqSup = CR.pqEncToSupport pq
+  ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe")
   let cReq' = strEncode cReq
-  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo")
-  ("", bobConn', Right (CONF confId _ "bob's connInfo")) <- (alice <#:)
+  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo")
+  ("", bobConn', Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:)
+  pqSup' `shouldBe` pqSup
   bobConn' `shouldBe` bobConn
   alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
-  bob <# ("", aliceConn, INFO "alice's connInfo")
-  bob <# ("", aliceConn, CON)
-  alice <# ("", bobConn, CON)
-  alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, MID 4)
+  bob <# ("", aliceConn, A.INFO pqSup "alice's connInfo")
+  bob <# ("", aliceConn, CON pq)
+  alice <# ("", bobConn, CON pq)
+  alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, A.MID 4 pq)
   alice <# ("", bobConn, SENT 4)
-  bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
+  bob <#= \case ("", c, Msg' 4 pq' "hello") -> c == aliceConn && pq == pq'; _ -> False
   bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK)
-  alice #: ("3", bobConn, "SEND F :how are you?") #> ("3", bobConn, MID 5)
+  alice #: ("3", bobConn, "SEND F :how are you?") #> ("3", bobConn, A.MID 5 pq)
   alice <# ("", bobConn, SENT 5)
-  bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False
+  bob <#= \case ("", c, Msg' 5 pq' "how are you?") -> c == aliceConn && pq == pq'; _ -> False
   bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
-  bob #: ("14", aliceConn, "SEND F 9\nhello too") #> ("14", aliceConn, MID 6)
+  bob #: ("14", aliceConn, "SEND F 9\nhello too") #> ("14", aliceConn, A.MID 6 pq)
   bob <# ("", aliceConn, SENT 6)
-  alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
+  alice <#= \case ("", c, Msg' 6 pq' "hello too") -> c == bobConn && pq == pq'; _ -> False
   alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK)
-  bob #: ("15", aliceConn, "SEND F 9\nmessage 1") #> ("15", aliceConn, MID 7)
+  bob #: ("15", aliceConn, "SEND F 9\nmessage 1") #> ("15", aliceConn, A.MID 7 pq)
   bob <# ("", aliceConn, SENT 7)
-  alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> False
+  alice <#= \case ("", c, Msg' 7 pq' "message 1") -> c == bobConn && pq == pq'; _ -> False
   alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK)
   alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
-  bob #: ("17", aliceConn, "SEND F 9\nmessage 3") #> ("17", aliceConn, MID 8)
+  bob #: ("17", aliceConn, "SEND F 9\nmessage 3") #> ("17", aliceConn, A.MID 8 pq)
   bob <# ("", aliceConn, MERR 8 (SMP AUTH))
   alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
   alice #:# "nothing else should be delivered to alice"
 
-testContactConnection :: Transport c => TProxy c -> c -> c -> c -> IO ()
-testContactConnection _ alice bob tom = do
-  ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON subscribe")
+testContactConnection :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()
+testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do
+  ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe")
   let cReq' = strEncode cReq
+      abPQ = pqConnectionMode aPQ bPQ
+      abPQSup = CR.pqEncToSupport abPQ
+      aPQMode = CR.connPQEncryption aPQ
 
-  bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
-  ("", "alice_contact", Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:)
-  alice #: ("2", "bob", "ACPT " <> aInvId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
-  ("", "alice", Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:)
+  bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
+  ("", "alice_contact", Right (A.REQ aInvId pqSup' _ "bob's connInfo")) <- (alice <#:)
+  pqSup' `shouldBe` bPQ
+  alice #: ("2", "bob", "ACPT " <> aInvId <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("2", "bob", OK)
+  ("", "alice", Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:)
+  pqSup'' `shouldBe` abPQSup
   bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
-  alice <# ("", "bob", INFO "bob's connInfo 2")
-  alice <# ("", "bob", CON)
-  bob <# ("", "alice", CON)
-  alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", MID 4)
+  alice <# ("", "bob", A.INFO abPQSup "bob's connInfo 2")
+  alice <# ("", "bob", CON abPQ)
+  bob <# ("", "alice", CON abPQ)
+  alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", A.MID 4 abPQ)
   alice <# ("", "bob", SENT 4)
-  bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
+  bob <#= \case ("", "alice", Msg' 4 pq' "hi") -> pq' == abPQ; _ -> False
   bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
 
-  tom #: ("21", "alice", "JOIN T " <> cReq' <> " subscribe 14\ntom's connInfo") #> ("21", "alice", OK)
-  ("", "alice_contact", Right (REQ aInvId' _ "tom's connInfo")) <- (alice <#:)
-  alice #: ("4", "tom", "ACPT " <> aInvId' <> " 16\nalice's connInfo") #> ("4", "tom", OK)
-  ("", "alice", Right (CONF tConfId _ "alice's connInfo")) <- (tom <#:)
+  let atPQ = pqConnectionMode aPQ tPQ
+      atPQSup = CR.pqEncToSupport atPQ
+  tom #: ("21", "alice", "JOIN T " <> cReq' <> enableKEMStr tPQ <> " subscribe 14\ntom's connInfo") #> ("21", "alice", OK)
+  ("", "alice_contact", Right (A.REQ aInvId' pqSup3 _ "tom's connInfo")) <- (alice <#:)
+  pqSup3 `shouldBe` tPQ
+  alice #: ("4", "tom", "ACPT " <> aInvId' <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("4", "tom", OK)
+  ("", "alice", Right (A.CONF tConfId pqSup4 _ "alice's connInfo")) <- (tom <#:)
+  pqSup4 `shouldBe` atPQSup
   tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
-  alice <# ("", "tom", INFO "tom's connInfo 2")
-  alice <# ("", "tom", CON)
-  tom <# ("", "alice", CON)
-  alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", MID 4)
+  alice <# ("", "tom", A.INFO atPQSup "tom's connInfo 2")
+  alice <# ("", "tom", CON atPQ)
+  tom <# ("", "alice", CON atPQ)
+  alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", A.MID 4 atPQ)
   alice <# ("", "tom", SENT 4)
-  tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False
+  tom <#= \case ("", "alice", Msg' 4 pq' "hi there") -> pq' == atPQ; _ -> False
   tom #: ("23", "alice", "ACK 4") #> ("23", "alice", OK)
 
-testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
-testContactConnRandomIds _ alice bob = do
-  ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON subscribe")
+testContactConnRandomIds :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO ()
+testContactConnRandomIds (alice, aPQ) (bob, bPQ) = do
+  let pq = pqConnectionMode aPQ bPQ
+      pqSup = CR.pqEncToSupport pq
+  ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe")
   let cReq' = strEncode cReq
 
-  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo")
-  ("", aliceContact', Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:)
+  ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo")
+  ("", aliceContact', Right (A.REQ aInvId pqSup' _ "bob's connInfo")) <- (alice <#:)
+  pqSup' `shouldBe` bPQ
   aliceContact' `shouldBe` aliceContact
 
-  ("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> " 16\nalice's connInfo")
-  ("", aliceConn', Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:)
+  ("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> enableKEMStr (CR.connPQEncryption aPQ) <> " 16\nalice's connInfo")
+  ("", aliceConn', Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:)
+  pqSup'' `shouldBe` pqSup
   aliceConn' `shouldBe` aliceConn
 
   bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
-  alice <# ("", bobConn, INFO "bob's connInfo 2")
-  alice <# ("", bobConn, CON)
-  bob <# ("", aliceConn, CON)
+  alice <# ("", bobConn, A.INFO pqSup "bob's connInfo 2")
+  alice <# ("", bobConn, CON pq)
+  bob <# ("", aliceConn, CON pq)
 
-  alice #: ("3", bobConn, "SEND F :hi") #> ("3", bobConn, MID 4)
+  alice #: ("3", bobConn, "SEND F :hi") #> ("3", bobConn, A.MID 4 pq)
   alice <# ("", bobConn, SENT 4)
-  bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> False
+  bob <#= \case ("", c, Msg' 4 pq' "hi") -> c == aliceConn && pq == pq'; _ -> False
   bob #: ("13", aliceConn, "ACK 4") #> ("13", aliceConn, OK)
 
 testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
@@ -292,7 +358,7 @@ testRejectContactRequest _ alice bob = do
   ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON subscribe")
   let cReq' = strEncode cReq
   bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 10\nbob's info") #> ("11", "alice", OK)
-  ("", "a_contact", Right (REQ aInvId _ "bob's info")) <- (alice <#:)
+  ("", "a_contact", Right (A.REQ aInvId PQSupportOff _ "bob's info")) <- (alice <#:)
   -- RJCT must use correct contact connection
   alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
   alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
@@ -327,31 +393,32 @@ testSubscrNotification t (server, _) client = do
   withSmpServer (ATransport t) $
     client <# ("", "conn1", ERR (SMP AUTH)) -- this new server does not have the queue
 
-testMsgDeliveryServerRestart :: Transport c => TProxy c -> c -> c -> IO ()
-testMsgDeliveryServerRestart t alice bob = do
+testMsgDeliveryServerRestart :: forall c. Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO ()
+testMsgDeliveryServerRestart (alice, aPQ) (bob, bPQ) = do
+  let pq = pqConnectionMode aPQ bPQ
   withServer $ do
-    connect (alice, "alice") (bob, "bob")
-    bob #: ("1", "alice", "SEND F 2\nhi") #> ("1", "alice", MID 4)
+    connect' (alice, "alice", aPQ) (bob, "bob", bPQ)
+    bob #: ("1", "alice", "SEND F 2\nhi") #> ("1", "alice", A.MID 4 pq)
     bob <# ("", "alice", SENT 4)
-    alice <#= \case ("", "bob", Msg "hi") -> True; _ -> False
+    alice <#= \case ("", "bob", Msg' _ pq' "hi") -> pq == pq'; _ -> False
     alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)
     alice #:# "nothing else delivered before the server is killed"
 
   let server = SMPServer "localhost" testPort2 testKeyHash
   alice <#. ("", "", DOWN server ["bob"])
-  bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", MID 5)
+  bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", A.MID 5 pq)
   bob #:# "nothing else delivered before the server is restarted"
   alice #:# "nothing else delivered before the server is restarted"
 
   withServer $ do
     bob <# ("", "alice", SENT 5)
     alice <#. ("", "", UP server ["bob"])
-    alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
+    alice <#= \case ("", "bob", Msg' _ pq' "hello again") -> pq == pq'; _ -> False
     alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
 
   removeFile testStoreLogFile
   where
-    withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
+    withServer test' = withSmpServerStoreLogOn (transport @c) testPort2 (const test') `shouldReturn` ()
 
 testServerConnectionAfterError :: forall c. Transport c => TProxy c -> [c] -> IO ()
 testServerConnectionAfterError t _ = do
@@ -432,7 +499,7 @@ testConcurrentMsgDelivery _ alice bob = do
   ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW T INV subscribe")
   let cReq' = strEncode cReq
   bob #: ("11", "alice2", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") #> ("11", "alice2", OK)
-  ("", "bob2", Right (CONF _confId _ "bob's connInfo")) <- (alice <#:)
+  ("", "bob2", Right (A.CONF _confId PQSupportOff _ "bob's connInfo")) <- (alice <#:)
   -- below commands would be needed to accept bob's connection, but alice does not
   -- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
   -- bob <# ("", "alice", INFO "alice's connInfo")
@@ -492,16 +559,33 @@ testResumeDeliveryQuotaExceeded _ alice bob = do
   -- message 8 is skipped because of alice agent sending "QCONT" message
   bob #: ("5", "alice", "ACK 9") #> ("5", "alice", OK)
 
-connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
-connect (h1, name1) (h2, name2) = do
-  ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV subscribe")
+connect :: Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
+connect (h1, name1) (h2, name2) = connect' (h1, name1, IKPQOn) (h2, name2, PQSupportOn)
+
+connect' :: forall c. Transport c => (c, ByteString, InitialKeys) -> (c, ByteString, PQSupport) -> IO ()
+connect' (h1, name1, pqMode1) (h2, name2, pqMode2) = do
+  ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV" <> pqConnModeStr pqMode1 <> " subscribe")
   let cReq' = strEncode cReq
-  h2 #: ("c2", name1, "JOIN T " <> cReq' <> " subscribe 5\ninfo2") #> ("c2", name1, OK)
-  ("", _, Right (CONF connId _ "info2")) <- (h1 <#:)
+      pq = pqConnectionMode pqMode1 pqMode2
+      pqSup = CR.pqEncToSupport pq
+  h2 #: ("c2", name1, "JOIN T " <> cReq' <> enableKEMStr pqMode2 <> " subscribe 5\ninfo2") #> ("c2", name1, OK)
+  ("", _, Right (A.CONF connId pqSup' _ "info2")) <- (h1 <#:)
+  pqSup' `shouldBe` pqSup
   h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
-  h2 <# ("", name1, INFO "info1")
-  h2 <# ("", name1, CON)
-  h1 <# ("", name2, CON)
+  h2 <# ("", name1, A.INFO pqSup "info1")
+  h2 <# ("", name1, CON pq)
+  h1 <# ("", name2, CON pq)
+
+pqConnectionMode :: InitialKeys -> PQSupport -> PQEncryption
+pqConnectionMode pqMode1 pqMode2 = PQEncryption $ supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2
+
+enableKEMStr :: PQSupport -> ByteString
+enableKEMStr PQSupportOn = " " <> strEncode PQSupportOn
+enableKEMStr _ = ""
+
+pqConnModeStr :: InitialKeys -> ByteString
+pqConnModeStr (IKNoPQ PQSupportOff) = ""
+pqConnModeStr pq =  " " <> strEncode pq
 
 sendMessage :: Transport c => (c, ConnId) -> (c, ConnId) -> ByteString -> IO ()
 sendMessage (h1, name1) (h2, name2) msg = do
@@ -546,8 +630,8 @@ syntaxTests t = do
             <> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
             <> "%40localhost%3A5001%2F3456-w%3D%3D%23"
             <> urlEncode True sampleDhKey
-            <> "&v=1"
-            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> "&v=2"
+            <> "&e2e=v%3D2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
             <> " subscribe "
             <> "14\nbob's connInfo"
         )

tests/AgentTests/ConnectionRequestTests.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module AgentTests.ConnectionRequestTests where
@@ -12,7 +15,8 @@ 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 (..), supportedSMPClientVRange)
+import Simplex.Messaging.Protocol (ProtocolServer (..), pattern VersionSMPC, supportedSMPClientVRange)
+import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
 import Simplex.Messaging.Version
 import Test.Hspec
 
@@ -37,7 +41,7 @@ queue :: SMPQueueUri
 queue = SMPQueueUri supportedSMPClientVRange queueAddr
 
 queueV1 :: SMPQueueUri
-queueV1 = SMPQueueUri (mkVersionRange 1 1) queueAddr
+queueV1 = SMPQueueUri (mkVersionRange (VersionSMPC 1) (VersionSMPC 1)) queueAddr
 
 testDhKey :: C.PublicKeyX25519
 testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
@@ -51,8 +55,8 @@ testDhKeyStrUri = urlEncode True testDhKeyStr
 connReqData :: ConnReqUriData
 connReqData =
   ConnReqUriData
-    { crScheme = CRSSimplex,
-      crAgentVRange = mkVersionRange 1 1,
+    { crScheme = SSSimplex,
+      crAgentVRange = mkVersionRange (VersionSMPA 2) (VersionSMPA 2),
       crSmpQueues = [queueV1],
       crClientData = Nothing
     }
@@ -60,22 +64,25 @@ connReqData =
 testDhPubKey :: C.PublicKeyX448
 testDhPubKey = "MEIwBQYDK2VvAzkAmKuSYeQ/m0SixPDS8Wq8VBaTS1cW+Lp0n0h4Diu+kUpR+qXx4SDJ32YGEFoGFGSbGPry5Ychr6U="
 
-testE2ERatchetParams :: E2ERatchetParamsUri 'C.X448
-testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange 1 1) testDhPubKey testDhPubKey
+testE2ERatchetParams :: RcvE2ERatchetParamsUri 'C.X448
+testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange (VersionE2E 1) (VersionE2E 1)) testDhPubKey testDhPubKey Nothing
 
-testE2ERatchetParams12 :: E2ERatchetParamsUri 'C.X448
-testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey
+testE2ERatchetParams12 :: RcvE2ERatchetParamsUri 'C.X448
+testE2ERatchetParams12 = E2ERatchetParamsUri (supportedE2EEncryptVRange PQSupportOn) testDhPubKey testDhPubKey Nothing
 
 connectionRequest :: AConnectionRequestUri
 connectionRequest =
   ACR SCMInvitation $
     CRInvitationUri connReqData testE2ERatchetParams
 
+contactAddress :: AConnectionRequestUri
+contactAddress = ACR SCMContact $ CRContactUri connReqData
+
 connectionRequestCurrentRange :: AConnectionRequestUri
 connectionRequestCurrentRange =
   ACR SCMInvitation $
     CRInvitationUri
-      connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]}
+      connReqData {crAgentVRange = supportedSMPAgentVRange PQSupportOn, crSmpQueues = [queueV1, queueV1]}
       testE2ERatchetParams12
 
 connectionRequestClientDataEmpty :: AConnectionRequestUri
@@ -94,7 +101,7 @@ connectionRequestTests =
     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 1 2}
+      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)
@@ -111,45 +118,51 @@ connectionRequestTests =
         `shouldBe` Right queueV1
     it "should serialize connection requests" $ do
       strEncode connectionRequest
-        `shouldBe` "simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+        `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=1-4&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+        `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%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+          <> "&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
       strEncode connectionRequestClientDataEmpty
-        `shouldBe` "simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+        `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=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
+        `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=1"
+            <> "&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=1"
+            <> "&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=1-1"
+            <> "&v=2-2"
         )
         `shouldBe` Right connectionRequest
       strDecode
@@ -157,9 +170,9 @@ connectionRequestTests =
             <> 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%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+            <> "&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=1-4"
+            <> "&v=2-5"
         )
         `shouldBe` Right connectionRequestCurrentRange
       strDecode
@@ -167,7 +180,7 @@ connectionRequestTests =
             <> testDhKeyStrUri
             <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
             <> "&data=%7B%7D"
-            <> "&v=1-1"
+            <> "&v=2-2"
         )
         `shouldBe` Right connectionRequestClientDataEmpty
       strDecode
@@ -175,6 +188,6 @@ connectionRequestTests =
             <> 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=1-1"
+            <> "&v=2"
         )
         `shouldBe` Right connectionRequestClientData

tests/AgentTests/DoubleRatchetTests.hs

@@ -1,75 +1,178 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 module AgentTests.DoubleRatchetTests where
 
 import Control.Concurrent.STM
+import Control.Monad (when)
 import Control.Monad.Except
+import Control.Monad.IO.Class
 import Crypto.Random (ChaChaDRG)
-import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson (FromJSON, ToJSON, (.=))
 import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Map.Strict as M
+import Data.Type.Equality
 import Simplex.Messaging.Crypto (Algorithm (..), AlgorithmI, CryptoError, DhAlgorithm)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Crypto.Ratchet
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util ((<$$>))
+import Simplex.Messaging.Version
 import Test.Hspec
 
 doubleRatchetTests :: Spec
 doubleRatchetTests = do
   describe "double-ratchet encryption/decryption" $ do
-    it "should serialize and parse message header" testMessageHeader
-    it "should encrypt and decrypt messages" $ do
-      withRatchets @X25519 testEncryptDecrypt
-      withRatchets @X448 testEncryptDecrypt
-    it "should encrypt and decrypt skipped messages" $ do
-      withRatchets @X25519 testSkippedMessages
-      withRatchets @X448 testSkippedMessages
-    it "should encrypt and decrypt many messages" $ do
-      withRatchets @X25519 testManyMessages
-    it "should allow skipped after ratchet advance" $ do
-      withRatchets @X25519 testSkippedAfterRatchetAdvance
+    it "should serialize and parse message header" $ do
+      testAlgs $ testMessageHeader kdfX3DHE2EEncryptVersion
+      testAlgs $ testMessageHeader $ max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+    describe "message tests" $ runMessageTests initRatchets False
     it "should encode/decode ratchet as JSON" $ do
-      testKeyJSON C.SX25519
-      testKeyJSON C.SX448
-      testRatchetJSON C.SX25519
-      testRatchetJSON C.SX448
-    it "should agree the same ratchet parameters" $ do
-      testX3dh C.SX25519
-      testX3dh C.SX448
-    it "should agree the same ratchet parameters with version 1" $ do
-      testX3dhV1 C.SX25519
-      testX3dhV1 C.SX448
+      testAlgs testKeyJSON
+      testAlgs testRatchetJSON
+      testVersionJSON
+    it "should decode v2 Ratchet with default field values" $ testDecodeV2RatchetJSON
+    it "should agree the same ratchet parameters" $ testAlgs testX3dh
+    it "should agree the same ratchet parameters with version 1" $ testAlgs testX3dhV1
+  describe "post-quantum hybrid KEM double-ratchet algorithm" $ do
+    describe "hybrid KEM key agreement" $ do
+      it "should propose KEM during agreement, but no shared secret" $ testAlgs testPqX3dhProposeInReply
+      it "should agree shared secret using KEM" $ testAlgs testPqX3dhProposeAccept
+      it "should reject proposed KEM in reply" $ testAlgs testPqX3dhProposeReject
+      it "should allow second proposal in reply" $ testAlgs testPqX3dhProposeAgain
+    describe "hybrid KEM key agreement errors" $ do
+      it "should fail if reply contains acceptance without proposal" $ testAlgs testPqX3dhAcceptWithoutProposalError
+    describe "ratchet encryption/decryption" $ do
+      it "should serialize and parse public KEM params" testKEMParams
+      it "should serialize and parse message header" $ testAlgs testMessageHeaderKEM
+      describe "message tests, KEM proposed" $ runMessageTests initRatchetsKEMProposed True
+      describe "message tests, KEM accepted" $ runMessageTests initRatchetsKEMAccepted False
+      describe "message tests, KEM proposed again in reply" $ runMessageTests initRatchetsKEMProposedAgain True
+      it "should disable and re-enable KEM" $ withRatchets_ @X25519 initRatchetsKEMAccepted testDisableEnableKEM
+      it "should disable and re-enable KEM (always set PQEncryption)" $ withRatchets_ @X25519 initRatchetsKEMAccepted testDisableEnableKEMStrict
+      it "should enable KEM when it was not enabled in handshake" $ withRatchets_ @X25519 initRatchets testEnableKEM
+      it "should enable KEM when it was not enabled in handshake (always set PQEncryption)" $ withRatchets_ @X25519 initRatchets testEnableKEMStrict
+
+runMessageTests ::
+  (forall a. (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a, Encrypt a, Decrypt a, EncryptDecryptSpec a)) ->
+  Bool ->
+  Spec
+runMessageTests initRatchets_ agreeRatchetKEMs = do
+  it "should encrypt and decrypt messages" $ run $ testEncryptDecrypt agreeRatchetKEMs
+  it "should encrypt and decrypt skipped messages" $ run $ testSkippedMessages agreeRatchetKEMs
+  it "should encrypt and decrypt many messages" $ run $ testManyMessages agreeRatchetKEMs
+  it "should allow skipped after ratchet advance" $ run $ testSkippedAfterRatchetAdvance agreeRatchetKEMs
+  where
+    run :: (forall a. (AlgorithmI a, DhAlgorithm a) => TestRatchets a) -> IO ()
+    run test = do
+      withRatchets_ @X25519 initRatchets_ test
+      withRatchets_ @X448 initRatchets_ test
+
+
+testAlgs :: (forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()) -> IO ()
+testAlgs test = test C.SX25519 >> test C.SX448
 
 paddedMsgLen :: Int
 paddedMsgLen = 100
 
-fullMsgLen :: Int
-fullMsgLen = 1 + fullHeaderLen + C.authTagSize + paddedMsgLen
+fullMsgLen :: Ratchet a -> Int
+fullMsgLen Ratchet {rcSupportKEM, rcVersion} = headerLenLength + fullHeaderLen v rcSupportKEM + C.authTagSize + paddedMsgLen
+  where
+    v = current rcVersion
+    headerLenLength = case rcSupportKEM of
+      PQSupportOn | v >= pqRatchetE2EEncryptVersion -> 3 -- two bytes are added because of two Large used in new encoding
+      _ -> 1
 
-testMessageHeader :: Expectation
-testMessageHeader = do
-  (k, _) <- atomically . C.generateKeyPair @X25519 =<< C.newRandom
-  let hdr = MsgHeader {msgMaxVersion = currentE2EEncryptVersion, msgDHRs = k, msgPN = 0, msgNs = 0}
-  parseAll (smpP @(MsgHeader 'X25519)) (smpEncode hdr) `shouldBe` Right hdr
+testMessageHeader :: forall a. AlgorithmI a => VersionE2E -> C.SAlgorithm a -> Expectation
+testMessageHeader v _ = do
+  (k, _) <- atomically . C.generateKeyPair @a =<< C.newRandom
+  let hdr = MsgHeader {msgMaxVersion = v, msgDHRs = k, msgKEM = Nothing, msgPN = 0, msgNs = 0}
+  parseAll (msgHeaderP v) (encodeMsgHeader v hdr) `shouldBe` Right hdr
+
+testKEMParams :: Expectation
+testKEMParams = do
+  g <- C.newRandom
+  (kem, _) <- sntrup761Keypair g
+  let kemParams = ARKP SRKSProposed $ RKParamsProposed kem
+  parseAll (smpP @ARKEMParams) (smpEncode kemParams) `shouldBe` Right kemParams
+  (kem', _) <- sntrup761Keypair g
+  (ct, _) <- sntrup761Enc g kem
+  let kemParams' = ARKP SRKSAccepted $ RKParamsAccepted ct kem'
+  parseAll (smpP @ARKEMParams) (smpEncode kemParams') `shouldBe` Right kemParams'
+
+testMessageHeaderKEM :: forall a. AlgorithmI a => C.SAlgorithm a -> Expectation
+testMessageHeaderKEM _ = do
+  g <- C.newRandom
+  (k, _) <- atomically $ C.generateKeyPair @a g
+  (kem, _) <- sntrup761Keypair g
+  let msgMaxVersion = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+      msgKEM = Just . ARKP SRKSProposed $ RKParamsProposed kem
+      hdr = MsgHeader {msgMaxVersion, msgDHRs = k, msgKEM, msgPN = 0, msgNs = 0}
+  parseAll (msgHeaderP msgMaxVersion) (encodeMsgHeader msgMaxVersion hdr) `shouldBe` Right hdr
+  (kem', _) <- sntrup761Keypair g
+  (ct, _) <- sntrup761Enc g kem
+  let msgKEM' = Just . ARKP SRKSAccepted $ RKParamsAccepted ct kem'
+      hdr' = MsgHeader {msgMaxVersion, msgDHRs = k, msgKEM = msgKEM', msgPN = 0, msgNs = 0}
+  parseAll (msgHeaderP msgMaxVersion) (encodeMsgHeader msgMaxVersion hdr') `shouldBe` Right hdr'
 
 pattern Decrypted :: ByteString -> Either CryptoError (Either CryptoError ByteString)
 pattern Decrypted msg <- Right (Right msg)
 
-type TestRatchets a = (AlgorithmI a, DhAlgorithm a) => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO ()
+type Encrypt a = TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString)
 
-testEncryptDecrypt :: TestRatchets a
-testEncryptDecrypt alice bob = do
+type Decrypt a = TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString))
+
+type EncryptDecryptSpec a = (TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys), ByteString) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> Expectation
+
+type TestRatchets a =
+  TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) ->
+  TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) ->
+  Encrypt a ->
+  Decrypt a ->
+  EncryptDecryptSpec a ->
+  IO ()
+
+deriving instance Eq (Ratchet a)
+
+deriving instance Eq (SndRatchet a)
+
+deriving instance Eq RcvRatchet
+
+deriving instance Eq RatchetKEM
+
+deriving instance Eq RatchetKEMAccepted
+
+deriving instance Eq RatchetInitParams
+
+deriving instance Eq RatchetKey
+
+instance Eq ARKEMParams where
+  (ARKP s ps) == (ARKP s' ps') = case testEquality s s' of
+    Just Refl -> ps == ps'
+    Nothing -> False
+
+deriving instance Eq (MsgHeader a)
+
+initRatchetKEM :: (AlgorithmI a, DhAlgorithm a) => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO ()
+initRatchetKEM s r = encryptDecrypt (Just $ PQEncOn) (const ()) (const ()) (s, "initialising ratchet") r
+
+testEncryptDecrypt :: (AlgorithmI a, DhAlgorithm a) => Bool -> TestRatchets a
+testEncryptDecrypt agreeRatchetKEMs alice bob encrypt decrypt (#>) = do
+  when agreeRatchetKEMs $ initRatchetKEM bob alice >> initRatchetKEM alice bob
   (bob, "hello alice") #> alice
   (alice, "hello bob") #> bob
   Right b1 <- encrypt bob "how are you, alice?"
@@ -88,8 +191,9 @@ testEncryptDecrypt alice bob = do
   (alice, "I'm here too, same") #> bob
   pure ()
 
-testSkippedMessages :: TestRatchets a
-testSkippedMessages alice bob = do
+testSkippedMessages :: (AlgorithmI a, DhAlgorithm a) => Bool -> TestRatchets a
+testSkippedMessages agreeRatchetKEMs alice bob encrypt decrypt _ = do
+  when agreeRatchetKEMs $ initRatchetKEM bob alice >> initRatchetKEM alice bob
   Right msg1 <- encrypt bob "hello alice"
   Right msg2 <- encrypt bob "hello there again"
   Right msg3 <- encrypt bob "are you there?"
@@ -99,8 +203,9 @@ testSkippedMessages alice bob = do
   Decrypted "hello alice" <- decrypt alice msg1
   pure ()
 
-testManyMessages :: TestRatchets a
-testManyMessages alice bob = do
+testManyMessages :: (AlgorithmI a, DhAlgorithm a) => Bool -> TestRatchets a
+testManyMessages agreeRatchetKEMs alice bob _ _ (#>) = do
+  when agreeRatchetKEMs $ initRatchetKEM bob alice >> initRatchetKEM alice bob
   (bob, "b1") #> alice
   (bob, "b2") #> alice
   (bob, "b3") #> alice
@@ -117,8 +222,9 @@ testManyMessages alice bob = do
   (bob, "b15") #> alice
   (bob, "b16") #> alice
 
-testSkippedAfterRatchetAdvance :: TestRatchets a
-testSkippedAfterRatchetAdvance alice bob = do
+testSkippedAfterRatchetAdvance :: (AlgorithmI a, DhAlgorithm a) => Bool -> TestRatchets a
+testSkippedAfterRatchetAdvance agreeRatchetKEMs alice bob encrypt decrypt (#>) = do
+  when agreeRatchetKEMs $ initRatchetKEM bob alice >> initRatchetKEM alice bob
   (bob, "b1") #> alice
   Right b2 <- encrypt bob "b2"
   Right b3 <- encrypt bob "b3"
@@ -152,6 +258,84 @@ testSkippedAfterRatchetAdvance alice bob = do
   Decrypted "b11" <- decrypt alice b11
   pure ()
 
+testDisableEnableKEM :: forall a. (AlgorithmI a, DhAlgorithm a) => TestRatchets a
+testDisableEnableKEM alice bob _ _ _ = do
+  (bob, "hello alice") !#> alice
+  (alice, "hello bob") !#> bob
+  (bob, "disabling KEM") !#>\ alice
+  (alice, "still disabling KEM") !#> bob
+  (bob, "now KEM is disabled") \#> alice
+  (alice, "KEM is disabled for both sides") \#> bob
+  (bob, "trying to enable KEM") \#>! alice
+  (alice, "but unless alice enables it too it won't enable") \#> bob
+  (bob, "KEM is disabled") \#> alice
+  (alice, "KEM is disabled for both sides") \#> bob
+  (bob, "enabling KEM again") \#>! alice
+  (alice, "and alice accepts it this time") \#>! bob
+  (bob, "still enabling KEM") \#>! alice
+  (alice, "now KEM is enabled") !#> bob
+  (bob, "KEM is enabled for both sides") !#> alice
+
+testDisableEnableKEMStrict :: forall a. (AlgorithmI a, DhAlgorithm a) => TestRatchets a
+testDisableEnableKEMStrict alice bob _ _ _ = do
+  (bob, "hello alice") !#>! alice
+  (alice, "hello bob") !#>! bob
+  (bob, "disabling KEM") !#>\ alice
+  (alice, "still disabling KEM") !#>! bob
+  (bob, "now KEM is disabled") \#>\ alice
+  (alice, "KEM is disabled for both sides") \#>\ bob
+  (bob, "trying to enable KEM") \#>! alice
+  (alice, "but unless alice enables it too it won't enable") \#>\ bob
+  (bob, "KEM is disabled") \#>! alice
+  (alice, "KEM is disabled for both sides") \#>\ bob
+  (bob, "enabling KEM again") \#>! alice
+  (alice, "and alice accepts it this time") \#>! bob
+  (bob, "still enabling KEM") \#>! alice
+  (alice, "now KEM is enabled") !#>! bob
+  (bob, "KEM is enabled for both sides") !#>! alice
+
+testEnableKEM :: forall a. (AlgorithmI a, DhAlgorithm a) => TestRatchets a
+testEnableKEM alice bob _ _ _ = do
+  (bob, "hello alice") \#> alice
+  (alice, "hello bob") \#> bob
+  (bob, "enabling KEM") \#>! alice
+  (bob, "KEM not enabled yet") \#>! alice
+  (alice, "accepting KEM") \#>! bob
+  (alice, "KEM not enabled yet here too") \#>! bob
+  (bob, "KEM is still not enabled") \#>! alice
+  (alice, "now KEM is enabled") !#>! bob
+  (bob, "now KEM is enabled for both sides") !#> alice
+  (alice, "still enabled for both sides") !#> bob
+  (bob, "still enabled for both sides 2") !#> alice
+  (alice, "disabling KEM") !#>\ bob
+  (bob, "KEM not disabled yet") !#> alice
+  (alice, "KEM disabled") \#> bob
+  (bob, "KEM disabled on both sides") \#> alice
+
+testEnableKEMStrict :: forall a. (AlgorithmI a, DhAlgorithm a) => TestRatchets a
+testEnableKEMStrict alice bob _ _ _ = do
+  (bob, "hello alice") \#>\ alice
+  (alice, "hello bob") \#>\ bob
+  (bob, "enabling KEM") \#>! alice
+  (bob, "KEM not enabled yet") \#>! alice
+  (alice, "accepting KEM") \#>! bob
+  (alice, "KEM not enabled yet here too") \#>! bob
+  (bob, "KEM is still not enabled") \#>! alice
+  (alice, "now KEM is enabled") !#>! bob
+  (bob, "now KEM is enabled for both sides") !#>! alice
+  (alice, "still enabled for both sides") !#>! bob
+  (bob, "still enabled for both sides 2") !#>! alice
+  (alice, "disabling KEM") !#>\ bob
+  (bob, "KEM not disabled yet") !#>! alice
+  (alice, "KEM disabled") \#>\ bob
+  (bob, "KEM disabled on both sides") \#>! alice
+  (alice, "KEM still disabled 1") \#>\ bob
+  (bob, "KEM still disabled 2") \#>! alice
+  (alice, "KEM still disabled 3") \#>\ bob
+  (bob, "KEM still disabled 4") \#>! alice
+  (alice, "KEM still disabled 5") \#>\ bob
+  (bob, "KEM still disabled 6") \#>! alice
+
 testKeyJSON :: forall a. AlgorithmI a => C.SAlgorithm a -> IO ()
 testKeyJSON _ = do
   (k, pk) <- atomically . C.generateKeyPair @a =<< C.newRandom
@@ -160,10 +344,33 @@ testKeyJSON _ = do
 
 testRatchetJSON :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
 testRatchetJSON _ = do
-  (alice, bob) <- initRatchets @a
+  (alice, bob, _, _, _) <- initRatchets @a
   testEncodeDecode alice
   testEncodeDecode bob
 
+testVersionJSON :: IO ()
+testVersionJSON = do
+  testEncodeDecode $ rv 1 1
+  testEncodeDecode $ rv 1 2
+  -- let bad = RVersions 2 1
+  -- Left err <- pure $ J.eitherDecode' @RatchetVersions (J.encode bad)
+  -- err `shouldContain` "bad version range"
+  testDecodeRV $ (1 :: Int, 2 :: Int)
+  testDecodeRV $ J.object ["current" .= (1 :: Int), "maxSupported" .= (2 :: Int)]
+  where
+    rv v1 v2 = RatchetVersions (VersionE2E v1) (VersionE2E v2)
+    testDecodeRV :: ToJSON a => a -> Expectation
+    testDecodeRV a = J.eitherDecode' (J.encode a) `shouldBe` Right (rv 1 2)
+
+testDecodeV2RatchetJSON :: IO ()
+testDecodeV2RatchetJSON = do
+  let v2RatchetJSON = "{\"rcVersion\":[2,2],\"rcAD\":\"2GEJrq48TmQse6NR16I-hrI0tSySZQ57E_g46nDceAPRAiF6j0drq26RTE7be6X7uiB4RaGJGf4QRXzcYuVtWw==\",\"rcDHRs\":\"TUM0Q0FRQXdCUVlESzJWdUJDSUVJRkNYbUxtSHQ3SUNfeHpGTi1Qb3ZqTVQ3S2p6XzZlZlBjOG9fRFY2RWxKOQ==\",\"rcRK\":\"BOX2X7YW5qDSp2XknY_lqacSrtDqQNPvS6iJlZIs3G0=\",\"rcNs\":0,\"rcNr\":0,\"rcPN\":0,\"rcNHKs\":\"IMouSkXUvzT_mo0WM-pqEUK09-HTLk9WOTCFQglyQxU=\",\"rcNHKr\":\"g-tus1clYPV0rGlzkf5a959tUqDYQVZ1FpcPeXdKwxI=\"}"
+  Right (r :: Ratchet X25519) <- pure $ J.eitherDecodeStrict' v2RatchetJSON
+  rcSupportKEM r `shouldBe` PQSupportOff
+  rcEnableKEM r `shouldBe` PQEncOff
+  rcSndKEM r `shouldBe` PQEncOff
+  rcRcvKEM r `shouldBe` PQEncOff
+
 testEncodeDecode :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Expectation
 testEncodeDecode x = do
   let j = J.encode x
@@ -173,77 +380,255 @@ testEncodeDecode x = do
 testX3dh :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
 testX3dh _ = do
   g <- C.newRandom
-  (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams @a g currentE2EEncryptVersion
-  (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams @a g currentE2EEncryptVersion
-  let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
-      paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
+  let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+  (pkBob1, pkBob2, Nothing, AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v Nothing
+  (pkAlice1, pkAlice2, Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOff
+  let paramsBob = pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice
+  paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
   paramsAlice `shouldBe` paramsBob
 
 testX3dhV1 :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
 testX3dhV1 _ = do
   g <- C.newRandom
-  (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams @a g 1
-  (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams @a g 1
-  let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
-      paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
+  (pkBob1, pkBob2, Nothing, AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g (VersionE2E 1) Nothing
+  (pkAlice1, pkAlice2, Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams @a g (VersionE2E 1) PQSupportOff
+  let paramsBob = pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice
+  paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
   paramsAlice `shouldBe` paramsBob
 
-(#>) :: (AlgorithmI a, DhAlgorithm a) => (TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys), ByteString) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> Expectation
-(alice, msg) #> bob = do
-  Right msg' <- encrypt alice msg
-  Decrypted msg'' <- decrypt bob msg'
+testPqX3dhProposeInReply :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
+testPqX3dhProposeInReply _ = do
+  g <- C.newRandom
+  let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+  -- initiate (no KEM)
+  (pkAlice1, pkAlice2, Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOff
+  -- propose KEM in reply
+  (pkBob1, pkBob2, pKemBob_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSProposed ProposeKEM)
+  Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemBob_ e2eAlice
+  Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
+  paramsAlice `compatibleRatchets` paramsBob
+
+testPqX3dhProposeAccept :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
+testPqX3dhProposeAccept _ = do
+  g <- C.newRandom
+  let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+  -- initiate (propose KEM)
+  (pkAlice1, pkAlice2, pKemAlice_@(Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
+  E2ERatchetParams _ _ _ (Just (RKParamsProposed aliceKem)) <- pure e2eAlice
+  -- accept KEM
+  (pkBob1, pkBob2, pKemBob_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSAccepted $ AcceptKEM aliceKem)
+  Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemBob_ e2eAlice
+  Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKemAlice_ e2eBob
+  paramsAlice `compatibleRatchets` paramsBob
+
+testPqX3dhProposeReject :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
+testPqX3dhProposeReject _ = do
+  g <- C.newRandom
+  let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+  -- initiate (propose KEM)
+  (pkAlice1, pkAlice2, pKemAlice_@(Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
+  E2ERatchetParams _ _ _ (Just (RKParamsProposed _)) <- pure e2eAlice
+  -- reject KEM
+  (pkBob1, pkBob2, Nothing, AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v Nothing
+  Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice
+  Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKemAlice_ e2eBob
+  paramsAlice `compatibleRatchets` paramsBob
+
+testPqX3dhAcceptWithoutProposalError :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
+testPqX3dhAcceptWithoutProposalError _ = do
+  g <- C.newRandom
+  let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+  -- initiate (no KEM)
+  (pkAlice1, pkAlice2, Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOff
+  E2ERatchetParams _ _ _ Nothing <- pure e2eAlice
+  -- incorrectly accept KEM
+  -- we don't have key in proposal, so we just generate it
+  (k, _) <- sntrup761Keypair g
+  (pkBob1, pkBob2, pKemBob_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSAccepted $ AcceptKEM k)
+  pqX3dhSnd pkBob1 pkBob2 pKemBob_ e2eAlice `shouldBe` Left C.CERatchetKEMState
+  runExceptT (pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob) `shouldReturn` Left C.CERatchetKEMState
+
+testPqX3dhProposeAgain :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
+testPqX3dhProposeAgain _ = do
+  g <- C.newRandom
+  let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+  -- initiate (propose KEM)
+  (pkAlice1, pkAlice2, pKemAlice_@(Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
+  E2ERatchetParams _ _ _ (Just (RKParamsProposed _)) <- pure e2eAlice
+  -- propose KEM again in reply - this is not an error
+  (pkBob1, pkBob2, pKemBob_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSProposed ProposeKEM)
+  Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemBob_ e2eAlice
+  Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKemAlice_ e2eBob
+  paramsAlice `compatibleRatchets` paramsBob
+
+compatibleRatchets :: (RatchetInitParams, x) -> (RatchetInitParams, x) -> Expectation
+compatibleRatchets
+  (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, _)
+  (RatchetInitParams {assocData = ad, ratchetKey = rk, sndHK = shk, rcvNextHK = rnhk, kemAccepted = ka}, _) = do
+    assocData == ad && ratchetKey == rk && sndHK == shk && rcvNextHK == rnhk `shouldBe` True
+    case (kemAccepted, ka) of
+      (Just RatchetKEMAccepted {rcPQRr, rcPQRss, rcPQRct}, Just RatchetKEMAccepted {rcPQRr = pqk, rcPQRss = pqss, rcPQRct = pqct}) ->
+        pqk /= rcPQRr && pqss == rcPQRss && pqct == rcPQRct `shouldBe` True
+      (Nothing, Nothing) -> pure ()
+      _ -> expectationFailure "RatchetInitParams params are not compatible"
+
+encryptDecrypt :: (AlgorithmI a, DhAlgorithm a) => Maybe PQEncryption -> (Ratchet a -> ()) -> (Ratchet a -> ()) -> EncryptDecryptSpec a
+encryptDecrypt pqEnc validSnd validRcv (alice, msg) bob = do
+  Right msg' <- withTVar (encrypt_ pqEnc) validSnd alice msg
+  Decrypted msg'' <- decrypt' validRcv bob msg'
   msg'' `shouldBe` msg
 
-withRatchets :: forall a. (AlgorithmI a, DhAlgorithm a) => (TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO ()) -> Expectation
-withRatchets test = do
+-- enable KEM (currently disabled)
+(\#>!) :: (AlgorithmI a, DhAlgorithm a) => EncryptDecryptSpec a
+(s, msg) \#>! r = encryptDecrypt (Just PQEncOn) noSndKEM noRcvKEM (s, msg) r
+
+-- enable KEM (currently enabled)
+(!#>!) :: (AlgorithmI a, DhAlgorithm a) => EncryptDecryptSpec a
+(s, msg) !#>! r = encryptDecrypt (Just PQEncOn) hasSndKEM hasRcvKEM (s, msg) r
+
+-- KEM enabled (no user preference)
+(!#>) :: (AlgorithmI a, DhAlgorithm a) => EncryptDecryptSpec a
+(s, msg) !#> r = encryptDecrypt Nothing hasSndKEM hasRcvKEM (s, msg) r
+
+-- disable KEM (currently enabled)
+(!#>\) :: (AlgorithmI a, DhAlgorithm a) => EncryptDecryptSpec a
+(s, msg) !#>\ r = encryptDecrypt (Just PQEncOff) hasSndKEM hasRcvKEM (s, msg) r
+
+-- disable KEM (currently disabled)
+(\#>\) :: (AlgorithmI a, DhAlgorithm a) => EncryptDecryptSpec a
+(s, msg) \#>\ r = encryptDecrypt (Just PQEncOff) noSndKEM noSndKEM (s, msg) r
+
+-- KEM disabled (no user preference)
+(\#>) :: (AlgorithmI a, DhAlgorithm a) => EncryptDecryptSpec a
+(s, msg) \#> r = encryptDecrypt Nothing noSndKEM noSndKEM (s, msg) r
+
+withRatchets_ :: IO (Ratchet a, Ratchet a, Encrypt a, Decrypt a, EncryptDecryptSpec a) -> TestRatchets a -> Expectation
+withRatchets_ initRatchets_ test = do
   ga <- C.newRandom
   gb <- C.newRandom
-  (a, b) <- initRatchets @a
+  (a, b, encrypt, decrypt, (#>)) <- initRatchets_
   alice <- newTVarIO (ga, a, M.empty)
   bob <- newTVarIO (gb, b, M.empty)
-  test alice bob `shouldReturn` ()
+  test alice bob encrypt decrypt (#>) `shouldReturn` ()
 
-initRatchets :: (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a)
+initRatchets :: (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a, Encrypt a, Decrypt a, EncryptDecryptSpec a)
 initRatchets = do
   g <- C.newRandom
-  (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams g currentE2EEncryptVersion
-  (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams g currentE2EEncryptVersion
-  let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice
-      paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob
+  let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+  (pkBob1, pkBob2, _pKemParams@Nothing, AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v Nothing
+  (pkAlice1, pkAlice2, _pKem@Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOff
+  Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice
+  Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
   (_, pkBob3) <- atomically $ C.generateKeyPair g
-  let bob = initSndRatchet supportedE2EEncryptVRange (C.publicKey pkAlice2) pkBob3 paramsBob
-      alice = initRcvRatchet supportedE2EEncryptVRange pkAlice2 paramsAlice
-  pure (alice, bob)
+  let vs = testRatchetVersions PQSupportOff
+      bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
+      alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOff
+  pure (alice, bob, encrypt' noSndKEM, decrypt' noRcvKEM, (\#>))
 
-encrypt_ :: AlgorithmI a => (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))
-encrypt_ (_, rc, _) msg =
-  runExceptT (rcEncrypt rc paddedMsgLen msg)
+initRatchetsKEMProposed :: forall a. (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a, Encrypt a, Decrypt a, EncryptDecryptSpec a)
+initRatchetsKEMProposed = do
+  g <- C.newRandom
+  let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+  -- initiate (no KEM)
+  (pkAlice1, pkAlice2, Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOff
+  -- propose KEM in reply
+  let useKem = AUseKEM SRKSProposed ProposeKEM
+  (pkBob1, pkBob2, pKemParams_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem)
+  Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
+  Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
+  (_, pkBob3) <- atomically $ C.generateKeyPair g
+  let vs = testRatchetVersions PQSupportOn
+      bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
+      alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
+  pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
+
+initRatchetsKEMAccepted :: forall a. (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a, Encrypt a, Decrypt a, EncryptDecryptSpec a)
+initRatchetsKEMAccepted = do
+  g <- C.newRandom
+  let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+  -- initiate (propose)
+  (pkAlice1, pkAlice2, pKem_@(Just _), e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOn
+  E2ERatchetParams _ _ _ (Just (RKParamsProposed aliceKem)) <- pure e2eAlice
+  -- accept
+  let useKem = AUseKEM SRKSAccepted (AcceptKEM aliceKem)
+  (pkBob1, pkBob2, pKemParams_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem)
+  Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
+  Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob
+  (_, pkBob3) <- atomically $ C.generateKeyPair g
+  let vs = testRatchetVersions PQSupportOn
+      bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
+      alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
+  pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
+
+initRatchetsKEMProposedAgain :: forall a. (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a, Encrypt a, Decrypt a, EncryptDecryptSpec a)
+initRatchetsKEMProposedAgain = do
+  g <- C.newRandom
+  let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
+  -- initiate (propose KEM)
+  (pkAlice1, pkAlice2, pKem_@(Just _), e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOn
+  -- propose KEM again in reply
+  let useKem = AUseKEM SRKSProposed ProposeKEM
+  (pkBob1, pkBob2, pKemParams_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem)
+  Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
+  Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob
+  (_, pkBob3) <- atomically $ C.generateKeyPair g
+  let vs = testRatchetVersions PQSupportOn
+      bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
+      alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
+  pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
+
+testRatchetVersions :: PQSupport -> RatchetVersions
+testRatchetVersions pq =
+  let v = maxVersion $ supportedE2EEncryptVRange pq
+   in RatchetVersions v v
+
+encrypt_ :: AlgorithmI a => Maybe PQEncryption -> (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))
+encrypt_ pqEnc_ (_, rc, _) msg =
+  -- print msg >>
+  runExceptT (rcEncrypt rc paddedMsgLen msg pqEnc_ currentE2EEncryptVersion)
     >>= either (pure . Left) checkLength
   where
     checkLength (msg', rc') = do
-      B.length msg' `shouldBe` fullMsgLen
+      B.length msg' `shouldBe` fullMsgLen rc'
       pure $ Right (msg', rc', SMDNoChange)
 
 decrypt_ :: (AlgorithmI a, DhAlgorithm a) => (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff))
 decrypt_ (g, rc, smks) msg = runExceptT $ rcDecrypt g rc smks msg
 
-encrypt :: AlgorithmI a => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString)
-encrypt = withTVar encrypt_
+encrypt' :: AlgorithmI a => (Ratchet a -> ()) -> Encrypt a
+encrypt' = withTVar $ encrypt_ Nothing
 
-decrypt :: (AlgorithmI a, DhAlgorithm a) => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString))
-decrypt = withTVar decrypt_
+decrypt' :: (AlgorithmI a, DhAlgorithm a) => (Ratchet a -> ()) -> Decrypt a
+decrypt' = withTVar decrypt_
+
+noSndKEM :: Ratchet a -> ()
+noSndKEM Ratchet {rcSndKEM = PQEncOn} = error "snd ratchet has KEM"
+noSndKEM _ = ()
+
+noRcvKEM :: Ratchet a -> ()
+noRcvKEM Ratchet {rcRcvKEM = PQEncOn} = error "rcv ratchet has KEM"
+noRcvKEM _ = ()
+
+hasSndKEM :: Ratchet a -> ()
+hasSndKEM Ratchet {rcSndKEM = PQEncOn} = ()
+hasSndKEM _ = error "snd ratchet has no KEM"
+
+hasRcvKEM :: Ratchet a -> ()
+hasRcvKEM Ratchet {rcRcvKEM = PQEncOn} = ()
+hasRcvKEM _ = error "rcv ratchet has no KEM"
 
 withTVar ::
   AlgorithmI a =>
   ((TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e (r, Ratchet a, SkippedMsgDiff))) ->
+  (Ratchet a -> ()) ->
   TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) ->
   ByteString ->
   IO (Either e r)
-withTVar op rcVar msg = do
+withTVar op valid rcVar msg = do
   (g, rc, smks) <- readTVarIO rcVar
   applyDiff smks <$$> (testEncodeDecode rc >> op (g, rc, smks) msg)
     >>= \case
-      Right (res, rc', smks') -> atomically (writeTVar rcVar (g, rc', smks')) >> pure (Right res)
+      Right (res, rc', smks') -> valid rc' `seq` atomically (writeTVar rcVar (g, rc', smks')) >> pure (Right res)
       Left e -> pure $ Left e
   where
     applyDiff smks (res, rc', smDiff) = (res, rc', applySMDiff smks smDiff)

tests/AgentTests/EqInstances.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module AgentTests.EqInstances where
+
+import Data.Type.Equality
+import Simplex.Messaging.Agent.Store
+
+instance Eq SomeConn where
+  SomeConn d c == SomeConn d' c' = case testEquality d d' of
+    Just Refl -> c == c'
+    _ -> False
+
+deriving instance Eq (Connection d)
+
+deriving instance Eq (SConnType d)
+
+deriving instance Eq (StoredRcvQueue q)
+
+deriving instance Eq (StoredSndQueue q)
+
+deriving instance Eq (DBQueueId q)
+
+deriving instance Eq ClientNtfCreds

tests/AgentTests/NotificationTests.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
@@ -6,11 +7,33 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module AgentTests.NotificationTests where
 
 -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging)
-import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, getSMPAgentClient', makeConnection, nGet, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg)
+import AgentTests.FunctionalAPITests
+  ( agentCfgV7,
+    createConnection,
+    exchangeGreetingsMsgId,
+    get,
+    getSMPAgentClient',
+    joinConnection,
+    makeConnection,
+    nGet,
+    runRight,
+    runRight_,
+    sendMessage,
+    switchComplete,
+    testServerMatrix2,
+    withAgentClientsCfg2,
+    (##>),
+    (=##>),
+    pattern CON,
+    pattern CONF,
+    pattern INFO,
+    pattern Msg,
+  )
 import Control.Concurrent (ThreadId, killThread, threadDelay)
 import Control.Monad
 import Control.Monad.Except
@@ -19,29 +42,32 @@ import Control.Monad.Trans.Except
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import Data.Bifunctor (bimap, first)
-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 NtfClient
-import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testDB3, testNtfServer2)
-import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, xit')
-import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Client (withStore')
-import Simplex.Messaging.Agent.Env.SQLite (InitialAgentServers)
-import Simplex.Messaging.Agent.Protocol
+import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testDB3, testNtfServer, testNtfServer2)
+import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn)
+import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
+import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
+import qualified Simplex.Messaging.Encoding.Base64.URL as U
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
+import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO)
 import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Types (NtfToken (..))
-import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
+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 (..))
 import Simplex.Messaging.Transport (ATransport)
 import System.Directory (doesFileExist, removeFile)
 import Test.Hspec
 import UnliftIO
+import Util
 
 removeFileIfExists :: FilePath -> IO ()
 removeFileIfExists filePath = do
@@ -49,72 +75,93 @@ removeFileIfExists filePath = do
   when fileExists $ removeFile filePath
 
 notificationTests :: ATransport -> Spec
-notificationTests t =
-  after_ (removeFileIfExists testDB >> removeFileIfExists testDB2) $ do
-    describe "Managing notification tokens" $ do
-      it "should register and verify notification token" $
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNotificationToken apns
-      it "should allow repeated registration with the same credentials" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNtfTokenRepeatRegistration apns
-      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" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          testNtfTokenServerRestart t apns
-      it "should work with multiple configured servers" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          testNtfTokenMultipleServers t apns
-      it "should keep working with active token until replaced" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          testNtfTokenChangeServers t apns
-    describe "Managing notification subscriptions" $ do
-      -- fails on Ubuntu CI?
-      xit' "should create notification subscription for existing connection" $ \_ -> do
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            withNtfServer t $ testNotificationSubscriptionExistingConnection apns
-      it "should create notification subscription for new connection" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            withNtfServer t $ testNotificationSubscriptionNewConnection apns
-      it "should change notifications mode" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            withNtfServer t $ testChangeNotificationsMode apns
-      it "should change token" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            withNtfServer t $ testChangeToken apns
-    describe "Notifications server store log" $
-      it "should save and restore tokens and subscriptions" $ \_ ->
-        withSmpServer t $
-          withAPNSMockServer $ \apns ->
-            testNotificationsStoreLog t apns
-    describe "Notifications after SMP server restart" $
-      it "should resume subscriptions after SMP server is restarted" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNotificationsSMPRestart t apns
-    describe "Notifications after SMP server restart" $
-      it "should resume batched subscriptions after SMP server is restarted" $ \_ ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns
-    describe "should switch notifications to the new queue" $
-      testServerMatrix2 t $ \servers ->
-        withAPNSMockServer $ \apns ->
-          withNtfServer t $ testSwitchNotifications servers apns
-    it "should keep sending notifications for old token" $
+notificationTests t = do
+  describe "Managing notification tokens" $ do
+    it "should register and verify notification token" $
+      withAPNSMockServer $ \apns ->
+        withNtfServer t $ testNotificationToken apns
+    it "should allow repeated registration with the same credentials" $
+      withAPNSMockServer $ \apns ->
+        withNtfServer t $ testNtfTokenRepeatRegistration apns
+    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" $
+      withAPNSMockServer $ \apns ->
+        testNtfTokenServerRestart t apns
+    it "should work with multiple configured servers" $
+      withAPNSMockServer $ \apns ->
+        testNtfTokenMultipleServers t apns
+    it "should keep working with active token until replaced" $
+      withAPNSMockServer $ \apns ->
+        testNtfTokenChangeServers t apns
+  describe "notification server tests" $ do
+    it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Nothing
+    let srv1 = testNtfServer {keyHash = "1234"}
+    it "should fail with incorrect fingerprint" $ do
+      testRunNTFServerTests t srv1 `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
+  describe "Managing notification subscriptions" $ do
+    describe "should create notification subscription for existing connection" $
+      testNtfMatrix t testNotificationSubscriptionExistingConnection
+    describe "should create notification subscription for new connection" $
+      testNtfMatrix t testNotificationSubscriptionNewConnection
+    it "should change notifications mode" $
       withSmpServer t $
         withAPNSMockServer $ \apns ->
-          withNtfServerOn t ntfTestPort $
-            testNotificationsOldToken apns
-    it "should update server from new token" $
+          withNtfServer t $ testChangeNotificationsMode apns
+    it "should change token" $
       withSmpServer t $
         withAPNSMockServer $ \apns ->
-          withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf ->
-            testNotificationsNewToken apns ntf
+          withNtfServer t $ testChangeToken apns
+  describe "Notifications server store log" $
+    it "should save and restore tokens and subscriptions" $
+      withSmpServer t $
+        withAPNSMockServer $ \apns ->
+          testNotificationsStoreLog t apns
+  describe "Notifications after SMP server restart" $
+    it "should resume subscriptions after SMP server is restarted" $
+      withAPNSMockServer $ \apns ->
+        withNtfServer t $ testNotificationsSMPRestart t apns
+  describe "Notifications after SMP server restart" $
+    it "should resume batched subscriptions after SMP server is restarted" $
+      withAPNSMockServer $ \apns ->
+        withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns
+  describe "should switch notifications to the new queue" $
+    testServerMatrix2 t $ \servers ->
+      withAPNSMockServer $ \apns ->
+        withNtfServer t $ testSwitchNotifications servers apns
+  it "should keep sending notifications for old token" $
+    withSmpServer t $
+      withAPNSMockServer $ \apns ->
+        withNtfServerOn t ntfTestPort $
+          testNotificationsOldToken apns
+  it "should update server from new token" $
+    withSmpServer t $
+      withAPNSMockServer $ \apns ->
+        withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf ->
+          testNotificationsNewToken apns ntf
+
+testNtfMatrix :: ATransport -> (APNSMockServer -> 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
+
+runNtfTestCfg :: ATransport -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> IO ()
+runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest =
+  withSmpServerConfigOn t smpCfg testPort $ \_ ->
+    withAPNSMockServer $ \apns ->
+      withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t)]} $ \_ ->
+        withAgentClientsCfg2 aCfg bCfg $ runTest apns
 
 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken APNSMockServer {apnsQ} = do
@@ -132,7 +179,7 @@ testNotificationToken APNSMockServer {apnsQ} = do
     deleteNtfToken a tkn
     -- agent deleted this token
     Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn
-    disconnectAgentClient a
+    disposeAgentClient a
 
 (.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
 v .-> key = do
@@ -164,7 +211,7 @@ testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
     -- can still use the first verification code, it is the same after decryption
     verifyNtfToken a tkn nonce verification
     NTActive <- checkNtfToken a tkn
-    disconnectAgentClient a
+    disposeAgentClient a
 
 testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
 testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
@@ -200,8 +247,8 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
     Left (NTF AUTH) <- tryE $ checkNtfToken a tkn
     -- and the second is active
     NTActive <- checkNtfToken a' tkn
-    disconnectAgentClient a
-    disconnectAgentClient a'
+    disposeAgentClient a
+    disposeAgentClient a'
 
 testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
@@ -215,7 +262,7 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
     pure ntfData
   -- 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
-  disconnectAgentClient a
+  disposeAgentClient a
   a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
   -- 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
@@ -230,7 +277,7 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
     liftIO $ sendApnsResponse' APNSRespOk
     verifyNtfToken a' tkn nonce' verification'
     NTActive <- checkNtfToken a' tkn
-    disconnectAgentClient a'
+    disposeAgentClient a'
 
 getTestNtfTokenPort :: (MonadUnliftIO m, MonadError AgentErrorType m) => AgentClient -> m String
 getTestNtfTokenPort a =
@@ -272,7 +319,7 @@ testNtfTokenChangeServers t APNSMockServer {apnsQ} =
       NTActive <- checkNtfToken a tkn
       setNtfServers a [testNtfServer2]
       NTActive <- checkNtfToken a tkn -- still works on old server
-      disconnectAgentClient a
+      disposeAgentClient a
       pure tkn
 
     threadDelay 1000000
@@ -294,10 +341,16 @@ testNtfTokenChangeServers t APNSMockServer {apnsQ} =
       tkn <- registerTestToken a "qwer" NMInstant apnsQ
       checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
 
-testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO ()
-testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
+testRunNTFServerTests t srv =
+  withNtfServerThreadOn t ntfTestPort $ \ntf -> do
+    a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB
+    r <- runRight $ testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
+    killThread ntf
+    pure r
+
+testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO ()
+testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg}} bob = do
   (bobId, aliceId, nonce, message) <- runRight $ do
     -- establish connection
     (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -318,7 +371,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
     verifyNtfToken alice tkn vNonce verification
     NTActive <- checkNtfToken alice tkn
     -- send message
-    liftIO $ threadDelay 50000
+    liftIO $ threadDelay 250000
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
     -- notification
@@ -329,11 +382,11 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
   Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message
 
   -- aliceNtf client doesn't have subscription and is allowed to get notification message
-  aliceNtf <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
+  aliceNtf <- getSMPAgentClient' 3 aliceCfg initAgentServers testDB
   runRight_ $ do
     (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
     pure ()
-  disconnectAgentClient aliceNtf
+  disposeAgentClient aliceNtf
 
   runRight_ $ do
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
@@ -346,16 +399,12 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do
     get bob ##> ("", aliceId, SENT $ baseId + 2)
     -- no notifications should follow
     noNotification apnsQ
-  disconnectAgentClient alice
-  disconnectAgentClient bob
   where
     baseId = 3
     msgId = subtract baseId
 
-testNotificationSubscriptionNewConnection :: APNSMockServer -> IO ()
-testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+testNotificationSubscriptionNewConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO ()
+testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob =
   runRight_ $ do
     -- alice registers notification token
     DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -367,32 +416,30 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do
     liftIO $ threadDelay 1000000
     aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     liftIO $ threadDelay 750000
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice apnsQ
     ("", _, CONF confId _ "bob's connInfo") <- get alice
     liftIO $ threadDelay 500000
     allowConnection alice bobId confId "alice's connInfo"
-    void $ messageNotification apnsQ
+    void $ messageNotificationData bob apnsQ
     get bob ##> ("", aliceId, INFO "alice's connInfo")
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice apnsQ
     get alice ##> ("", bobId, CON)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData bob apnsQ
     get bob ##> ("", aliceId, CON)
     -- bob sends message
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 1) Nothing
     -- alice sends message
     2 <- msgId <$> sendMessage alice bobId (SMP.MsgFlags True) "hey there"
     get alice ##> ("", bobId, SENT $ baseId + 2)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData bob apnsQ
     get bob =##> \case ("", c, Msg "hey there") -> c == aliceId; _ -> False
     ackMessage bob aliceId (baseId + 2) Nothing
     -- no unexpected notifications should follow
     noNotification apnsQ
-  disconnectAgentClient alice
-  disconnectAgentClient bob
   where
     baseId = 3
     msgId = subtract baseId
@@ -429,7 +476,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     liftIO $ threadDelay 500000
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 1) Nothing
     -- set mode to NMPeriodic
@@ -447,7 +494,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     liftIO $ threadDelay 500000
     3 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
     get bob ##> ("", aliceId, SENT $ baseId + 3)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice apnsQ
     get alice =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 3) Nothing
     -- turn off notifications
@@ -465,13 +512,13 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
     liftIO $ threadDelay 500000
     5 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hey"
     get bob ##> ("", aliceId, SENT $ baseId + 5)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice apnsQ
     get alice =##> \case ("", c, Msg "hey") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 5) Nothing
     -- no notifications should follow
     noNotification apnsQ
-  disconnectAgentClient alice
-  disconnectAgentClient bob
+  disposeAgentClient alice
+  disposeAgentClient bob
   where
     baseId = 3
     msgId = subtract baseId
@@ -495,11 +542,11 @@ testChangeToken APNSMockServer {apnsQ} = do
     liftIO $ threadDelay 500000
     1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT $ baseId + 1)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId (baseId + 1) Nothing
     pure (aliceId, bobId)
-  disconnectAgentClient alice
+  disposeAgentClient alice
 
   alice1 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
   runRight_ $ do
@@ -510,13 +557,13 @@ testChangeToken APNSMockServer {apnsQ} = do
     liftIO $ threadDelay 500000
     2 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello there"
     get bob ##> ("", aliceId, SENT $ baseId + 2)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice1 apnsQ
     get alice1 =##> \case ("", c, Msg "hello there") -> c == bobId; _ -> False
     ackMessage alice1 bobId (baseId + 2) Nothing
     -- no notifications should follow
     noNotification apnsQ
-  disconnectAgentClient alice1
-  disconnectAgentClient bob
+  disposeAgentClient alice1
+  disposeAgentClient bob
   where
     baseId = 3
     msgId = subtract baseId
@@ -531,7 +578,7 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
     liftIO $ threadDelay 250000
     4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT 4)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId 4 Nothing
     liftIO $ killThread threadId
@@ -543,11 +590,11 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
     liftIO $ threadDelay 250000
     5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again"
     get bob ##> ("", aliceId, SENT 5)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice apnsQ
     get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
     liftIO $ killThread threadId
-  disconnectAgentClient alice
-  disconnectAgentClient bob
+  disposeAgentClient alice
+  disposeAgentClient bob
 
 testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
 testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
@@ -559,7 +606,7 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     liftIO $ threadDelay 250000
     4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello"
     get bob ##> ("", aliceId, SENT 4)
-    void $ messageNotification apnsQ
+    void $ messageNotificationData alice apnsQ
     get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
     ackMessage alice bobId 4 Nothing
     liftIO $ killThread threadId
@@ -578,8 +625,8 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
     _ <- messageNotificationData alice apnsQ
     get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
     liftIO $ killThread threadId
-  disconnectAgentClient alice
-  disconnectAgentClient bob
+  disposeAgentClient alice
+  disposeAgentClient bob
 
 testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO ()
 testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
@@ -593,7 +640,7 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
     forM_ conns $ \(aliceId, bobId) -> do
       msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
       get b ##> ("", aliceId, SENT msgId)
-      void $ messageNotification apnsQ
+      void $ messageNotificationData a apnsQ
       get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
       ackMessage a bobId msgId Nothing
     pure conns
@@ -619,13 +666,13 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
       get b ##> ("", aliceId, SENT msgId)
       _ <- messageNotificationData a apnsQ
       get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
-  disconnectAgentClient a
-  disconnectAgentClient b
+  disposeAgentClient a
+  disposeAgentClient b
   where
     runServers :: ExceptT AgentErrorType IO a -> IO a
     runServers a = do
       withSmpServerStoreLogOn t testPort $ \t1 -> do
-        res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
+        res <- withSmpServerConfigOn t (cfg :: ServerConfig) {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 ->
           runRight a `finally` killThread t2
         killThread t1
         pure res
@@ -642,7 +689,7 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do
     let testMessage msg = do
           msgId <- sendMessage b aId (SMP.MsgFlags True) msg
           get b ##> ("", aId, SENT msgId)
-          void $ messageNotification apnsQ
+          void $ messageNotificationData a apnsQ
           get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
           ackMessage a bId msgId Nothing
     testMessage "hello"
@@ -650,8 +697,8 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do
     switchComplete a bId b aId
     liftIO $ threadDelay 500000
     testMessage "hello again"
-  disconnectAgentClient a
-  disconnectAgentClient b
+  disposeAgentClient a
+  disposeAgentClient b
 
 testNotificationsOldToken :: APNSMockServer -> IO ()
 testNotificationsOldToken APNSMockServer {apnsQ} = do
@@ -674,9 +721,9 @@ testNotificationsOldToken APNSMockServer {apnsQ} = do
     (acId, caId) <- makeConnection a c
     let testMessageAC = testMessage_ apnsQ a acId c caId
     testMessageAC "greetings"
-  disconnectAgentClient a
-  disconnectAgentClient b
-  disconnectAgentClient c
+  disposeAgentClient a
+  disposeAgentClient b
+  disposeAgentClient c
 
 testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO ()
 testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do
@@ -702,15 +749,15 @@ testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do
     (acId, caId) <- makeConnection a c
     let testMessageAC = testMessage_ apnsQ a acId c caId
     testMessageAC "greetings"
-  disconnectAgentClient a
-  disconnectAgentClient b
-  disconnectAgentClient c
+  disposeAgentClient a
+  disposeAgentClient b
+  disposeAgentClient c
 
 testMessage_ :: HasCallStack => TBQueue APNSMockRequest -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO ()
 testMessage_ apnsQ a aId b bId msg = do
   msgId <- sendMessage b aId (SMP.MsgFlags True) msg
   get b ##> ("", aId, SENT msgId)
-  void $ messageNotification apnsQ
+  void $ messageNotificationData a apnsQ
   get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False
   ackMessage a bId msgId Nothing
 

tests/AgentTests/SQLiteTests.hs

@@ -1,20 +1,27 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module AgentTests.SQLiteTests (storeTests) where
 
+import AgentTests.EqInstances ()
 import Control.Concurrent.Async (concurrently_)
 import Control.Concurrent.STM
 import Control.Exception (SomeException)
 import Control.Monad (replicateM_)
+import Control.Monad.Trans.Except
+import Crypto.Random (ChaChaDRG)
 import Data.ByteArray (ScrubbedBytes)
 import Data.ByteString.Char8 (ByteString)
 import Data.List (isInfixOf)
@@ -38,9 +45,11 @@ import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), pattern PQSupportOn)
+import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
-import Simplex.Messaging.Protocol (SubscriptionMode (..))
+import Simplex.Messaging.Protocol (SubscriptionMode (..), pattern VersionSMPC)
 import qualified Simplex.Messaging.Protocol as SMP
 import System.Random
 import Test.Hspec
@@ -91,7 +100,7 @@ storeTests = do
       testForeignKeysEnabled
     describe "db methods" $ do
       describe "Queue and Connection management" $ do
-        describe "createRcvConn" $ do
+        describe "create Rcv connection" $ do
           testCreateRcvConn
           testCreateRcvConnRandomId
           testCreateRcvConnDuplicate
@@ -172,10 +181,20 @@ testForeignKeysEnabled =
       `shouldThrow` (\e -> SQL.sqlError e == SQL.ErrorConstraint)
 
 cData1 :: ConnData
-cData1 = ConnData {userId = 1, connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk}
+cData1 =
+  ConnData
+    { userId = 1,
+      connId = "conn1",
+      connAgentVersion = VersionSMPA 1,
+      enableNtfs = True,
+      lastExternalSndId = 0,
+      deleted = False,
+      ratchetSyncState = RSOk,
+      pqSupport = CR.PQSupportOn
+    }
 
-testPrivateSignKey :: C.APrivateSignKey
-testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
+testPrivateAuthKey :: C.APrivateAuthKey
+testPrivateAuthKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
 
 testPrivDhKey :: C.PrivateKeyX25519
 testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk"
@@ -193,7 +212,7 @@ rcvQueue1 =
       connId = "conn1",
       server = smpServer1,
       rcvId = "1234",
-      rcvPrivateKey = testPrivateSignKey,
+      rcvPrivateKey = testPrivateAuthKey,
       rcvDhSecret = testDhSecret,
       e2ePrivKey = testPrivDhKey,
       e2eDhSecret = Nothing,
@@ -203,7 +222,7 @@ rcvQueue1 =
       primary = True,
       dbReplaceQueueId = Nothing,
       rcvSwchStatus = Nothing,
-      smpClientVersion = 1,
+      smpClientVersion = VersionSMPC 1,
       clientNtfCreds = Nothing,
       deleteErrors = 0
     }
@@ -216,7 +235,7 @@ sndQueue1 =
       server = smpServer1,
       sndId = "3456",
       sndPublicKey = Nothing,
-      sndPrivateKey = testPrivateSignKey,
+      sndPrivateKey = testPrivateAuthKey,
       e2ePubKey = Nothing,
       e2eDhSecret = testDhSecret,
       status = New,
@@ -224,9 +243,15 @@ sndQueue1 =
       primary = True,
       dbReplaceQueueId = Nothing,
       sndSwchStatus = Nothing,
-      smpClientVersion = 1
+      smpClientVersion = VersionSMPC 1
     }
 
+createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewRcvQueue -> SConnectionMode c -> IO (Either StoreError (ConnId, RcvQueue))
+createRcvConn db g cData rq cMode = runExceptT $ do
+  connId <- ExceptT $ createNewConn db g cData cMode
+  rq' <- ExceptT $ updateNewConnRcv db connId rq
+  pure (connId, rq')
+
 testCreateRcvConn :: SpecWith SQLiteStore
 testCreateRcvConn =
   it "should create RcvConnection and add SndQueue" . withStoreTransaction $ \db -> do
@@ -312,8 +337,8 @@ testDeleteRcvConn =
     Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq))
-    deleteConn db "conn1"
-      `shouldReturn` ()
+    deleteConn db Nothing "conn1"
+      `shouldReturn` Just "conn1"
     getConn db "conn1"
       `shouldReturn` Left SEConnNotFound
 
@@ -324,8 +349,8 @@ testDeleteSndConn =
     Right (_, sq) <- createSndConn db g cData1 sndQueue1
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq))
-    deleteConn db "conn1"
-      `shouldReturn` ()
+    deleteConn db Nothing "conn1"
+      `shouldReturn` Just "conn1"
     getConn db "conn1"
       `shouldReturn` Left SEConnNotFound
 
@@ -337,8 +362,8 @@ testDeleteDuplexConn =
     Right sq <- upgradeRcvConnToDuplex db "conn1" sndQueue1
     getConn db "conn1"
       `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq]))
-    deleteConn db "conn1"
-      `shouldReturn` ()
+    deleteConn db Nothing "conn1"
+      `shouldReturn` Just "conn1"
     getConn db "conn1"
       `shouldReturn` Left SEConnNotFound
 
@@ -354,7 +379,7 @@ testUpgradeRcvConnToDuplex =
               server = SMPServer "smp.simplex.im" "5223" testKeyHash,
               sndId = "2345",
               sndPublicKey = Nothing,
-              sndPrivateKey = testPrivateSignKey,
+              sndPrivateKey = testPrivateAuthKey,
               e2ePubKey = Nothing,
               e2eDhSecret = testDhSecret,
               status = New,
@@ -362,7 +387,7 @@ testUpgradeRcvConnToDuplex =
               sndSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
-              smpClientVersion = 1
+              smpClientVersion = VersionSMPC 1
             }
     upgradeRcvConnToDuplex db "conn1" anotherSndQueue
       `shouldReturn` Left (SEBadConnType CSnd)
@@ -381,7 +406,7 @@ testUpgradeSndConnToDuplex =
               connId = "conn1",
               server = SMPServer "smp.simplex.im" "5223" testKeyHash,
               rcvId = "3456",
-              rcvPrivateKey = testPrivateSignKey,
+              rcvPrivateKey = testPrivateAuthKey,
               rcvDhSecret = testDhSecret,
               e2ePrivKey = testPrivDhKey,
               e2eDhSecret = Nothing,
@@ -391,7 +416,7 @@ testUpgradeSndConnToDuplex =
               rcvSwchStatus = Nothing,
               primary = True,
               dbReplaceQueueId = Nothing,
-              smpClientVersion = 1,
+              smpClientVersion = VersionSMPC 1,
               clientNtfCreds = Nothing,
               deleteErrors = 0
             }
@@ -459,7 +484,8 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
           { integrity = MsgOk,
             recipient = (unId internalId, ts),
             sndMsgId = externalSndId,
-            broker = (brokerId, ts)
+            broker = (brokerId, ts),
+            pqEncryption = CR.PQEncOn
           },
       msgType = AM_A_MSG_,
       msgFlags = SMP.noMsgFlags,
@@ -497,6 +523,7 @@ mkSndMsgData internalId internalSndId internalHash =
       msgType = AM_A_MSG_,
       msgFlags = SMP.noMsgFlags,
       msgBody = hw,
+      pqEncryption = CR.PQEncOn,
       internalHash,
       prevMsgHash = internalHash
     }
@@ -635,7 +662,7 @@ testGetPendingServerCommand st = do
     Right (Just PendingCommand {corrId = corrId'}) <- getPendingServerCommand db (Just smpServer1)
     corrId' `shouldBe` "4"
   where
-    command = AClientCommand $ APC SAEConn $ NEW True (ACM SCMInvitation) SMSubscribe
+    command = AClientCommand $ APC SAEConn $ NEW True (ACM SCMInvitation) (IKNoPQ PQSupportOn) SMSubscribe
     corruptCmd :: DB.Connection -> ByteString -> ConnId -> IO ()
     corruptCmd db corrId connId = DB.execute db "UPDATE commands SET command = cast('bad' as blob) WHERE conn_id = ? AND corr_id = ?" (connId, corrId)
 
@@ -658,7 +685,8 @@ rcvFileDescr1 =
               chunkSize = defaultChunkSize,
               replicas = [FileChunkReplica {server = xftpServer1, replicaId, replicaKey = testFileReplicaKey}]
             }
-        ]
+        ],
+      redirect = Nothing
     }
   where
     defaultChunkSize = FileSize $ mb 8
@@ -671,8 +699,8 @@ testFileSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD
 testFileCbNonce :: C.CbNonce
 testFileCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu"
 
-testFileReplicaKey :: C.APrivateSignKey
-testFileReplicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
+testFileReplicaKey :: C.APrivateAuthKey
+testFileReplicaKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
 
 testGetNextRcvChunkToDownload :: SQLiteStore -> Expectation
 testGetNextRcvChunkToDownload st = do
@@ -716,9 +744,9 @@ testGetNextSndFileToPrepare st = do
   withTransaction st $ \db -> do
     Right Nothing <- getNextSndFileToPrepare db 86400
 
-    Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce
+    Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
     DB.execute_ db "UPDATE snd_files SET status = 'new', num_recipients = 'bad' WHERE snd_file_id = 1"
-    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce
+    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
     DB.execute_ db "UPDATE snd_files SET status = 'new' WHERE snd_file_id = 2"
 
     Left e <- getNextSndFileToPrepare db 86400
@@ -744,12 +772,12 @@ testGetNextSndChunkToUpload st = do
     Right Nothing <- getNextSndChunkToUpload db xftpServer1 86400
 
     -- create file 1
-    Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce
+    Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
     updateSndFileEncrypted db 1 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")]
     createSndFileReplica_ db 1 newSndChunkReplica1
     DB.execute_ db "UPDATE snd_files SET num_recipients = 'bad' WHERE snd_file_id = 1"
     -- create file 2
-    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce
+    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
     updateSndFileEncrypted db 2 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")]
     createSndFileReplica_ db 2 newSndChunkReplica1
 

tests/CLITests.hs

@@ -1,16 +1,20 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module CLITests where
 
 import Data.Ini (lookupValue, readIniFile)
 import Data.List (isPrefixOf)
-import Simplex.FileTransfer.Server.Main (xftpServerCLI, xftpServerVersion)
+import qualified Data.X509 as X
+import qualified Data.X509.File as XF
+import Simplex.FileTransfer.Server.Main (xftpServerCLI)
 import Simplex.Messaging.Notifications.Server.Main
 import Simplex.Messaging.Server.Main
 import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Util (catchAll_)
 import System.Directory (doesFileExist)
 import System.Environment (withArgs)
+import System.FilePath ((</>))
 import System.IO.Silently (capture_)
 import System.Timeout (timeout)
 import Test.Hspec
@@ -51,6 +55,7 @@ cliTests = do
 
 smpServerTest :: Bool -> Bool -> IO ()
 smpServerTest storeLog basicAuth = do
+  -- init
   capture_ (withArgs (["init", "-y"] <> ["-l" | storeLog] <> ["--no-password" | not basicAuth]) $ smpServerCLI cfgPath logPath)
     >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> cfgPath <> "/smp-server.ini") `isPrefixOf`))
   Right ini <- readIniFile $ cfgPath <> "/smp-server.ini"
@@ -61,12 +66,30 @@ smpServerTest storeLog basicAuth = do
   lookupValue "AUTH" "new_queues" ini `shouldBe` Right "on"
   lookupValue "INACTIVE_CLIENTS" "disconnect" ini `shouldBe` Right "off"
   doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True
+  -- start
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
   r `shouldContain` ["SMP server v" <> simplexMQVersion]
   r `shouldContain` (if storeLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."])
   r `shouldContain` ["Listening on port 5223 (TLS)..."]
   r `shouldContain` ["not expiring inactive clients"]
   r `shouldContain` (if basicAuth then ["creating new queues requires password"] else ["creating new queues allowed"])
+  -- cert
+  let certPath = cfgPath </> "server.crt"
+  oldCrt@X.Certificate {} <-
+    XF.readSignedObject certPath >>= \case
+      [cert] -> pure . X.signedObject $ X.getSigned cert
+      _ -> error "bad crt format"
+  r' <- lines <$> capture_ (withArgs ["cert"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
+  r' `shouldContain` ["Generated new server credentials"]
+  newCrt <-
+    XF.readSignedObject certPath >>= \case
+      [cert] -> pure . X.signedObject $ X.getSigned cert
+      _ -> error "bad crt format after cert"
+  X.certSignatureAlg oldCrt `shouldBe` X.certSignatureAlg newCrt
+  X.certSubjectDN oldCrt `shouldBe` X.certSubjectDN newCrt
+  X.certSerial oldCrt `shouldNotBe` X.certSerial newCrt
+  X.certPubKey oldCrt `shouldNotBe` X.certPubKey newCrt
+  -- delete
   capture_ (withStdin "Y" . withArgs ["delete"] $ smpServerCLI cfgPath logPath)
     >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
   doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
@@ -82,7 +105,7 @@ ntfServerTest storeLog = do
   lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
   doesFileExist (ntfCfgPath <> "/ca.key") `shouldReturn` True
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ()))
-  r `shouldContain` ["SMP notifications server v" <> ntfServerVersion]
+  r `shouldContain` ["SMP notifications server v" <> simplexMQVersion]
   r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."])
   r `shouldContain` ["Listening on port 443 (TLS)..."]
   capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath)
@@ -99,7 +122,7 @@ xftpServerTest storeLog = do
   lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443"
   doesFileExist (fileCfgPath <> "/ca.key") `shouldReturn` True
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` xftpServerCLI fileCfgPath fileLogPath) `catchAll_` pure (Just ()))
-  r `shouldContain` ["SimpleX XFTP server v" <> xftpServerVersion]
+  r `shouldContain` ["SimpleX XFTP server v" <> simplexMQVersion]
   r `shouldContain` (if storeLog then ["Store log: " <> fileLogPath <> "/file-server-store.log"] else ["Store log disabled."])
   r `shouldContain` ["Listening on port 443..."]
   capture_ (withStdin "Y" . withArgs ["delete"] $ xftpServerCLI fileCfgPath fileLogPath)

tests/CoreTests/BatchingTests.hs

@@ -1,41 +1,67 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
 
 module CoreTests.BatchingTests (batchingTests) where
 
 import Control.Concurrent.STM
 import Control.Monad
-import Data.ByteString.Char8 (ByteString)
+import Crypto.Random (ChaChaDRG)
 import qualified Data.ByteString as B
+import Data.ByteString.Char8 (ByteString)
 import qualified Data.List.NonEmpty as L
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Version (VersionRange (..))
 import Test.Hspec
 
 batchingTests :: Spec
 batchingTests = do
   describe "batchTransmissions" $ do
-    it "should batch with 90 subscriptions per batch" testBatchSubscriptions
-    it "should break on message that does not fit" testBatchWithMessage
-    it "should break on large message" testBatchWithLargeMessage
+    describe "SMP v6 (current)" $ do
+      it "should batch with 107 subscriptions per batch" testBatchSubscriptions
+      it "should break on message that does not fit" testBatchWithMessage
+      it "should break on large message" testBatchWithLargeMessage
+    describe "v7 (next)" $ do
+      it "should batch with 136 subscriptions per batch" testBatchSubscriptionsV7
+      it "should break on message that does not fit" testBatchWithMessageV7
+      it "should break on large message" testBatchWithLargeMessageV7
   describe "batchTransmissions'" $ do
-    it "should batch with 90 subscriptions per batch" testClientBatchSubscriptions
-    it "should break on message that does not fit" testClientBatchWithMessage
-    it "should break on large message" testClientBatchWithLargeMessage
+    describe "SMP v6 (current)" $ do
+      it "should batch with 107 subscriptions per batch" testClientBatchSubscriptions
+      it "should break on message that does not fit" testClientBatchWithMessage
+      it "should break on large message" testClientBatchWithLargeMessage
+    describe "v7 (next)" $ do
+      it "should batch with 136 subscriptions per batch" testClientBatchSubscriptionsV7
+      it "should break on message that does not fit" testClientBatchWithMessageV7
+      it "should break on large message" testClientBatchWithLargeMessageV7
 
 testBatchSubscriptions :: IO ()
 testBatchSubscriptions = do
   sessId <- atomically . C.randomBytes 32 =<< C.newRandom
-  subs <- replicateM 200 $ randomSUB sessId
+  subs <- replicateM 250 $ randomSUB sessId
   let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
-  length batches1 `shouldBe` 200
+  length batches1 `shouldBe` 250
   let batches = batchTransmissions True smpBlockSize $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (20, 90, 90)
+  (n1, n2, n3) `shouldBe` (36, 107, 107)
+  all lenOk [s1, s2, s3] `shouldBe` True
+
+testBatchSubscriptionsV7 :: IO ()
+testBatchSubscriptionsV7 = do
+  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
+  subs <- replicateM 300 $ randomSUBv7 sessId
+  let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs
+  all lenOk1 batches1 `shouldBe` True
+  length batches1 `shouldBe` 300
+  let batches = batchTransmissions True smpBlockSize $ L.fromList subs
+  length batches `shouldBe` 3
+  [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
+  (n1, n2, n3) `shouldBe` (28, 136, 136)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testBatchWithMessage :: IO ()
@@ -51,46 +77,92 @@ testBatchWithMessage = do
   let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 2
   [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches
-  (n1, n2) `shouldBe` (55, 46)
+  (n1, n2) `shouldBe` (47, 54)
+  all lenOk [s1, s2] `shouldBe` True
+
+testBatchWithMessageV7 :: IO ()
+testBatchWithMessageV7 = do
+  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
+  subs1 <- replicateM 60 $ randomSUBv7 sessId
+  send <- randomSENDv7 sessId 8000
+  subs2 <- replicateM 40 $ randomSUBv7 sessId
+  let cmds = subs1 <> [send] <> subs2
+      batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
+  all lenOk1 batches1 `shouldBe` True
+  length batches1 `shouldBe` 101
+  let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
+  length batches `shouldBe` 2
+  [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches
+  (n1, n2) `shouldBe` (32, 69)
   all lenOk [s1, s2] `shouldBe` True
 
 testBatchWithLargeMessage :: IO ()
 testBatchWithLargeMessage = do
   sessId <- atomically . C.randomBytes 32 =<< C.newRandom
-  subs1 <- replicateM 60 $ randomSUB sessId
+  subs1 <- replicateM 50 $ randomSUB sessId
   send <- randomSEND sessId 17000
-  subs2 <- replicateM 100 $ randomSUB sessId
+  subs2 <- replicateM 150 $ randomSUB sessId
   let cmds = subs1 <> [send] <> subs2
       batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` False
-  length batches1 `shouldBe` 161
-  let batches1' = take 60 batches1 <> drop 61 batches1
+  length batches1 `shouldBe` 201
+  let batches1' = take 50 batches1 <> drop 51 batches1
   all lenOk1 batches1' `shouldBe` True
-  length batches1' `shouldBe` 160
+  length batches1' `shouldBe` 200
   let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 4
-  [TBTransmissions s1 n1 _, TBLargeTransmission _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
-  (n1, n2, n3) `shouldBe` (60, 10, 90)
+  [TBTransmissions s1 n1 _, TBError TELargeMsg _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
+  (n1, n2, n3) `shouldBe` (50, 43, 107)
+  all lenOk [s1, s2, s3] `shouldBe` True
+
+testBatchWithLargeMessageV7 :: IO ()
+testBatchWithLargeMessageV7 = do
+  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
+  subs1 <- replicateM 60 $ randomSUBv7 sessId
+  send <- randomSENDv7 sessId 17000
+  subs2 <- replicateM 150 $ randomSUBv7 sessId
+  let cmds = subs1 <> [send] <> subs2
+      batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds
+  all lenOk1 batches1 `shouldBe` False
+  length batches1 `shouldBe` 211
+  let batches1' = take 60 batches1 <> drop 61 batches1
+  all lenOk1 batches1' `shouldBe` True
+  length batches1' `shouldBe` 210
+  let batches = batchTransmissions True smpBlockSize $ L.fromList cmds
+  length batches `shouldBe` 4
+  [TBTransmissions s1 n1 _, TBError TELargeMsg _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches
+  (n1, n2, n3) `shouldBe` (60, 14, 136)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testClientBatchSubscriptions :: IO ()
 testClientBatchSubscriptions = do
-  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
-  client <- atomically $ clientStub sessId
-  subs <- replicateM 200 $ randomSUBCmd client
+  client <- testClientStub
+  subs <- replicateM 250 $ randomSUBCmd client
   let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs
   all lenOk1 batches1 `shouldBe` True
   let batches = batchTransmissions' True smpBlockSize $ L.fromList subs
   length batches `shouldBe` 3
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (20, 90, 90)
-  (length rs1, length rs2, length rs3) `shouldBe` (20, 90, 90)
+  (n1, n2, n3) `shouldBe` (36, 107, 107)
+  (length rs1, length rs2, length rs3) `shouldBe` (36, 107, 107)
+  all lenOk [s1, s2, s3] `shouldBe` True
+
+testClientBatchSubscriptionsV7 :: IO ()
+testClientBatchSubscriptionsV7 = do
+  client <- clientStubV7
+  subs <- replicateM 300 $ randomSUBCmdV7 client
+  let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs
+  all lenOk1 batches1 `shouldBe` True
+  let batches = batchTransmissions' True smpBlockSize $ L.fromList subs
+  length batches `shouldBe` 3
+  [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
+  (n1, n2, n3) `shouldBe` (28, 136, 136)
+  (length rs1, length rs2, length rs3) `shouldBe` (28, 136, 136)
   all lenOk [s1, s2, s3] `shouldBe` True
 
 testClientBatchWithMessage :: IO ()
 testClientBatchWithMessage = do
-  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
-  client <- atomically $ clientStub sessId
+  client <- testClientStub
   subs1 <- replicateM 60 $ randomSUBCmd client
   send <- randomSENDCmd client 8000
   subs2 <- replicateM 40 $ randomSUBCmd client
@@ -101,71 +173,176 @@ testClientBatchWithMessage = do
   let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 2
   [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches
-  (n1, n2) `shouldBe` (55, 46)
-  (length rs1, length rs2) `shouldBe` (55, 46)
+  (n1, n2) `shouldBe` (47, 54)
+  (length rs1, length rs2) `shouldBe` (47, 54)
+  all lenOk [s1, s2] `shouldBe` True
+
+testClientBatchWithMessageV7 :: IO ()
+testClientBatchWithMessageV7 = do
+  client <- clientStubV7
+  subs1 <- replicateM 60 $ randomSUBCmdV7 client
+  send <- randomSENDCmdV7 client 8000
+  subs2 <- replicateM 40 $ randomSUBCmdV7 client
+  let cmds = subs1 <> [send] <> subs2
+      batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
+  all lenOk1 batches1 `shouldBe` True
+  length batches1 `shouldBe` 101
+  let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
+  length batches `shouldBe` 2
+  [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches
+  (n1, n2) `shouldBe` (32, 69)
+  (length rs1, length rs2) `shouldBe` (32, 69)
   all lenOk [s1, s2] `shouldBe` True
 
 testClientBatchWithLargeMessage :: IO ()
 testClientBatchWithLargeMessage = do
-  sessId <- atomically . C.randomBytes 32 =<< C.newRandom
-  client <- atomically $ clientStub sessId
-  subs1 <- replicateM 60 $ randomSUBCmd client
+  client <- testClientStub
+  subs1 <- replicateM 50 $ randomSUBCmd client
   send <- randomSENDCmd client 17000
-  subs2 <- replicateM 100 $ randomSUBCmd client
+  subs2 <- replicateM 150 $ randomSUBCmd client
   let cmds = subs1 <> [send] <> subs2
       batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
   all lenOk1 batches1 `shouldBe` False
-  length batches1 `shouldBe` 161
-  let batches1' = take 60 batches1 <> drop 61 batches1
+  length batches1 `shouldBe` 201
+  let batches1' = take 50 batches1 <> drop 51 batches1
   all lenOk1 batches1' `shouldBe` True
-  length batches1' `shouldBe` 160
+  length batches1' `shouldBe` 200
   --
   let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
   length batches `shouldBe` 4
-  [TBTransmissions s1 n1 rs1, TBLargeTransmission _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
-  (n1, n2, n3) `shouldBe` (60, 10, 90)
-  (length rs1, length rs2, length rs3) `shouldBe` (60, 10, 90)
+  [TBTransmissions s1 n1 rs1, TBError TELargeMsg _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
+  (n1, n2, n3) `shouldBe` (50, 43, 107)
+  (length rs1, length rs2, length rs3) `shouldBe` (50, 43, 107)
   all lenOk [s1, s2, s3] `shouldBe` True
   --
   let cmds' = [send] <> subs1 <> subs2
   let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds'
   length batches' `shouldBe` 3
-  [TBLargeTransmission _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches'
-  (n1', n2') `shouldBe` (70, 90)
-  (length rs1', length rs2') `shouldBe` (70, 90)
+  [TBError TELargeMsg _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches'
+  (n1', n2') `shouldBe` (93, 107)
+  (length rs1', length rs2') `shouldBe` (93, 107)
   all lenOk [s1', s2'] `shouldBe` True
 
-randomSUB :: ByteString -> IO (Maybe C.ASignature, ByteString)
-randomSUB sessId = do
-  g <- C.newRandom
-  rId <- atomically $ C.randomBytes 24 g
-  corrId <- atomically $ CorrId <$> C.randomBytes 3 g
-  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
-  let s = encodeTransmission (maxVersion supportedSMPServerVRange) sessId (corrId, rId, Cmd SRecipient SUB)
-  pure (Just $ C.sign rpKey s, s)
+testClientBatchWithLargeMessageV7 :: IO ()
+testClientBatchWithLargeMessageV7 = do
+  client <- clientStubV7
+  subs1 <- replicateM 60 $ randomSUBCmdV7 client
+  send <- randomSENDCmdV7 client 17000
+  subs2 <- replicateM 150 $ randomSUBCmdV7 client
+  let cmds = subs1 <> [send] <> subs2
+      batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds
+  all lenOk1 batches1 `shouldBe` False
+  length batches1 `shouldBe` 211
+  let batches1' = take 60 batches1 <> drop 61 batches1
+  all lenOk1 batches1' `shouldBe` True
+  length batches1' `shouldBe` 210
+  --
+  let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds
+  length batches `shouldBe` 4
+  [TBTransmissions s1 n1 rs1, TBError TELargeMsg _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches
+  (n1, n2, n3) `shouldBe` (60, 14, 136)
+  (length rs1, length rs2, length rs3) `shouldBe` (60, 14, 136)
+  all lenOk [s1, s2, s3] `shouldBe` True
+  --
+  let cmds' = [send] <> subs1 <> subs2
+  let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds'
+  length batches' `shouldBe` 3
+  [TBError TELargeMsg _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches'
+  (n1', n2') `shouldBe` (74, 136)
+  (length rs1', length rs2') `shouldBe` (74, 136)
+  all lenOk [s1', s2'] `shouldBe` True
 
-randomSUBCmd :: ProtocolClient ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
-randomSUBCmd c = do
+testClientStub :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg)
+testClientStub = do
+  g <- C.newRandom
+  sessId <- atomically $ C.randomBytes 32 g
+  atomically $ smpClientStub g sessId subModeSMPVersion Nothing
+
+clientStubV7 :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg)
+clientStubV7 = do
+  g <- C.newRandom
+  sessId <- atomically $ C.randomBytes 32 g
+  (rKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g
+  thAuth_ <- testTHandleAuth authCmdsSMPVersion g rKey
+  atomically $ smpClientStub g sessId authCmdsSMPVersion thAuth_
+
+randomSUB :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSUB = randomSUB_ C.SEd25519 subModeSMPVersion
+
+randomSUBv7 :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSUBv7 = randomSUB_ C.SEd25519 authCmdsSMPVersion
+
+randomSUB_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSUB_ a v sessId = do
   g <- C.newRandom
   rId <- atomically $ C.randomBytes 24 g
-  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+  corrId <- atomically $ CorrId <$> C.randomBytes 24 g
+  (rKey, rpKey) <- atomically $ C.generateAuthKeyPair a g
+  thAuth_ <- testTHandleAuth v g rKey
+  let thParams = testTHandleParams v sessId
+      TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, rId, Cmd SRecipient SUB)
+  pure $ (,tToSend) <$> authTransmission thAuth_ (Just rpKey) corrId tForAuth
+
+randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
+randomSUBCmd = randomSUBCmd_ C.SEd25519
+
+randomSUBCmdV7 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
+randomSUBCmdV7 = randomSUBCmd_ C.SEd25519 -- same as v6
+
+randomSUBCmd_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg)
+randomSUBCmd_ a c = do
+  g <- C.newRandom
+  rId <- atomically $ C.randomBytes 24 g
+  (_, rpKey) <- atomically $ C.generateAuthKeyPair a g
   mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB)
 
-randomSEND :: ByteString -> Int -> IO (Maybe C.ASignature, ByteString)
-randomSEND sessId len = do
+randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSEND = randomSEND_ C.SEd25519 subModeSMPVersion
+
+randomSENDv7 :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSENDv7 = randomSEND_ C.SX25519 authCmdsSMPVersion
+
+randomSEND_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString))
+randomSEND_ a v sessId len = do
   g <- C.newRandom
   sId <- atomically $ C.randomBytes 24 g
   corrId <- atomically $ CorrId <$> C.randomBytes 3 g
-  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+  (sKey, spKey) <- atomically $ C.generateAuthKeyPair a g
+  thAuth_ <- testTHandleAuth v g sKey
   msg <- atomically $ C.randomBytes len g
-  let s = encodeTransmission (maxVersion supportedSMPServerVRange) sessId (corrId, sId, Cmd SSender $ SEND noMsgFlags msg)
-  pure (Just $ C.sign rpKey s, s)
+  let thParams = testTHandleParams v sessId
+      TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, sId, Cmd SSender $ SEND noMsgFlags msg)
+  pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) corrId tForAuth
 
-randomSENDCmd :: ProtocolClient ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
-randomSENDCmd c len = do
+testTHandleParams :: VersionSMP -> ByteString -> THandleParams SMPVersion
+testTHandleParams v sessionId =
+  THandleParams
+    { sessionId,
+      blockSize = smpBlockSize,
+      thVersion = v,
+      thAuth = Nothing,
+      implySessId = v >= authCmdsSMPVersion,
+      batch = True
+    }
+
+testTHandleAuth :: VersionSMP -> TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe THandleAuth)
+testTHandleAuth v g (C.APublicAuthKey a k) = case a of
+  C.SX25519 | v >= authCmdsSMPVersion -> do
+    (_, privKey) <- atomically $ C.generateKeyPair g
+    pure $ Just THandleAuth {peerPubKey = k, privKey}
+  _ -> pure Nothing
+
+randomSENDCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
+randomSENDCmd = randomSENDCmd_ C.SEd25519
+
+randomSENDCmdV7 :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
+randomSENDCmdV7 = randomSENDCmd_ C.SX25519
+
+randomSENDCmd_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
+randomSENDCmd_ a c len = do
   g <- C.newRandom
   sId <- atomically $ C.randomBytes 24 g
-  (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g
+  (_, rpKey) <- atomically $ C.generateAuthKeyPair a g
   msg <- atomically $ C.randomBytes len g
   mkTransmission c (Just rpKey, sId, Cmd SSender $ SEND noMsgFlags msg)
 

tests/CoreTests/CryptoTests.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module CoreTests.CryptoTests (cryptoTests) where
 
@@ -13,6 +15,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Encoding as LE
+import Data.Type.Equality
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
@@ -91,6 +94,16 @@ cryptoTests = do
   describe "sntrup761" $
     it "should enc/dec key" testSNTRUP761
 
+instance Eq C.APublicKey where
+  C.APublicKey a k == C.APublicKey a' k' = case testEquality a a' of
+    Just Refl -> k == k'
+    Nothing -> False
+
+instance Eq C.APrivateKey where
+  C.APrivateKey a k == C.APrivateKey a' k' = case testEquality a a' of
+    Just Refl -> k == k'
+    Nothing -> False
+
 testPadUnpadFile :: IO ()
 testPadUnpadFile = do
   let f = "tests/tmp/testpad"

tests/CoreTests/ProtocolErrorTests.hs

@@ -12,7 +12,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
-import Simplex.FileTransfer.Protocol (XFTPErrorType (..))
+import Simplex.FileTransfer.Transport (XFTPErrorType (..))
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String

tests/CoreTests/TRcvQueuesTests.hs

@@ -0,0 +1,144 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeApplications #-}
+
+module CoreTests.TRcvQueuesTests where
+
+import AgentTests.EqInstances ()
+import qualified Data.List.NonEmpty as L
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Simplex.Messaging.Agent.Protocol (ConnId, QueueStatus (..), UserId)
+import Simplex.Messaging.Agent.Store (DBQueueId (..), RcvQueue, StoredRcvQueue (..))
+import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Protocol (SMPServer, pattern VersionSMPC)
+import Test.Hspec
+import UnliftIO
+
+tRcvQueuesTests :: Spec
+tRcvQueuesTests = do
+  describe "connection API" $ do
+    it "hasConn" hasConnTest
+    it "hasConn, batch add" hasConnTestBatch
+    it "deleteConn" deleteConnTest
+  describe "session API" $ do
+    it "getSessQueues" getSessQueuesTest
+    it "getDelSessQueues" getDelSessQueuesTest
+
+checkDataInvariant :: RQ.TRcvQueues -> IO Bool
+checkDataInvariant trq = atomically $ do
+  conns <- readTVar $ RQ.getConnections trq
+  qs <- readTVar $ RQ.getRcvQueues trq
+  -- three invariant checks
+  let inv1 = all (\cId -> (S.fromList . L.toList <$> M.lookup cId conns) == Just (M.keysSet (M.filter (\q -> connId q == cId) qs))) (M.keys conns)
+      inv2 = all (\(k, q) -> maybe False ((k `elem`) . L.toList) (M.lookup (connId q) conns)) (M.assocs qs)
+      inv3 = all (\(k, q) -> RQ.qKey q == k) (M.assocs qs)
+  pure $ inv1 && inv2 && inv3
+
+hasConnTest :: IO ()
+hasConnTest = do
+  trq <- atomically RQ.empty
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq
+  checkDataInvariant trq `shouldReturn` True
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq
+  checkDataInvariant trq `shouldReturn` True
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq
+  checkDataInvariant trq `shouldReturn` True
+  atomically (RQ.hasConn "c1" trq) `shouldReturn` True
+  atomically (RQ.hasConn "c2" trq) `shouldReturn` True
+  atomically (RQ.hasConn "c3" trq) `shouldReturn` True
+  atomically (RQ.hasConn "nope" trq) `shouldReturn` False
+
+hasConnTestBatch :: IO ()
+hasConnTestBatch = do
+  trq <- atomically RQ.empty
+  let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1", dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@beta" "c3"]
+  atomically $ RQ.batchAddQueues trq qs
+  checkDataInvariant trq `shouldReturn` True
+  atomically (RQ.hasConn "c1" trq) `shouldReturn` True
+  atomically (RQ.hasConn "c2" trq) `shouldReturn` True
+  atomically (RQ.hasConn "c3" trq) `shouldReturn` True
+  atomically (RQ.hasConn "nope" trq) `shouldReturn` False
+
+deleteConnTest :: IO ()
+deleteConnTest = do
+  trq <- atomically RQ.empty
+  atomically $ do
+    RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq
+    RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq
+    RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq
+  checkDataInvariant trq `shouldReturn` True
+  atomically $ RQ.deleteConn "c1" trq
+  checkDataInvariant trq `shouldReturn` True
+  atomically $ RQ.deleteConn "nope" trq
+  checkDataInvariant trq `shouldReturn` True
+  M.keys <$> readTVarIO (RQ.getConnections trq) `shouldReturn` ["c2", "c3"]
+
+getSessQueuesTest :: IO ()
+getSessQueuesTest = do
+  trq <- atomically RQ.empty
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq
+  checkDataInvariant trq `shouldReturn` True
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq
+  checkDataInvariant trq `shouldReturn` True
+  atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq
+  checkDataInvariant trq `shouldReturn` True
+  atomically $ RQ.addQueue (dummyRQ 1 "smp://1234-w==@beta" "c4") trq
+  checkDataInvariant trq `shouldReturn` True
+  atomically (RQ.getSessQueues (0, "smp://1234-w==@alpha", Just "c1") trq) `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c1"]
+  atomically (RQ.getSessQueues (1, "smp://1234-w==@alpha", Just "c1") trq) `shouldReturn` []
+  atomically (RQ.getSessQueues (0, "smp://1234-w==@alpha", Just "nope") trq) `shouldReturn` []
+  atomically (RQ.getSessQueues (0, "smp://1234-w==@alpha", Nothing) trq) `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@alpha" "c1"]
+
+getDelSessQueuesTest :: IO ()
+getDelSessQueuesTest = do
+  trq <- atomically RQ.empty
+  let qs =
+        [ dummyRQ 0 "smp://1234-w==@alpha" "c1",
+          dummyRQ 0 "smp://1234-w==@alpha" "c2",
+          dummyRQ 0 "smp://1234-w==@beta" "c3",
+          dummyRQ 1 "smp://1234-w==@beta" "c4"
+        ]
+  atomically $ RQ.batchAddQueues trq qs
+  checkDataInvariant trq `shouldReturn` True
+  -- no user
+  atomically (RQ.getDelSessQueues (2, "smp://1234-w==@alpha", Nothing) trq) `shouldReturn` ([], [])
+  checkDataInvariant trq `shouldReturn` True
+  -- wrong user
+  atomically (RQ.getDelSessQueues (1, "smp://1234-w==@alpha", Nothing) trq) `shouldReturn` ([], [])
+  checkDataInvariant trq `shouldReturn` True
+  -- connections intact
+  atomically (RQ.hasConn "c1" trq) `shouldReturn` True
+  atomically (RQ.hasConn "c2" trq) `shouldReturn` True
+  atomically (RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) trq) `shouldReturn` ([dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@alpha" "c1"], ["c1", "c2"])
+  checkDataInvariant trq `shouldReturn` True
+  -- connections gone
+  atomically (RQ.hasConn "c1" trq) `shouldReturn` False
+  atomically (RQ.hasConn "c2" trq) `shouldReturn` False
+  -- non-matched connections intact
+  atomically (RQ.hasConn "c3" trq) `shouldReturn` True
+  atomically (RQ.hasConn "c4" trq) `shouldReturn` True
+
+dummyRQ :: UserId -> SMPServer -> ConnId -> RcvQueue
+dummyRQ userId server connId =
+  RcvQueue
+    { userId,
+      connId,
+      server,
+      rcvId = "",
+      rcvPrivateKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe",
+      rcvDhSecret = "01234567890123456789012345678901",
+      e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk",
+      e2eDhSecret = Nothing,
+      sndId = "",
+      status = New,
+      dbQueueId = DBQueueId 0,
+      primary = True,
+      dbReplaceQueueId = Nothing,
+      rcvSwchStatus = Nothing,
+      smpClientVersion = VersionSMPC 123,
+      clientNtfCreds = Nothing,
+      deleteErrors = 0
+    }

tests/CoreTests/VersionRangeTests.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module CoreTests.VersionRangeTests where
@@ -8,6 +9,7 @@ module CoreTests.VersionRangeTests where
 import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
 import Simplex.Messaging.Version
+import Simplex.Messaging.Version.Internal
 import Test.Hspec
 import Test.Hspec.QuickCheck (modifyMaxSuccess)
 import Test.QuickCheck
@@ -16,6 +18,10 @@ data V = V1 | V2 | V3 | V4 | V5 deriving (Eq, Enum, Ord, Generic, Show)
 
 instance Arbitrary V where arbitrary = genericArbitraryU
 
+data T
+
+instance VersionScope T
+
 versionRangeTests :: Spec
 versionRangeTests = modifyMaxSuccess (const 1000) $ do
   describe "VersionRange construction" $ do
@@ -25,31 +31,31 @@ versionRangeTests = modifyMaxSuccess (const 1000) $ do
       (pure $! vr 2 1) `shouldThrow` anyErrorCall
   describe "compatible version" $ do
     it "should choose mutually compatible max version" $ do
-      (vr 1 1, vr 1 1) `compatible` Just 1
-      (vr 1 1, vr 1 2) `compatible` Just 1
-      (vr 1 2, vr 1 2) `compatible` Just 2
-      (vr 1 2, vr 2 3) `compatible` Just 2
-      (vr 1 3, vr 2 3) `compatible` Just 3
-      (vr 1 3, vr 2 4) `compatible` Just 3
+      (vr 1 1, vr 1 1) `compatible` Just (Version 1)
+      (vr 1 1, vr 1 2) `compatible` Just (Version 1)
+      (vr 1 2, vr 1 2) `compatible` Just (Version 2)
+      (vr 1 2, vr 2 3) `compatible` Just (Version 2)
+      (vr 1 3, vr 2 3) `compatible` Just (Version 3)
+      (vr 1 3, vr 2 4) `compatible` Just (Version 3)
       (vr 1 2, vr 3 4) `compatible` Nothing
     it "should check if version is compatible" $ do
-      isCompatible (1 :: Version) (vr 1 2) `shouldBe` True
-      isCompatible (2 :: Version) (vr 1 2) `shouldBe` True
-      isCompatible (2 :: Version) (vr 1 1) `shouldBe` False
-      isCompatible (1 :: Version) (vr 2 2) `shouldBe` False
+      isCompatible @T (Version 1) (vr 1 2) `shouldBe` True
+      isCompatible @T (Version 2) (vr 1 2) `shouldBe` True
+      isCompatible @T (Version 2) (vr 1 1) `shouldBe` False
+      isCompatible @T (Version 1) (vr 2 2) `shouldBe` False
     it "compatibleVersion should pass isCompatible check" . property $
       \((min1, max1) :: (V, V)) ((min2, max2) :: (V, V)) ->
         min1 > max1
           || min2 > max2 -- one of ranges is invalid, skip testing it
-          || let w = fromIntegral . fromEnum
-                 vr1 = mkVersionRange (w min1) (w max1) :: VersionRange
-                 vr2 = mkVersionRange (w min2) (w max2) :: VersionRange
+          || let w = Version . fromIntegral . fromEnum
+                 vr1 = mkVersionRange (w min1) (w max1) :: VersionRange T
+                 vr2 = mkVersionRange (w min2) (w max2) :: VersionRange T
               in case compatibleVersion vr1 vr2 of
                   Just (Compatible v) -> v `isCompatible` vr1 && v `isCompatible` vr2
                   _ -> True
   where
-    vr = mkVersionRange
-    compatible :: (VersionRange, VersionRange) -> Maybe Version -> Expectation
+    vr v1 v2 = mkVersionRange (Version v1) (Version v2)
+    compatible :: (VersionRange T, VersionRange T) -> Maybe (Version T) -> Expectation
     (vr1, vr2) `compatible` v = do
       (vr1, vr2) `checkCompatible` v
       (vr2, vr1) `checkCompatible` v

tests/FileDescriptionTests.hs

@@ -13,16 +13,20 @@ import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
 import System.Directory (removeFile)
 import Test.Hspec
 
 fileDescriptionTests :: Spec
-fileDescriptionTests =
+fileDescriptionTests = do
   describe "file description parsing / serializing" $ do
     it "parse YAML file description" testParseYAMLFileDescription
     it "serialize YAML file description" testSerializeYAMLFileDescription
     it "parse file description" testParseFileDescription
     it "serialize file description" testSerializeFileDescription
+    describe "file description URIs" $ do
+      it "round trip file description URI" testFileDescriptionURI
+      it "round trip file description URI with extra JSON" testFileDescriptionURIExtras
 
 fileDescPath :: FilePath
 fileDescPath = "tests/fixtures/file_description.yaml"
@@ -82,12 +86,13 @@ fileDesc =
                   FileChunkReplica {server = "xftp://[email protected]", replicaId, replicaKey}
                 ]
             }
-        ]
+        ],
+      redirect = Nothing
     }
   where
     defaultChunkSize = FileSize $ mb 8
     replicaId = ChunkReplicaId "abc"
-    replicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
+    replicaKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
     chunkDigest = FileDigest "ghi"
 
 yamlFileDesc :: YAMLFileDescription
@@ -128,7 +133,8 @@ yamlFileDesc =
                   "3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
                 ]
             }
-        ]
+        ],
+      redirect = Nothing
     }
 
 testParseYAMLFileDescription :: IO ()
@@ -157,6 +163,18 @@ testSerializeFileDescription = withRemoveTmpFile $ do
   fdExp <- B.readFile fileDescPath
   fdSer `shouldBe` fdExp
 
+testFileDescriptionURI :: IO ()
+testFileDescriptionURI = do
+  vfd <- either fail pure $ validateFileDescription fileDesc
+  let descr = FileDescriptionURI SSSimplex vfd mempty
+  strDecode (strEncode descr) `shouldBe` Right descr
+
+testFileDescriptionURIExtras :: IO ()
+testFileDescriptionURIExtras = do
+  vfd <- either fail pure $ validateFileDescription fileDesc
+  let descr = FileDescriptionURI SSSimplex vfd $ Just "{\"something\":\"extra\",\"more\":true}"
+  strDecode (strEncode descr) `shouldBe` Right descr
+
 withRemoveTmpFile :: IO () -> IO ()
 withRemoveTmpFile =
   bracket_

tests/NtfClient.hs

@@ -30,10 +30,11 @@ import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Server as H
 import Network.Socket
 import SMPClient (serverBracket)
-import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig)
-import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
+import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig)
+import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
+import Simplex.Messaging.Notifications.Protocol (NtfResponse)
 import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Push.APNS
@@ -45,6 +46,7 @@ import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams)
 import Simplex.Messaging.Transport.HTTP2.Server
 import Simplex.Messaging.Transport.Server
+import Simplex.Messaging.Version (mkVersionRange)
 import Test.Hspec
 import UnliftIO.Async
 import UnliftIO.Concurrent
@@ -69,11 +71,13 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 ntfTestStoreLogFile :: FilePath
 ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
 
-testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
+testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandleNTF c -> m a) -> m a
 testNtfClient client = do
   Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
-  runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h ->
-    liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
+  runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h -> do
+    g <- liftIO C.newRandom
+    ks <- atomically $ C.generateKeyPair g
+    liftIO (runExceptT $ ntfClientHandshake h ks testKeyHash supportedClientNTFVRange) >>= \case
       Right th -> client th
       Left e -> error $ show e
 
@@ -104,9 +108,17 @@ ntfServerCfg =
       logStatsStartTime = 0,
       serverStatsLogFile = "tests/ntf-server-stats.daily.log",
       serverStatsBackupFile = Nothing,
+      ntfServerVRange = supportedServerNTFVRange,
       transportConfig = defaultTransportServerConfig
     }
 
+ntfServerCfgV2 :: NtfServerConfig
+ntfServerCfgV2 =
+  ntfServerCfg
+    { ntfServerVRange = mkVersionRange initialNTFVersion authBatchCmdsNTFVersion,
+      smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}}
+    }
+
 withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
 withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t)]}
 
@@ -128,27 +140,27 @@ withNtfServerOn t port' = withNtfServerThreadOn t port' . const
 withNtfServer :: ATransport -> IO a -> IO a
 withNtfServer t = withNtfServerOn t ntfTestPort
 
-runNtfTest :: forall c a. Transport c => (THandle c -> IO a) -> IO a
+runNtfTest :: forall c a. Transport c => (THandleNTF c -> IO a) -> IO a
 runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
 
 ntfServerTest ::
   forall c smp.
   (Transport c, Encoding smp) =>
   TProxy c ->
-  (Maybe C.ASignature, ByteString, ByteString, smp) ->
-  IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg)
+  (Maybe TransmissionAuth, ByteString, ByteString, smp) ->
+  IO (Maybe TransmissionAuth, ByteString, ByteString, NtfResponse)
 ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
   where
-    tPut' :: THandle c -> (Maybe C.ASignature, ByteString, ByteString, smp) -> IO ()
-    tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do
-      let t' = smpEncode (sessionId, corrId, queueId, smp)
-      [Right ()] <- tPut h [(sig, t')]
+    tPut' :: THandleNTF c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
+    tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do
+      let t' = if implySessId then smpEncode (corrId, queueId, smp) else smpEncode (sessionId, corrId, queueId, smp)
+      [Right ()] <- tPut h [Right (sig, t')]
       pure ()
     tGet' h = do
       [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
-ntfTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
+ntfTest :: Transport c => TProxy c -> (THandleNTF c -> IO ()) -> Expectation
 ntfTest _ test' = runNtfTest test' `shouldReturn` ()
 
 data APNSMockRequest = APNSMockRequest

tests/NtfServerTests.hs

@@ -5,7 +5,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module NtfServerTests where
 
@@ -13,7 +15,6 @@ import Control.Concurrent (threadDelay)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import Data.Bifunctor (first)
-import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
@@ -33,10 +34,12 @@ import ServerTests
 import qualified Simplex.Messaging.Agent.Protocol as AP
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
+import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import qualified Simplex.Messaging.Notifications.Server.Push.APNS as APNS
+import Simplex.Messaging.Notifications.Transport (THandleNTF)
 import Simplex.Messaging.Parsers (parse, parseAll)
 import Simplex.Messaging.Protocol hiding (notification)
 import Simplex.Messaging.Transport
@@ -50,34 +53,41 @@ ntfServerTests t = do
 
 ntfSyntaxTests :: ATransport -> Spec
 ntfSyntaxTests (ATransport t) = do
-  it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN)
+  it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", NRErr $ CMD UNKNOWN)
   describe "NEW" $ do
-    it "no parameters" $ (sampleSig, "bcda", "", TNEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)
-    it "many parameters" $ (sampleSig, "cdab", "", (TNEW_, (' ', '\x01', 'A'), ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
-    it "no signature" $ ("", "dabc", "", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
-    it "token ID" $ (sampleSig, "abcd", "12345678", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
+    it "no parameters" $ (sampleSig, "bcda", "", TNEW_) >#> ("", "bcda", "", NRErr $ CMD SYNTAX)
+    it "many parameters" $ (sampleSig, "cdab", "", (TNEW_, (' ', '\x01', 'A'), ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", NRErr $ CMD SYNTAX)
+    it "no signature" $ ("", "dabc", "", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", NRErr $ CMD NO_AUTH)
+    it "token ID" $ (sampleSig, "abcd", "12345678", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", NRErr $ CMD HAS_AUTH)
   where
     (>#>) ::
       Encoding smp =>
-      (Maybe C.ASignature, ByteString, ByteString, smp) ->
-      (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) ->
+      (Maybe TransmissionAuth, ByteString, ByteString, smp) ->
+      (Maybe TransmissionAuth, ByteString, ByteString, NtfResponse) ->
       Expectation
     command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response
 
 pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission ErrorType NtfResponse
 pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command))
 
-sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
-sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
-  let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
-  Right () <- tPut1 h (sgn, t)
+deriving instance Eq NtfResponse
+
+sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c -> (Maybe TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
+sendRecvNtf h@THandle {params} (sgn, corrId, qId, cmd) = do
+  let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
+  Right () <- tPut1 h (sgn, tToSend)
   tGet1 h
 
-signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
-signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
-  let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
-  Right () <- tPut1 h (Just $ C.sign pk t, t)
+signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c -> C.APrivateAuthKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
+signSendRecvNtf h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do
+  let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
+  Right () <- tPut1 h (authorize tForAuth, tToSend)
   tGet1 h
+  where
+    authorize t = case a of
+      C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t
+      C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t
+      _ -> Nothing
 
 (.->) :: J.Value -> J.Key -> Either String ByteString
 v .-> key =
@@ -89,9 +99,9 @@ testNotificationSubscription (ATransport t) =
   -- hangs on Ubuntu 20/22
   xit' "should create notification subscription and notify when message is received" $ do
     g <- C.newRandom
-    (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-    (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
-    (tknPub, tknKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
+    (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+    (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+    (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
     (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
     let tkn = DeviceToken PPApnsTest "abcd"
     withAPNSMockServer $ \APNSMockServer {apnsQ} ->

tests/SMPAgentClient.hs

@@ -35,7 +35,8 @@ import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
 import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
 import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
-import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig)
+import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultSMPClientConfig, defaultNetworkConfig)
+import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth)
 import Simplex.Messaging.Transport
@@ -204,8 +205,8 @@ agentCfg =
     { tcpPort = agentTestPort,
       tbqSize = 4,
       -- database = testDB,
-      smpCfg = defaultClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS), networkConfig},
-      ntfCfg = defaultClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS), networkConfig},
+      smpCfg = defaultSMPClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS), networkConfig},
+      ntfCfg = defaultNTFClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS), networkConfig},
       reconnectInterval = fastRetryInterval,
       xftpNotifyErrsOnRetry = False,
       ntfWorkerDelay = 100,

tests/SMPClient.hs

@@ -26,7 +26,7 @@ import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Transport.Server
-import Simplex.Messaging.Version
+import Simplex.Messaging.Version (mkVersionRange)
 import System.Environment (lookupEnv)
 import System.Info (os)
 import Test.Hspec
@@ -34,6 +34,7 @@ import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar)
 import UnliftIO.Timeout (timeout)
+import Util
 
 testHost :: NonEmpty TransportHost
 testHost = "localhost"
@@ -60,24 +61,26 @@ testServerStatsBackupFile :: FilePath
 testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
 
 xit' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
-xit' = if os == "linux" then xit else it
+xit' d = if os == "linux" then skip "skipped on Linux" . it d else it d
 
 xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
 xit'' d t = do
   ci <- runIO $ lookupEnv "CI"
-  (if ci == Just "true" then xit else it) d t
+  (if ci == Just "true" then skip "skipped on CI" . it d else it d) t
 
-testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a
-testSMPClient client = do
+testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandleSMP c -> m a) -> m a
+testSMPClient = testSMPClientVR supportedClientSMPRelayVRange
+
+testSMPClientVR :: (Transport c, MonadUnliftIO m, MonadFail m) => VersionRangeSMP -> (THandleSMP c -> m a) -> m a
+testSMPClientVR vr client = do
   Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
-  runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h ->
-    liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case
+  runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> do
+    g <- liftIO C.newRandom
+    ks <- atomically $ C.generateKeyPair g
+    liftIO (runExceptT $ smpClientHandshake h ks testKeyHash vr) >>= \case
       Right th -> client th
       Left e -> error $ show e
 
-cfgV2 :: ServerConfig
-cfgV2 = cfg {smpServerVRange = mkVersionRange 1 2}
-
 cfg :: ServerConfig
 cfg =
   ServerConfig
@@ -92,6 +95,8 @@ cfg =
       storeMsgsFile = Nothing,
       allowNewQueues = True,
       newQueueBasicAuth = Nothing,
+      controlPortUserAuth = Nothing,
+      controlPortAdminAuth = Nothing,
       messageExpiration = Just defaultMessageExpiration,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       logStatsInterval = Nothing,
@@ -101,13 +106,13 @@ cfg =
       caCertificateFile = "tests/fixtures/ca.crt",
       privateKeyFile = "tests/fixtures/server.key",
       certificateFile = "tests/fixtures/server.crt",
-      smpServerVRange = supportedSMPServerVRange,
+      smpServerVRange = supportedServerSMPRelayVRange,
       transportConfig = defaultTransportServerConfig,
       controlPort = Nothing
     }
 
-withSmpServerStoreMsgLogOnV2 :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
-withSmpServerStoreMsgLogOnV2 t = withSmpServerConfigOn t cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
+cfgV7 :: ServerConfig
+cfgV7 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}
 
 withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
@@ -143,57 +148,66 @@ withSmpServerOn t port' = withSmpServerThreadOn t port' . const
 withSmpServer :: HasCallStack => ATransport -> IO a -> IO a
 withSmpServer t = withSmpServerOn t testPort
 
-runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandle c -> IO a) -> IO a
+withSmpServerV7 :: HasCallStack => ATransport -> IO a -> IO a
+withSmpServerV7 t = withSmpServerConfigOn t cfgV7 testPort . const
+
+runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandleSMP c -> IO a) -> IO a
 runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
 
-runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandle c] -> IO a) -> IO a
-runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients []
+runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c] -> IO a) -> IO a
+runSmpTestN = runSmpTestNCfg cfg supportedClientSMPRelayVRange
+
+runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c] -> IO a) -> IO a
+runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c) srvCfg testPort $ \_ -> run nClients []
   where
-    run :: Int -> [THandle c] -> IO a
+    run :: Int -> [THandleSMP c] -> IO a
     run 0 hs = test hs
-    run n hs = testSMPClient $ \h -> run (n - 1) (h : hs)
+    run n hs = testSMPClientVR clntVR $ \h -> run (n - 1) (h : hs)
 
 smpServerTest ::
   forall c smp.
   (Transport c, Encoding smp) =>
   TProxy c ->
-  (Maybe C.ASignature, ByteString, ByteString, smp) ->
-  IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg)
+  (Maybe TransmissionAuth, ByteString, ByteString, smp) ->
+  IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg)
 smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
   where
-    tPut' :: THandle c -> (Maybe C.ASignature, ByteString, ByteString, smp) -> IO ()
-    tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do
-      let t' = smpEncode (sessionId, corrId, queueId, smp)
-      [Right ()] <- tPut h [(sig, t')]
+    tPut' :: THandleSMP c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
+    tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do
+      let t' = if implySessId then smpEncode (corrId, queueId, smp) else smpEncode (sessionId, corrId, queueId, smp)
+      [Right ()] <- tPut h [Right (sig, t')]
       pure ()
     tGet' h = do
       [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
       pure (Nothing, corrId, qId, cmd)
 
-smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> IO ()) -> Expectation
+smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c -> IO ()) -> Expectation
 smpTest _ test' = runSmpTest test' `shouldReturn` ()
 
-smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandle c] -> IO ()) -> Expectation
+smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c] -> IO ()) -> Expectation
 smpTestN n test' = runSmpTestN n test' `shouldReturn` ()
 
-smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> IO ()) -> Expectation
-smpTest2 _ test' = smpTestN 2 _test
+smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
+smpTest2 = smpTest2Cfg cfg supportedClientSMPRelayVRange
+
+smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c -> (HasCallStack => THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
+smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` ()
   where
-    _test :: HasCallStack => [THandle c] -> IO ()
+    _test :: HasCallStack => [THandleSMP c] -> IO ()
     _test [h1, h2] = test' h1 h2
     _test _ = error "expected 2 handles"
 
-smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
+smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c -> THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
 smpTest3 _ test' = smpTestN 3 _test
   where
-    _test :: HasCallStack => [THandle c] -> IO ()
+    _test :: HasCallStack => [THandleSMP c] -> IO ()
     _test [h1, h2, h3] = test' h1 h2 h3
     _test _ = error "expected 3 handles"
 
-smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
+smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c -> THandleSMP c -> THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
 smpTest4 _ test' = smpTestN 4 _test
   where
-    _test :: HasCallStack => [THandle c] -> IO ()
+    _test :: HasCallStack => [THandleSMP c] -> IO ()
     _test [h1, h2, h3, h4] = test' h1 h2 h3 h4
     _test _ = error "expected 4 handles"