mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-04-25 14:12:33 +00:00
agent: xrcp implementation for connection via link (no multicast) (#884)
* WIP: start working on connection invites startSession/OOB is broken now - the port isn't coming from the actualy assigned one. * Add invite types * clean old invite-related types * apply renames * Move SessionKeys from Invitation * Stub host-side keys and handle * move keys and handles to Types * add Simplex.RemoteControl.Client * more keys * progress * crypto for sessions * progress to multicast * multicast crypto * add RC TLS server * agent api for remote control * WIP: tls client * fix test * update encoding to include nonce * add TODO * update * Use network-info to find TransportHost * request and submit tls client certificate * WIP: add missing bits for testing RC client * RCEncryptedHello encoding * add block encoding * refactor * validate known host certificate * remove some spaghetti * functional API to host/ctrl clients * refactor connectRCCtrl_ * refactor connectRCHost * question * add type * fix RC session * update doc * update doc 2 * add block on confirmation * remove unused parameter * export CtrlSessKeys * export * fix parsing * move test of xrcp handshake * move KEM to HELLO step * fix JSON * type --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
committed by
GitHub
GitHub
parent
1a0c4b73de
commit
1a8dfb4cbe
@@ -52,6 +52,7 @@ dependencies:
|
||||
- memory == 0.18.*
|
||||
- mtl == 2.3.*
|
||||
- network >= 3.1.2.7 && < 3.2
|
||||
- network-info >= 0.2 && < 0.3
|
||||
- network-transport == 0.5.6
|
||||
- network-udp >= 0.0 && < 0.1
|
||||
- optparse-applicative >= 0.15 && < 0.17
|
||||
|
||||
@@ -1,100 +1,101 @@
|
||||
# SimpleX Remote Control protocol
|
||||
|
||||
Using profiles in SimpleX Chat mobile app from desktop app with minimal risk to the security model of SimpleX protocols.
|
||||
Using profiles in SimpleX Chat mobile app from desktop app with minimal risk to the security/threat model of SimpleX protocols.
|
||||
|
||||
## Problem
|
||||
|
||||
Synchronizing profiles that use double ratchet for e2e encryption is effectively impossible in a way that tolerates partitioning between devices.
|
||||
Synchronizing profiles that use double ratchet for e2e encryption is effectively impossible in a way that tolerates partitioning between devices without reducing security of double ratchet.
|
||||
|
||||
We are not considering replacing double ratchet to allow profile synchronization, as some other messengers did. We are also not considering Signal model, when profile is known to the server and adding devices results in changing security code and no visibility of conversation history, as it would be substantially different from the current model.
|
||||
We are not considering replacing (or weakening) double ratchet to allow profile synchronization, as some other messengers did (e.g., Session). We are also not considering Signal model, when profile is known to the server and adding devices results in changing security code and no visibility of conversation history, as it would be substantially different from the current model, and also effectively weakens the security, as in practives most users don't revalidate security codes when they change.
|
||||
|
||||
## Solution
|
||||
|
||||
The proposed option is remote access/control protocol, when the application on host device (usually mobile) acts as a server, and application on another device (usually desktop) acts as a controller usually running in the same local network.
|
||||
The proposed solution is a new remote access/control protocol, when the application on host device (usually mobile) acts as a server, and application on another device (usually desktop) acts as a controller usually running in the same local network.
|
||||
|
||||
Service discovery and remote control protocols known to us are vulnerable to spoofing, spamming and MITM attacks. This design aims to solve these problems.
|
||||
Existing service discovery and remote control protocols known to us are vulnerable to spoofing, spamming and MITM attacks. This design aims to solve these problems.
|
||||
|
||||
## Requirements
|
||||
|
||||
- Strong, cryptographically verified identity of the controller device, with the initial connection requiring out-of-band communication of public keys (QR code or link).
|
||||
- Identity verification of the host device during session handshake.
|
||||
- Protection against malicious "controllers" trying to make host connect to them instead of valid controller on the same network.
|
||||
- Protection against replay attacks, both during discovery and during control session.
|
||||
- Additional encryption layer inside TLS.
|
||||
- Additional encryption layer inside TLS, with post-quantum algorithm in key agreement.
|
||||
- Protect host device from unauthorized access in case of controller compromise.
|
||||
- Have post-compromised security - that is, even if long term secrets were copied from the controller, and host device was made to connect to malicious controller device, prevent malicious controller from accessing the host device data.
|
||||
- Support general high-level interactions common for many applications:
|
||||
- Post-compromised security - that is, even if long term secrets were copied from the controller, and host device was made to connect to malicious controller device, prevent malicious controller from accessing the host device data.
|
||||
- Allow general high-level interactions common for many applications:
|
||||
- RPC pattern for commands executed by the host application.
|
||||
- Events sent by host to update controller UI.
|
||||
- Uploading and downloading files between host and controller, either to be processed by the host or to be presented in the controller UI.
|
||||
|
||||
This design is quite close to how SimpleX Chat UI interacts with SimpleX Chat core - there is a similar RPC + events protocol and support for files.
|
||||
This design will allow application-level protocol that is quite close to how SimpleX Chat UI interacts with SimpleX Chat core - there is a similar RPC + events protocol and support for files. The application-level protocol is out of scope of this specification.
|
||||
|
||||
## Protocol phases
|
||||
|
||||
Protocol consists of four phases:
|
||||
- controller session announcement
|
||||
- controller session invitation
|
||||
- establishing session TLS connection
|
||||
- session verification and protocol negotiation
|
||||
- session operation
|
||||
|
||||
### Session announcement
|
||||
### Session invitation
|
||||
|
||||
The first session between host and controller pair MUST be announced out-of-band, to establish a long term identity keys/certificates of the controller to host device.
|
||||
The invitation to the first session between host and controller pair MUST be shared out-of-band, to establish a long term identity keys/certificates of the controller to host device.
|
||||
|
||||
The subsequent sessions will be announced via an application-defined site-local multicast group, e.g. `224.0.0.251` (also used in mDNS/bonjour) and an application-defined port (SimpleX Chat uses 5227).
|
||||
The subsequent sessions can be announced via an application-defined site-local multicast group, e.g. `224.0.0.251` (also used in mDNS/bonjour) and an application-defined port (SimpleX Chat uses 5227).
|
||||
|
||||
The session announcement contains this data:
|
||||
The session invitation contains this data:
|
||||
- supported version range for remote control protocol
|
||||
- application name
|
||||
- device name
|
||||
- application-specific information, e.g. device name, application name and supported version range, settings, etc.
|
||||
- session start time in seconds since epoch
|
||||
- if multicast is used, counter of announce packets sent by controller
|
||||
- network address (ipv4 address and port) of the controller
|
||||
- CA TLS certificate fingerprint of the controller - this is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements.
|
||||
- Session Ed25519 public key used to verify the announcement and commands - this mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first.
|
||||
- Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity.
|
||||
- Session X25519 DH key and sntrup761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The initial out-of-band announcement is always unencrypted. These DH and KEM key are always sent unencrypted. NaCL Cryptobox is used for encryption.
|
||||
- additional application specific parameters, e.g controller settings.
|
||||
- Session X25519 DH key and sntrup761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. These DH public key and KEM encapsulation key are always sent unencrypted. NaCL Cryptobox is used for encryption.
|
||||
|
||||
Host device decrypts (except the first session) and validates the announcement:
|
||||
Host device decrypts (except the first session) and validates the invitation:
|
||||
- Session signature is valid.
|
||||
- Timestamp is within some window from the current time.
|
||||
- Long-term key signature is valid.
|
||||
- Long-term CA and key are the same as in the first session.
|
||||
- Some version in the range can be supported.
|
||||
- Long-term CA and signature key are the same as in the first session.
|
||||
- Some version in the offered range is supported.
|
||||
|
||||
OOB announcement is a URI with this syntax:
|
||||
OOB session invitation is a URI with this syntax:
|
||||
|
||||
```abnf
|
||||
sessionAddressUri = "xrcp://" encodedCAFingerprint "@" host ":" port "#/?" qsParams
|
||||
encodedCAFingerprint = base64url
|
||||
qsParams = param *("&" param)
|
||||
param = versionRangeParam / appNameParam / appVerionRangeParam / deviceNameParam / sessionTsParam /
|
||||
param = versionRangeParam / appInfoParam / sessionTsParam /
|
||||
sessPubKeyParam / idPubKeyParam / kemEncKeyParam / dhPubKeyParam /
|
||||
sessSignatureParam / idSignatureParam
|
||||
versionRangeParam = "v=" (versionParam / (versionParam "-" versionParam))
|
||||
versionParam = 1*DIGIT
|
||||
appNameParam = "app=" 1*(ALPHA / DIGIT / "-" / "_") ; optional
|
||||
appVerionRangeParam = "appv=" (versionParam / (versionParam "-" versionParam)) ; optional
|
||||
deviceNameParam = "device=" 1*(ALPHA / DIGIT / "-" / "_") ; optional
|
||||
appInfoParam = "app=" escapedJSON ; optional
|
||||
sessionTsParam = "ts=" 1*DIGIT
|
||||
sessPubKeyParam = "skey=" base64url ; required
|
||||
idPubKeyParam = "idkey=" base64url ; required
|
||||
kemEncKeyParam = "kem=" base64url ; required, can we have x509encoded?
|
||||
dhPubKeyParam = "dh=" base64url ; required
|
||||
sessSignatureParam = "ssig=" base64url ; required, signs the URI with this and idSignatureParam param removed
|
||||
idSignatureParam = "idsig=" base64url ; required, signs the URI with this param removed
|
||||
base64url = <base64url encoded binary> ; RFC4648, section 5
|
||||
```
|
||||
|
||||
Multicast announcement is a binary encoded packet with this syntax:
|
||||
Multicast session announcement is a binary encoded packet with this syntax:
|
||||
|
||||
```abnf
|
||||
sessionAddressPacket = dhPubKey length encrypted(serviceAddress sessSignature idSignature)
|
||||
sessionAddressPacket = dhPubKey nonce encrypted(unpaddedSize serviceAddress sessSignature idSignature packetPad)
|
||||
dhPubKey = length x509encoded
|
||||
serviceAddress = length addressJSON
|
||||
nonce = length *OCTET
|
||||
serviceAddress = largeLength serviceAddressJSON
|
||||
sessSignature = length *OCTET ; signs the preceding announcement packet
|
||||
idSignature = length *OCTET ; signs the preceding announcement packet including sessSignature
|
||||
length = 1*1 OCTET ; for binary data up to 255 bytes
|
||||
largeLength = 2*2 OCTET ; for binary data up to 65535 bytes
|
||||
packetPad = <pad packet size to 1450 bytes> ; possibly, we may need to move KEM agreement one step later,
|
||||
; with encapsulation key in HELLO block and KEM ciphertext in reply to HELLO.
|
||||
```
|
||||
|
||||
addressJSON is a JSON string valid against this JTD (RFC 8927) schema:
|
||||
@@ -122,13 +123,10 @@ addressJSON is a JSON string valid against this JTD (RFC 8927) schema:
|
||||
"v": {"ref": "versionRange"},
|
||||
"ts": {"type": "uint64"},
|
||||
"skey": {"ref": "base64url"},
|
||||
"idkey": {"ref": "base64url"},
|
||||
"kem": {"ref": "base64url"}
|
||||
"idkey": {"ref": "base64url"}
|
||||
},
|
||||
"optionalProperties": {
|
||||
"app": {"type": "string"},
|
||||
"appv": {"ref": "versionRange"},
|
||||
"device": {"type": "string"}
|
||||
"app": {"properties": {}, "additionalProperties": true}
|
||||
},
|
||||
"additionalProperties": true
|
||||
}
|
||||
@@ -136,41 +134,42 @@ addressJSON is a JSON string valid against this JTD (RFC 8927) schema:
|
||||
|
||||
### Establishing session TLS connection
|
||||
|
||||
Host connects to controller via TCP session and validates CA credentials during TLS handshake. Controller acts as a TCP server in this connection, to avoid host device listening on a port, which might create an attack vector. During TLS handshake the controller's TCP server presents a self-signed two-certificate chain where the fingerprint of the first certificate MUST be the same as in the announcement.
|
||||
Host connects to controller via TCP session and validates CA credentials during TLS handshake. Controller acts as a TCP server in this connection, to avoid host device listening on a port, which might create an attack vector. During TLS handshake the controller's TCP server MUST present a self-signed two-certificate chain where the fingerprint of the first certificate MUST be the same as in the announcement.
|
||||
|
||||
Host device presents its own client certificate chain with CA representing a long-term identity of the host device.
|
||||
|
||||
### Session verification and protocol negotiation
|
||||
|
||||
Once TLS session is established, both the host and controller device present a "session security code" to the user who must match them (e.g., visually or via QR code scan) and confirm on the host device. The session security code must be a digest of tlsunique channel binding. As it is computed as a digest of the TLS handshake for both the controller and the host, it will validate that the same TLS certificates are used on both sides, and that the same TLS session is established.
|
||||
Once TLS session is established, both the host and controller device present a "session security code" to the user who must match them (e.g., visually or via QR code scan) and confirm on the host device. The session security code must be a digest of tlsunique channel binding. As it is computed as a digest of the TLS handshake for both the controller and the host, it will validate that the same TLS certificates are used on both sides, and that the same TLS session is established, mitigating the possibility of MITM attack in the connection.
|
||||
|
||||
Once the session is confirmed by the user, the host device sends "hello" block to the controller. ALPN TLS extension is not used to obtain tlsunique prior to sending any packets.
|
||||
|
||||
Block size should be 16384 bytes.
|
||||
|
||||
Hello block must contain:
|
||||
- KEM ciphertext with encapsulated secret and new session DH key - used to compute new shared secret with the controller keys from the announcement.
|
||||
Host HELLO must contain:
|
||||
- new session DH key - used to compute new shared secret with the controller keys from the announcement.
|
||||
- encrypted part of hello block (JSON object), containing:
|
||||
- chosen protocol version.
|
||||
- host CA TLS certificate fingerprint - part of host long term identity - must match the one presented in TLS handshake and the previous sessions, otherwise the connection is terminated.
|
||||
- host device name
|
||||
- chosen application version.
|
||||
- additional application specific parameters, e.g host settings or JSON encoding format.
|
||||
- KEM encapsulation key - used to compute new shared secret for the session.
|
||||
- additional application specific parameters, e.g host device name, application version, host settings or JSON encoding format.
|
||||
|
||||
Hello block syntax:
|
||||
|
||||
|
||||
```abnf
|
||||
helloBlock = unpaddedSize %s"HELLO " dhPubKey kemCiphertext length encrypted(length helloBlockJSON) pad
|
||||
unpaddedSize = 2*2 OCTET
|
||||
hostHello = unpaddedSize %s"HELLO " dhPubKey nonce encrypted(unpaddedSize hostHelloJSON helloPad) pad
|
||||
unpaddedSize = largeLength
|
||||
dhPubKey = length x509encoded
|
||||
pad = <pad block size to 16384 bytes>
|
||||
kemCiphertext = length base64url
|
||||
helloPad = <pad hello size to 12888 bytes>
|
||||
largeLength = 2*2 OCTET
|
||||
```
|
||||
|
||||
Controller decrypts (including the first session) and validates the received hello block:
|
||||
- Chosen versions are supported (must be within offered ranges).
|
||||
- CA fingerprint matches the one presented in TLS handshake and the previous sessions - in subsequent sessions TLS connection should be rejected if the fingerprint is different.
|
||||
|
||||
JTD schema for the encrypted part of hello block:
|
||||
JTD schema for the encrypted part of host HELLO block `hostHelloJSON`:
|
||||
|
||||
```json
|
||||
{
|
||||
@@ -191,29 +190,61 @@ JTD schema for the encrypted part of hello block:
|
||||
"properties": {
|
||||
"v": {"ref": "version"},
|
||||
"ca": {"ref": "base64url"},
|
||||
"kem": {"ref": "base64url"}
|
||||
},
|
||||
"optionalProperties": {
|
||||
"device": {"type": "string"},
|
||||
"appVersion": {"ref": "version"}
|
||||
"app": {"properties": {}, "additionalProperties": true}
|
||||
},
|
||||
"additionalProperties": true
|
||||
}
|
||||
```
|
||||
|
||||
Controller should reply with with `ok` or `err` block:
|
||||
Controller should reply with with `hello` or `error` response:
|
||||
|
||||
```abnf
|
||||
ctrlHello = unpaddedSize %s"HELLO " kemCyphertext nonce encrypted(unpaddedSize ctrlHelloJSON helloPad) pad
|
||||
; ctrlHelloJSON is encrypted with the hybrid secret,
|
||||
; including both previously agreed DH secret and KEM secret from kemCyphertext
|
||||
unpaddedSize = largeLength
|
||||
kemCyphertext = largeLength *OCTET
|
||||
pad = <pad block size to 16384 bytes>
|
||||
helloPad = <pad hello size to 12888 bytes>
|
||||
largeLength = 2*2 OCTET
|
||||
|
||||
ctrlError = unpaddedSize %s"ERROR " nonce encrypted(unpaddedSize ctrlErrorJSON helloPad) pad
|
||||
; ctrlErrorJSON is encrypted using previously agreed DH secret.
|
||||
```
|
||||
ok = unpaddedSize %s"OK" pad
|
||||
err = unpaddedSize %s"ERR " length error pad
|
||||
|
||||
JTD schema for the encrypted part of controller HELLO block `ctrlHelloJSON`:
|
||||
|
||||
```json
|
||||
{
|
||||
"properties": {},
|
||||
"additionalProperties": true
|
||||
}
|
||||
```
|
||||
|
||||
JTD schema for the encrypted part of controller ERROR block `ctrlErrorJSON`:
|
||||
|
||||
```json
|
||||
{
|
||||
"properties": {
|
||||
"message": {"type": "string"}
|
||||
},
|
||||
"additionalProperties": true
|
||||
}
|
||||
```
|
||||
|
||||
Once controller replies HELLO to the valid host HELLO block, it should stop accepting new TCP connections.
|
||||
|
||||
|
||||
### Сontroller/host session operation
|
||||
|
||||
The protocol for communication during the session is out of scope of this protocol.
|
||||
|
||||
SimpleX Chat will use HTTP2 encoding, where host device acts as a server and controller acts as a client (these roles are reversed compared with TLS connection).
|
||||
|
||||
Payloads in the protocol must be encrypted using NaCL cryptobox using the shared secret agreed during session establishment.
|
||||
Payloads in the protocol must be encrypted using NaCL cryptobox using the hybrid shared secret agreed during session establishment.
|
||||
|
||||
Commands of the controller must be signed after the encryption using the controller's session and long term Ed25519 keys.
|
||||
|
||||
@@ -232,27 +263,30 @@ counter = 8*8 OCTET ; int64
|
||||
|
||||
Initial announcement is shared out-of-band, and it is not encrypted.
|
||||
|
||||
This announcement contains DH and KEM keys, which are used to agree session encryption keys - the HELLO block will containt DH key and KEM ciphertext with encapsulated secret that will be used to determine the shared secret (using SHA512 over concatenated DH shared secret and KEM encapsulated secret).
|
||||
This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will containt DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA256 over concatenated DH shared secret and KEM encapsulated secret) both for controller HELLO response (that contains KEM cyphertext in plaintext part) and subsequent session commands and responses.
|
||||
|
||||
During the next session we send announcement via encrypted multicast block. The shared key for this secret is determined using the KEM shared secred from the previous session and DH shared secret computed using the host DH key from the previous session and the new controller DH key from the announcement.
|
||||
During the next session the announcement is sent via encrypted multicast block. The shared key for this announcement and for host HELLO block is determined using the KEM shared secred from the previous session and DH shared secret computed using the host DH key from the previous session and the new controller DH key from the announcement.
|
||||
|
||||
For the session, the shared secred is computed again using the KEM shared secret encapsulated using the new KEM key from the announcement and DH shared secret computed using the host DH key from HELLO block and the new controller DH key from the announcement.
|
||||
For the session, the shared secred is computed again using the KEM shared secret encapsulated by the controller using the new KEM key from the HOST hello block and DH shared secret computed using the host DH key from HELLO block and the new controller DH key from the announcement.
|
||||
|
||||
To describe it in pseudocode:
|
||||
|
||||
```
|
||||
// session 1
|
||||
sessionSecret(1) = sha512(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. hello
|
||||
hostHelloSecret(1) = dhSecret(1)
|
||||
sessionSecret(1) = sha256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello
|
||||
dhSecret(1) = dh(hostHelloDhKey(1), controllerAnnouncementDhKey(1))
|
||||
kemCiphertext(1) = enc(kemSecret(1), kemEncKey(1))
|
||||
// kemEncKey is included in host HELLO, kemCiphertext - in controller HELLO
|
||||
kemSecret(1) = dec(kemCiphertext(1), kemDecKey(1))
|
||||
|
||||
// announcement for session n
|
||||
announcementSecret(n) = sha512(dhSecret(n') || kemSecret(n - 1))
|
||||
announcementSecret(n) = sha256(dhSecret(n') || kemSecret(n - 1))
|
||||
dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerAnnouncementDhKey(n))
|
||||
|
||||
// session n
|
||||
sessionSecret(n) = sha512(dhSecret(n) || kemSecret(n))
|
||||
hostHelloSecret(n) = sha256(dhSecret(n) || kemSecret(n - 1))
|
||||
sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello
|
||||
dhSecret(n) = dh(hostHelloDhKey(n), controllerAnnouncementDhKey(n))
|
||||
kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n))
|
||||
kemSecret(n) = dec(kemCiphertext(n), kemDecKey(n))
|
||||
@@ -283,7 +317,7 @@ The alternative design will use mobile host device as TLS server. The session ne
|
||||
Pros:
|
||||
- no reversing server role between TLS and HTTP2
|
||||
- TLS credentials are exchanged before TLS, so invalid credentials can be rejected during the handshake of the first session.
|
||||
- if some other way to pass data from host to controller is added, then it can be used with host running in VM.
|
||||
- if some other way to pass data from host to controller is added, then it can be used with host running in VM.
|
||||
|
||||
Cons:
|
||||
- multicast is mandatory, as there is no efficient way to communicate from mobile to desktop.
|
||||
|
||||
@@ -148,8 +148,10 @@ library
|
||||
Simplex.Messaging.Transport.WebSockets
|
||||
Simplex.Messaging.Util
|
||||
Simplex.Messaging.Version
|
||||
Simplex.RemoteControl.Client
|
||||
Simplex.RemoteControl.Discovery
|
||||
Simplex.RemoteControl.Discovery.Multicast
|
||||
Simplex.RemoteControl.Invitation
|
||||
Simplex.RemoteControl.Types
|
||||
other-modules:
|
||||
Paths_simplexmq
|
||||
@@ -192,6 +194,7 @@ library
|
||||
, memory ==0.18.*
|
||||
, mtl ==2.3.*
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
@@ -256,6 +259,7 @@ executable ntf-server
|
||||
, memory ==0.18.*
|
||||
, mtl ==2.3.*
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
@@ -321,6 +325,7 @@ executable smp-agent
|
||||
, memory ==0.18.*
|
||||
, mtl ==2.3.*
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
@@ -386,6 +391,7 @@ executable smp-server
|
||||
, memory ==0.18.*
|
||||
, mtl ==2.3.*
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
@@ -451,6 +457,7 @@ executable xftp
|
||||
, memory ==0.18.*
|
||||
, mtl ==2.3.*
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
@@ -516,6 +523,7 @@ executable xftp-server
|
||||
, memory ==0.18.*
|
||||
, mtl ==2.3.*
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
@@ -569,6 +577,7 @@ test-suite simplexmq-test
|
||||
FileDescriptionTests
|
||||
NtfClient
|
||||
NtfServerTests
|
||||
RemoteControl
|
||||
ServerTests
|
||||
SMPAgentClient
|
||||
SMPClient
|
||||
@@ -616,6 +625,7 @@ test-suite simplexmq-test
|
||||
, memory ==0.18.*
|
||||
, mtl ==2.3.*
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
|
||||
@@ -51,7 +51,6 @@ import Simplex.Messaging.Protocol
|
||||
tEncode,
|
||||
tEncodeBatch,
|
||||
tParse,
|
||||
_smpP,
|
||||
)
|
||||
import Simplex.Messaging.Transport (SessionId, TransportError (..))
|
||||
import Simplex.Messaging.Util (bshow, (<$?>))
|
||||
|
||||
@@ -93,6 +93,10 @@ module Simplex.Messaging.Agent
|
||||
xftpSendFile,
|
||||
xftpDeleteSndFileInternal,
|
||||
xftpDeleteSndFileRemote,
|
||||
rcNewHostPairing,
|
||||
rcConnectHost,
|
||||
rcConnectCtrlURI,
|
||||
rcConnectCtrlMulticast,
|
||||
foregroundAgent,
|
||||
suspendAgent,
|
||||
execAgentStoreSQL,
|
||||
@@ -111,6 +115,7 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift (MonadUnliftIO)
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random (MonadRandom)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Bifunctor (bimap, first, second)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
@@ -156,6 +161,8 @@ import qualified Simplex.Messaging.Protocol as SMP
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.RemoteControl.Client
|
||||
import Simplex.RemoteControl.Invitation
|
||||
import UnliftIO.Async (async, race_)
|
||||
import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
|
||||
import UnliftIO.STM
|
||||
@@ -379,6 +386,38 @@ xftpDeleteSndFileInternal c = withAgentEnv c . deleteSndFileInternal c
|
||||
xftpDeleteSndFileRemote :: AgentErrorMonad m => AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> m ()
|
||||
xftpDeleteSndFileRemote c = withAgentEnv c .:. deleteSndFileRemote c
|
||||
|
||||
-- | Create new remote host pairing
|
||||
rcNewHostPairing :: MonadIO m => m RCHostPairing
|
||||
rcNewHostPairing = liftIO newRCHostPairing
|
||||
|
||||
-- | start TLS server for remote host with optional multicast
|
||||
rcConnectHost :: AgentErrorMonad m => AgentClient -> RCHostPairing -> J.Value -> Bool -> m RCHostConnection
|
||||
rcConnectHost c = withAgentEnv c .:. rcConnectHost'
|
||||
|
||||
rcConnectHost' :: AgentMonad m => RCHostPairing -> J.Value -> Bool -> m RCHostConnection
|
||||
rcConnectHost' pairing ctrlAppInfo _multicast = do
|
||||
drg <- asks random
|
||||
liftError RCP $ connectRCHost drg pairing ctrlAppInfo
|
||||
|
||||
-- | connect to remote controller via URI
|
||||
rcConnectCtrlURI :: AgentErrorMonad m => AgentClient -> RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection
|
||||
rcConnectCtrlURI c = withAgentEnv c .:. rcConnectCtrlURI'
|
||||
|
||||
rcConnectCtrlURI' :: AgentMonad m => RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection
|
||||
rcConnectCtrlURI' signedInv pairing_ hostAppInfo = do
|
||||
drg <- asks random
|
||||
liftError RCP $ connectRCCtrlURI drg signedInv pairing_ hostAppInfo
|
||||
|
||||
-- | connect to known remote controller via multicast
|
||||
rcConnectCtrlMulticast :: AgentErrorMonad m => AgentClient -> NonEmpty RCCtrlPairing -> J.Value -> m RCCtrlConnection
|
||||
rcConnectCtrlMulticast c = withAgentEnv c .: rcConnectCtrlMulticast'
|
||||
|
||||
rcConnectCtrlMulticast' :: AgentMonad m => NonEmpty RCCtrlPairing -> J.Value -> m RCCtrlConnection
|
||||
rcConnectCtrlMulticast' pairings hostAppInfo = do
|
||||
drg <- asks random
|
||||
subscribers <- newTVarIO 0 -- TODO: get from agent
|
||||
liftError RCP $ connectKnownRCCtrlMulticast drg subscribers pairings hostAppInfo
|
||||
|
||||
-- | Activate operations
|
||||
foregroundAgent :: MonadUnliftIO m => AgentClient -> m ()
|
||||
foregroundAgent c = withAgentEnv c $ foregroundAgent' c
|
||||
|
||||
@@ -211,6 +211,7 @@ import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTra
|
||||
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts_ (..))
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.RemoteControl.Types
|
||||
import Text.Read
|
||||
import UnliftIO.Exception (Exception)
|
||||
|
||||
@@ -1419,6 +1420,8 @@ data AgentErrorType
|
||||
NTF {ntfErr :: ErrorType}
|
||||
| -- | XFTP protocol errors forwarded to agent clients
|
||||
XFTP {xftpErr :: XFTPErrorType}
|
||||
| -- | XRCP protocol errors forwarded to agent clients
|
||||
RCP {rcpErr :: RCErrorType}
|
||||
| -- | SMP server errors
|
||||
BROKER {brokerAddress :: String, brokerErr :: BrokerErrorType}
|
||||
| -- | errors of other agents
|
||||
@@ -1524,6 +1527,7 @@ instance StrEncoding AgentErrorType where
|
||||
<|> "SMP " *> (SMP <$> strP)
|
||||
<|> "NTF " *> (NTF <$> strP)
|
||||
<|> "XFTP " *> (XFTP <$> strP)
|
||||
<|> "RCP " *> (RCP <$> strP)
|
||||
<|> "BROKER " *> (BROKER <$> textP <* " RESPONSE " <*> (RESPONSE <$> textP))
|
||||
<|> "BROKER " *> (BROKER <$> textP <* " TRANSPORT " <*> (TRANSPORT <$> transportErrorP))
|
||||
<|> "BROKER " *> (BROKER <$> textP <* A.space <*> parseRead1)
|
||||
@@ -1540,6 +1544,7 @@ instance StrEncoding AgentErrorType where
|
||||
SMP e -> "SMP " <> strEncode e
|
||||
NTF e -> "NTF " <> strEncode e
|
||||
XFTP e -> "XFTP " <> strEncode e
|
||||
RCP e -> "RCP " <> strEncode e
|
||||
BROKER srv (RESPONSE e) -> "BROKER " <> text srv <> " RESPONSE " <> text e
|
||||
BROKER srv (TRANSPORT e) -> "BROKER " <> text srv <> " TRANSPORT " <> serializeTransportError e
|
||||
BROKER srv e -> "BROKER " <> text srv <> " " <> bshow e
|
||||
|
||||
@@ -237,7 +237,7 @@ defaultNetworkConfig =
|
||||
|
||||
transportClientConfig :: NetworkConfig -> TransportClientConfig
|
||||
transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
|
||||
TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors}
|
||||
TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing}
|
||||
|
||||
-- | protocol client configuration.
|
||||
data ProtocolClientConfig = ProtocolClientConfig
|
||||
|
||||
@@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -678,6 +679,10 @@ class CryptoSignature s where
|
||||
signatureBytes :: s -> ByteString
|
||||
decodeSignature :: ByteString -> Either String s
|
||||
|
||||
instance CryptoSignature (Signature s) => StrEncoding (Signature s) where
|
||||
strEncode = serializeSignature
|
||||
strDecode = decodeSignature
|
||||
|
||||
instance CryptoSignature ASignature where
|
||||
signatureBytes (ASignature _ sig) = signatureBytes sig
|
||||
decodeSignature s
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Simplex.Messaging.Crypto.SNTRUP761 where
|
||||
|
||||
@@ -8,21 +9,36 @@ import Data.ByteArray (ScrubbedBytes)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString (ByteString)
|
||||
import Simplex.Messaging.Crypto
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
|
||||
|
||||
-- Hybrid shared secret for crypto_box is defined as SHA256(DHSecret || KEMSharedKey),
|
||||
-- similar to https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/
|
||||
|
||||
class KEMSharedSecret kem where kemSecretBytes :: kem -> ScrubbedBytes
|
||||
|
||||
newtype KEMHybridSecret = KEMHybridSecret ScrubbedBytes
|
||||
|
||||
newtype KEMHybridOrDHSecret = KEMHybridOrDHSecret ScrubbedBytes
|
||||
|
||||
instance KEMSharedSecret KEMHybridSecret where kemSecretBytes (KEMHybridSecret secret) = secret
|
||||
|
||||
instance KEMSharedSecret KEMHybridOrDHSecret where kemSecretBytes (KEMHybridOrDHSecret secret) = secret
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared hybrid DH + KEM secret and 192-bit nonce.
|
||||
kcbDecrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
kcbDecrypt (KEMHybridSecret secret) = sbDecrypt_ secret
|
||||
kcbDecrypt :: KEMSharedSecret kem => kem -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
kcbDecrypt = sbDecrypt_ . kemSecretBytes
|
||||
|
||||
-- | NaCl @crypto_box@ encrypt with a shared hybrid DH + KEM secret and 192-bit nonce.
|
||||
kcbEncrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
kcbEncrypt (KEMHybridSecret secret) = sbEncrypt_ secret
|
||||
kcbEncrypt :: KEMSharedSecret kem => kem -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
kcbEncrypt = sbEncrypt_ . kemSecretBytes
|
||||
|
||||
kemHybridSecret :: DhSecret 'X25519 -> KEMSharedKey -> KEMHybridSecret
|
||||
kemHybridSecret (DhSecretX25519 k1) (KEMSharedKey k2) =
|
||||
KEMHybridSecret $ BA.convert (hash $ BA.convert k1 <> k2 :: Digest SHA256)
|
||||
kemHybridSecret :: PublicKeyX25519 -> PrivateKeyX25519 -> KEMSharedKey -> KEMHybridSecret
|
||||
kemHybridSecret k pk (KEMSharedKey kem) =
|
||||
let DhSecretX25519 dh = C.dh' k pk
|
||||
in KEMHybridSecret $ BA.convert (hash $ BA.convert dh <> kem :: Digest SHA256)
|
||||
|
||||
kemHybridOrDHSecret :: PublicKeyX25519 -> PrivateKeyX25519 -> Maybe KEMSharedKey -> KEMHybridOrDHSecret
|
||||
kemHybridOrDHSecret k pk = \case
|
||||
Just kem -> KEMHybridOrDHSecret $ kemSecretBytes $ kemHybridSecret k pk kem
|
||||
Nothing -> let DhSecretX25519 dh = C.dh' k pk in KEMHybridOrDHSecret $ BA.convert dh
|
||||
|
||||
@@ -4,6 +4,7 @@ module Simplex.Messaging.Crypto.SNTRUP761.Bindings where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import Data.Bifunctor (bimap)
|
||||
import Data.ByteArray (ScrubbedBytes)
|
||||
import qualified Data.ByteArray as BA
|
||||
@@ -16,14 +17,20 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
|
||||
newtype KEMPublicKey = KEMPublicKey ByteString
|
||||
deriving (Show)
|
||||
|
||||
newtype KEMSecretKey = KEMSecretKey ScrubbedBytes
|
||||
deriving (Show)
|
||||
|
||||
newtype KEMCiphertext = KEMCiphertext ByteString
|
||||
deriving (Show)
|
||||
|
||||
newtype KEMSharedKey = KEMSharedKey ScrubbedBytes
|
||||
deriving (Show)
|
||||
|
||||
sntrup761Keypair :: TVar ChaChaDRG -> IO (KEMPublicKey, KEMSecretKey)
|
||||
type KEMKeyPair = (KEMPublicKey, KEMSecretKey)
|
||||
|
||||
sntrup761Keypair :: TVar ChaChaDRG -> IO KEMKeyPair
|
||||
sntrup761Keypair drg =
|
||||
bimap KEMPublicKey KEMSecretKey
|
||||
<$> BA.allocRet
|
||||
@@ -51,14 +58,17 @@ sntrup761Dec (KEMCiphertext c) (KEMSecretKey sk) =
|
||||
KEMSharedKey
|
||||
<$> BA.alloc c_SNTRUP761_SIZE (\kPtr -> c_sntrup761_dec kPtr cPtr skPtr)
|
||||
|
||||
instance Encoding KEMPublicKey where
|
||||
smpEncode (KEMPublicKey pk) = smpEncode (BA.convert pk :: ByteString)
|
||||
smpP = KEMPublicKey . BA.convert <$> smpP @ByteString
|
||||
|
||||
instance StrEncoding KEMPublicKey where
|
||||
strEncode (KEMPublicKey pk) = strEncode (BA.convert pk :: ByteString)
|
||||
strP = KEMPublicKey . BA.convert <$> strP @ByteString
|
||||
|
||||
instance Encoding KEMCiphertext where
|
||||
smpEncode (KEMCiphertext c) = smpEncode (BA.convert c :: ByteString)
|
||||
smpP = KEMCiphertext . BA.convert <$> smpP @ByteString
|
||||
smpEncode (KEMCiphertext c) = smpEncode . Large $ BA.convert c
|
||||
smpP = KEMCiphertext . BA.convert . unLarge <$> smpP
|
||||
|
||||
instance ToJSON KEMPublicKey where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
instance FromJSON KEMPublicKey where
|
||||
parseJSON = strParseJSON "KEMPublicKey"
|
||||
|
||||
@@ -11,6 +11,7 @@ module Simplex.Messaging.Encoding
|
||||
( Encoding (..),
|
||||
Tail (..),
|
||||
Large (..),
|
||||
_smpP,
|
||||
smpEncodeList,
|
||||
smpListP,
|
||||
lenEncode,
|
||||
@@ -143,6 +144,9 @@ instance Encoding SystemTime where
|
||||
smpP = MkSystemTime <$> smpP <*> pure 0
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
_smpP :: Encoding a => Parser a
|
||||
_smpP = A.space *> smpP
|
||||
|
||||
-- lists encode/parse as a sequence of items prefixed with list length (as 1 byte)
|
||||
smpEncodeList :: Encoding a => [a] -> ByteString
|
||||
smpEncodeList xs = B.cons (lenEncode $ length xs) . B.concat $ map smpEncode xs
|
||||
|
||||
@@ -1203,9 +1203,6 @@ instance ProtocolEncoding ErrorType BrokerMsg where
|
||||
| B.null queueId -> Left $ CMD NO_ENTITY
|
||||
| otherwise -> Right cmd
|
||||
|
||||
_smpP :: Encoding a => Parser a
|
||||
_smpP = A.space *> smpP
|
||||
|
||||
-- | Parse SMP protocol commands and broker messages
|
||||
parseProtocol :: forall err msg. ProtocolEncoding err msg => Version -> ByteString -> Either err msg
|
||||
parseProtocol v s =
|
||||
|
||||
@@ -110,12 +110,13 @@ instance IsString (NonEmpty TransportHost) where fromString = parseString strDec
|
||||
data TransportClientConfig = TransportClientConfig
|
||||
{ socksProxy :: Maybe SocksProxy,
|
||||
tcpKeepAlive :: Maybe KeepAliveOpts,
|
||||
logTLSErrors :: Bool
|
||||
logTLSErrors :: Bool,
|
||||
clientCredentials :: Maybe (X.CertificateChain, T.PrivKey)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
defaultTransportClientConfig :: TransportClientConfig
|
||||
defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True
|
||||
defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True Nothing
|
||||
|
||||
clientTransportConfig :: TransportClientConfig -> TransportConfig
|
||||
clientTransportConfig TransportClientConfig {logTLSErrors} =
|
||||
@@ -126,9 +127,9 @@ runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig ->
|
||||
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} proxyUsername host port keyHash client = do
|
||||
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials} proxyUsername host port keyHash client = do
|
||||
let hostName = B.unpack $ strEncode host
|
||||
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash
|
||||
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials
|
||||
connectTCP = case socksProxy of
|
||||
Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host
|
||||
_ -> connectTCPClient hostName
|
||||
@@ -205,14 +206,19 @@ instance ToJSON SocksProxy where
|
||||
instance FromJSON SocksProxy where
|
||||
parseJSON = strParseJSON "SocksProxy"
|
||||
|
||||
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
|
||||
mkTLSClientParams supported caStore_ host port keyHash_ = do
|
||||
let p = B.pack port
|
||||
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_ =
|
||||
(T.defaultParamsClient host p)
|
||||
{ T.clientShared = maybe def (\caStore -> def {T.sharedCAStore = caStore}) caStore_,
|
||||
T.clientHooks = maybe def (\keyHash -> def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p}) keyHash_,
|
||||
{ T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
|
||||
T.clientHooks =
|
||||
def
|
||||
{ T.onServerCertificate = maybe def (\cafp _ _ _ -> validateCertificateChain cafp host p) cafp_,
|
||||
T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_
|
||||
},
|
||||
T.clientSupported = supported
|
||||
}
|
||||
where
|
||||
p = B.pack port
|
||||
|
||||
validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
|
||||
validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain]
|
||||
|
||||
@@ -13,7 +13,7 @@ import Data.ASN1.Types (getObjectID)
|
||||
import Data.ASN1.Types.String (ASN1StringEncoding (UTF8))
|
||||
import Data.Hourglass (Hours (..), timeAdd)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import qualified Data.X509 as X509
|
||||
@@ -34,9 +34,9 @@ tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credentials)
|
||||
tlsCredentials credentials = (C.KeyHash rootFP, TLS.Credentials [(X509.CertificateChain certs, privateToTls $ snd leafKey)])
|
||||
where
|
||||
Fingerprint rootFP = getFingerprint root X509.HashSHA256
|
||||
leafKey = fst $ NE.head credentials
|
||||
root = snd $ NE.last credentials
|
||||
certs = map snd $ NE.toList credentials
|
||||
leafKey = fst $ L.head credentials
|
||||
root = snd $ L.last credentials
|
||||
certs = map snd $ L.toList credentials
|
||||
|
||||
privateToTls :: C.APrivateSignKey -> TLS.PrivKey
|
||||
privateToTls (C.APrivateSignKey _ k) = case k of
|
||||
|
||||
@@ -66,7 +66,7 @@ defaultHTTP2ClientConfig =
|
||||
HTTP2ClientConfig
|
||||
{ qSize = 64,
|
||||
connTimeout = 10000000,
|
||||
transportConfig = TransportClientConfig Nothing Nothing True,
|
||||
transportConfig = TransportClientConfig Nothing Nothing True Nothing,
|
||||
bufferSize = defaultHTTP2BufferSize,
|
||||
bodyHeadSize = 16384,
|
||||
suportedTLSParams = http2TLSParams
|
||||
|
||||
528
src/Simplex/RemoteControl/Client.hs
Normal file
528
src/Simplex/RemoteControl/Client.hs
Normal file
@@ -0,0 +1,528 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.RemoteControl.Client
|
||||
( RCHostPairing (..),
|
||||
RCHostClient (action),
|
||||
RCHostSession (..),
|
||||
RCHostHello (..),
|
||||
HostSessKeys (..),
|
||||
RCHostConnection,
|
||||
SessionCode,
|
||||
newRCHostPairing,
|
||||
connectRCHost,
|
||||
cancelHostClient,
|
||||
RCCtrlPairing (..),
|
||||
RCCtrlClient (action),
|
||||
RCCtrlSession (..),
|
||||
CtrlSessKeys (..),
|
||||
RCCtrlConnection,
|
||||
connectRCCtrlURI,
|
||||
connectKnownRCCtrlMulticast,
|
||||
confirmCtrlSession,
|
||||
cancelCtrlClient,
|
||||
RCStepTMVar,
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.TH as JQ
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Default (def)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (isNothing)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock.System (getSystemTime)
|
||||
import qualified Data.X509 as X509
|
||||
import Data.X509.Validation (Fingerprint (..), getFingerprint)
|
||||
import Network.Socket (PortNumber)
|
||||
import qualified Network.TLS as TLS
|
||||
import Simplex.Messaging.Agent.Client ()
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.SNTRUP761
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.Transport (TLS (tlsUniq), cGet, cPut)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost, defaultTransportClientConfig, runTransportClient)
|
||||
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, ifM, liftEitherWith, safeDecodeUtf8, tshow)
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.RemoteControl.Discovery (getLocalAddress, startTLSServer)
|
||||
import Simplex.RemoteControl.Invitation
|
||||
import Simplex.RemoteControl.Types
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent (forkIO)
|
||||
|
||||
currentRCVersion :: Version
|
||||
currentRCVersion = 1
|
||||
|
||||
supportedRCVRange :: VersionRange
|
||||
supportedRCVRange = mkVersionRange 1 currentRCVersion
|
||||
|
||||
xrcpBlockSize :: Int
|
||||
xrcpBlockSize = 16384
|
||||
|
||||
helloBlockSize :: Int
|
||||
helloBlockSize = 12288
|
||||
|
||||
data RCHostHello = RCHostHello
|
||||
{ v :: Version,
|
||||
ca :: C.KeyHash,
|
||||
app :: J.Value,
|
||||
kem :: KEMPublicKey
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''RCHostHello)
|
||||
|
||||
data RCCtrlHello = RCCtrlHello {}
|
||||
deriving (Show)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON {J.nullaryToObject = True} ''RCCtrlHello)
|
||||
|
||||
newRCHostPairing :: IO RCHostPairing
|
||||
newRCHostPairing = do
|
||||
((_, caKey), caCert) <- genCredentials Nothing (-25, 24 * 999999) "ca"
|
||||
(_, idPrivKey) <- C.generateKeyPair'
|
||||
pure RCHostPairing {caKey, caCert, idPrivKey, knownHost = Nothing}
|
||||
|
||||
data RCHostClient = RCHostClient
|
||||
{ action :: Async (),
|
||||
client_ :: RCHClient_
|
||||
}
|
||||
|
||||
data RCHClient_ = RCHClient_
|
||||
{ startedPort :: TMVar (Maybe PortNumber),
|
||||
hostCAHash :: TMVar C.KeyHash,
|
||||
endSession :: TMVar (),
|
||||
tlsEnded :: TMVar (Either RCErrorType ())
|
||||
}
|
||||
|
||||
-- tlsunique channel binding
|
||||
type SessionCode = ByteString
|
||||
|
||||
type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
|
||||
|
||||
type RCStepTMVar a = TMVar (Either RCErrorType a)
|
||||
|
||||
connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> ExceptT RCErrorType IO RCHostConnection
|
||||
connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo = do
|
||||
r <- newEmptyTMVarIO
|
||||
host <- getLocalAddress >>= maybe (throwError RCENoLocalAddress) pure
|
||||
c@RCHClient_ {startedPort, tlsEnded} <- liftIO mkClient
|
||||
hostKeys <- liftIO genHostKeys
|
||||
action <- liftIO $ runClient c r hostKeys
|
||||
void . forkIO $ do
|
||||
res <- atomically $ takeTMVar tlsEnded
|
||||
either (logError . ("XRCP session ended with error: " <>) . tshow) (\() -> logInfo "XRCP session ended") res
|
||||
uninterruptibleCancel action
|
||||
-- wait for the port to make invitation
|
||||
-- TODO can't we actually find to which interface the server got connected to get host there?
|
||||
portNum <- atomically $ readTMVar startedPort
|
||||
signedInv <- maybe (throwError RCETLSStartFailed) (liftIO . mkInvitation hostKeys host) portNum
|
||||
pure (signedInv, RCHostClient {action, client_ = c}, r)
|
||||
where
|
||||
mkClient :: IO RCHClient_
|
||||
mkClient = do
|
||||
startedPort <- newEmptyTMVarIO
|
||||
endSession <- newEmptyTMVarIO
|
||||
tlsEnded <- newEmptyTMVarIO
|
||||
hostCAHash <- newEmptyTMVarIO
|
||||
pure RCHClient_ {startedPort, hostCAHash, endSession, tlsEnded}
|
||||
runClient :: RCHClient_ -> RCStepTMVar (ByteString, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> IO (Async ())
|
||||
runClient RCHClient_ {startedPort, hostCAHash, endSession, tlsEnded} r hostKeys = do
|
||||
tlsCreds <- genTLSCredentials caKey caCert
|
||||
startTLSServer startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls -> do
|
||||
res <- handleAny (pure . Left . RCEException . show) . runExceptT $ do
|
||||
logDebug "Incoming TLS connection"
|
||||
r' <- newEmptyTMVarIO
|
||||
atomically $ putTMVar r $ Right (tlsUniq tls, r')
|
||||
-- TODO lock session
|
||||
hostEncHello <- receiveRCPacket tls
|
||||
logDebug "Received host HELLO"
|
||||
hostCA <- atomically $ takeTMVar hostCAHash
|
||||
(ctrlEncHello, sessionKeys, helloBody, pairing') <- prepareHostSession drg hostCA pairing hostKeys hostEncHello
|
||||
sendRCPacket tls ctrlEncHello
|
||||
logDebug "Sent ctrl HELLO"
|
||||
atomically $ putTMVar r' $ Right (RCHostSession {tls, sessionKeys}, helloBody, pairing')
|
||||
-- can use `RCHostSession` until `endSession` is signalled
|
||||
logDebug "Holding session"
|
||||
atomically $ takeTMVar endSession
|
||||
logDebug $ "TLS connection finished with " <> tshow res
|
||||
atomically $ putTMVar tlsEnded res
|
||||
tlsHooks :: TMVar a -> Maybe KnownHostPairing -> TMVar C.KeyHash -> TLS.ServerHooks
|
||||
tlsHooks r knownHost_ hostCAHash =
|
||||
def
|
||||
{ TLS.onUnverifiedClientCert = pure True,
|
||||
TLS.onNewHandshake = \_ -> atomically $ isNothing <$> tryReadTMVar r,
|
||||
TLS.onClientCertificate = \(X509.CertificateChain chain) ->
|
||||
case chain of
|
||||
[_leaf, ca] -> do
|
||||
let Fingerprint fp = getFingerprint ca X509.HashSHA256
|
||||
kh = C.KeyHash fp
|
||||
atomically $ putTMVar hostCAHash kh
|
||||
let accept = maybe True (\h -> h.hostFingerprint == kh) knownHost_
|
||||
pure $ if accept then TLS.CertificateUsageAccept else TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA
|
||||
_ ->
|
||||
pure $ TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA
|
||||
}
|
||||
genHostKeys :: IO RCHostKeys
|
||||
genHostKeys = do
|
||||
sessKeys <- C.generateKeyPair'
|
||||
dhKeys <- C.generateKeyPair'
|
||||
pure RCHostKeys {sessKeys, dhKeys}
|
||||
mkInvitation :: RCHostKeys -> TransportHost -> PortNumber -> IO RCSignedInvitation
|
||||
mkInvitation RCHostKeys {sessKeys, dhKeys} host portNum = do
|
||||
ts <- getSystemTime
|
||||
let inv =
|
||||
RCInvitation
|
||||
{ ca = certFingerprint caCert,
|
||||
host,
|
||||
port = fromIntegral portNum,
|
||||
v = supportedRCVRange,
|
||||
app = ctrlAppInfo,
|
||||
ts,
|
||||
skey = fst sessKeys,
|
||||
idkey = C.publicKey idPrivKey,
|
||||
dh = fst dhKeys
|
||||
}
|
||||
signedInv = signInviteURL (snd sessKeys) idPrivKey inv
|
||||
pure signedInv
|
||||
|
||||
genTLSCredentials :: C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials
|
||||
genTLSCredentials caKey caCert = do
|
||||
let caCreds = (C.signatureKeyPair caKey, caCert)
|
||||
leaf <- genCredentials (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert
|
||||
pure . snd $ tlsCredentials (leaf :| [caCreds])
|
||||
|
||||
certFingerprint :: X509.SignedCertificate -> C.KeyHash
|
||||
certFingerprint caCert = C.KeyHash fp
|
||||
where
|
||||
Fingerprint fp = getFingerprint caCert X509.HashSHA256
|
||||
|
||||
cancelHostClient :: RCHostClient -> IO ()
|
||||
cancelHostClient RCHostClient {action, client_ = RCHClient_ {endSession}} = do
|
||||
atomically $ putTMVar endSession ()
|
||||
uninterruptibleCancel action
|
||||
|
||||
prepareHostSession :: TVar ChaChaDRG -> C.KeyHash -> RCHostPairing -> RCHostKeys -> RCHostEncHello -> ExceptT RCErrorType IO (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing)
|
||||
prepareHostSession
|
||||
drg
|
||||
tlsHostFingerprint
|
||||
pairing@RCHostPairing {idPrivKey, knownHost = knownHost_}
|
||||
RCHostKeys {sessKeys = (_, sessPrivKey), dhKeys = (_, dhPrivKey)}
|
||||
RCHostEncHello {dhPubKey, nonce, encBody} = do
|
||||
let sharedKey = kemHybridOrDHSecret dhPubKey dhPrivKey $ (\h -> h.storedSessKeys.kemSharedKey) <$> knownHost_
|
||||
helloBody <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt sharedKey nonce encBody
|
||||
hostHello@RCHostHello {v, ca, kem = kemPubKey} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody
|
||||
(kemCiphertext, kemSharedKey) <- liftIO $ sntrup761Enc drg kemPubKey
|
||||
let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
|
||||
unless (isCompatible v supportedRCVRange) $ throwError RCEVersion
|
||||
let keys = HostSessKeys {hybridKey, idPrivKey, sessPrivKey}
|
||||
storedSessKeys = StoredHostSessKeys {hostDHPublicKey = dhPubKey, kemSharedKey}
|
||||
knownHost' <- updateKnownHost ca storedSessKeys
|
||||
let ctrlHello = RCCtrlHello {}
|
||||
-- TODO send error response if something fails
|
||||
nonce' <- liftIO . atomically $ C.pseudoRandomCbNonce drg
|
||||
encBody' <- liftEitherWith (const RCEBlockSize) $ kcbEncrypt hybridKey nonce' (LB.toStrict $ J.encode ctrlHello) helloBlockSize
|
||||
let ctrlEncHello = RCCtrlEncHello {kem = kemCiphertext, nonce = nonce', encBody = encBody'}
|
||||
pure (ctrlEncHello, keys, hostHello, pairing {knownHost = Just knownHost'})
|
||||
where
|
||||
updateKnownHost :: C.KeyHash -> StoredHostSessKeys -> ExceptT RCErrorType IO KnownHostPairing
|
||||
updateKnownHost ca storedSessKeys = case knownHost_ of
|
||||
Just h -> do
|
||||
unless (h.hostFingerprint == tlsHostFingerprint) . throwError $
|
||||
RCEInternal "TLS host CA is different from host pairing, should be caught in TLS handshake"
|
||||
unless (ca == tlsHostFingerprint) $ throwError RCEIdentity
|
||||
pure (h :: KnownHostPairing) {storedSessKeys}
|
||||
Nothing -> pure KnownHostPairing {hostFingerprint = ca, storedSessKeys}
|
||||
|
||||
data RCCtrlClient = RCCtrlClient
|
||||
{ action :: Async (),
|
||||
client_ :: RCCClient_
|
||||
}
|
||||
|
||||
data RCCClient_ = RCCClient_
|
||||
{ confirmSession :: TMVar Bool,
|
||||
endSession :: TMVar (),
|
||||
tlsEnded :: TMVar (Either RCErrorType ())
|
||||
}
|
||||
|
||||
type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
|
||||
|
||||
connectRCCtrlURI :: TVar ChaChaDRG -> RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
|
||||
connectRCCtrlURI drg signedInv@RCSignedInvitation {invitation} pairing_ hostAppInfo = do
|
||||
unless (verifySignedInviteURI signedInv) $ throwError RCECtrlAuth
|
||||
connectRCCtrl drg invitation pairing_ hostAppInfo
|
||||
|
||||
-- app should determine whether it is a new or known pairing based on CA fingerprint in the invitation
|
||||
connectRCCtrl :: TVar ChaChaDRG -> RCInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
|
||||
connectRCCtrl drg inv@RCInvitation {ca, idkey} pairing_ hostAppInfo = do
|
||||
pairing' <- maybe (liftIO newCtrlPairing) updateCtrlPairing pairing_
|
||||
connectRCCtrl_ drg pairing' inv hostAppInfo
|
||||
where
|
||||
newCtrlPairing :: IO RCCtrlPairing
|
||||
newCtrlPairing = do
|
||||
((_, caKey), caCert) <- genCredentials Nothing (0, 24 * 999999) "ca"
|
||||
(_, dhPrivKey) <- C.generateKeyPair'
|
||||
let storedSessKeys = StoredCtrlSessKeys dhPrivKey Nothing
|
||||
pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, storedSessKeys, prevStoredSessKeys = Nothing}
|
||||
updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
|
||||
updateCtrlPairing pairing@RCCtrlPairing {ctrlFingerprint, idPubKey, storedSessKeys = currSSK} = do
|
||||
unless (ca == ctrlFingerprint && idPubKey == idkey) $ throwError RCEIdentity
|
||||
(_, dhPrivKey) <- liftIO C.generateKeyPair'
|
||||
pure pairing {storedSessKeys = currSSK {dhPrivKey}, prevStoredSessKeys = Just currSSK}
|
||||
|
||||
connectRCCtrl_ :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
|
||||
connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, host, port} hostAppInfo = do
|
||||
r <- newEmptyTMVarIO
|
||||
c <- liftIO mkClient
|
||||
action <- async $ runClient c r
|
||||
pure (RCCtrlClient {action, client_ = c}, r)
|
||||
where
|
||||
mkClient :: IO RCCClient_
|
||||
mkClient = do
|
||||
tlsEnded <- newEmptyTMVarIO
|
||||
confirmSession <- newEmptyTMVarIO
|
||||
endSession <- newEmptyTMVarIO
|
||||
pure RCCClient_ {confirmSession, endSession, tlsEnded}
|
||||
runClient :: RCCClient_ -> RCStepTMVar (SessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO ()
|
||||
runClient RCCClient_ {confirmSession, endSession, tlsEnded} r = do
|
||||
clientCredentials <-
|
||||
liftIO (genTLSCredentials caKey caCert) >>= \case
|
||||
TLS.Credentials [one] -> pure $ Just one
|
||||
_ -> throwError $ RCEInternal "genTLSCredentials must generate only one set of credentials"
|
||||
let clientConfig = defaultTransportClientConfig {clientCredentials}
|
||||
liftIO $ runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls -> do
|
||||
logDebug "Got TLS connection"
|
||||
-- TODO this seems incorrect still
|
||||
res <- handleAny (pure . Left . RCEException . show) . runExceptT $ do
|
||||
logDebug "Waiting for session confirmation"
|
||||
r' <- newEmptyTMVarIO
|
||||
atomically $ putTMVar r $ Right (tlsUniq tls, r') -- (RCCtrlSession {tls, sessionKeys = ctrlSessKeys}, pairing')
|
||||
ifM
|
||||
(atomically $ readTMVar confirmSession)
|
||||
(runSession tls r')
|
||||
(logDebug "Session rejected")
|
||||
atomically $ putTMVar tlsEnded res
|
||||
where
|
||||
runSession tls r' = do
|
||||
(sharedKey, kemPrivKey, hostEncHello) <- prepareHostHello drg pairing' inv hostAppInfo
|
||||
sendRCPacket tls hostEncHello
|
||||
ctrlEncHello <- receiveRCPacket tls
|
||||
logDebug "Received ctrl HELLO"
|
||||
(ctrlSessKeys, pairing'') <- prepareCtrlSession pairing' inv sharedKey kemPrivKey ctrlEncHello
|
||||
atomically $ putTMVar r' $ Right (RCCtrlSession {tls, sessionKeys = ctrlSessKeys}, pairing'')
|
||||
-- TODO receive OK response
|
||||
logDebug "Session started"
|
||||
-- release second putTMVar in confirmCtrlSession
|
||||
void . atomically $ takeTMVar confirmSession
|
||||
atomically $ takeTMVar endSession
|
||||
logDebug "Session ended"
|
||||
|
||||
sendRCPacket :: Encoding a => TLS -> a -> ExceptT RCErrorType IO ()
|
||||
sendRCPacket tls pkt = do
|
||||
b <- liftEitherWith (const RCEBlockSize) $ C.pad (smpEncode pkt) xrcpBlockSize
|
||||
liftIO $ cPut tls b
|
||||
|
||||
receiveRCPacket :: Encoding a => TLS -> ExceptT RCErrorType IO a
|
||||
receiveRCPacket tls = do
|
||||
b <- liftIO $ cGet tls xrcpBlockSize
|
||||
when (B.length b /= xrcpBlockSize) $ throwError RCEBlockSize
|
||||
b' <- liftEitherWith (const RCEBlockSize) $ C.unPad b
|
||||
liftEitherWith RCESyntax $ smpDecode b'
|
||||
|
||||
prepareHostHello :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO (KEMHybridOrDHSecret, KEMSecretKey, RCHostEncHello)
|
||||
prepareHostHello
|
||||
drg
|
||||
RCCtrlPairing {caCert, storedSessKeys = StoredCtrlSessKeys {dhPrivKey, kemSharedKey}}
|
||||
RCInvitation {v, dh = dhPubKey}
|
||||
hostAppInfo = do
|
||||
logDebug "Preparing session"
|
||||
case compatibleVersion v supportedRCVRange of
|
||||
Nothing -> throwError RCEVersion
|
||||
Just (Compatible v') -> do
|
||||
nonce <- liftIO . atomically $ C.pseudoRandomCbNonce drg
|
||||
(kemPubKey, kemPrivKey) <- liftIO $ sntrup761Keypair drg
|
||||
let Fingerprint fp = getFingerprint caCert X509.HashSHA256
|
||||
helloBody = RCHostHello {v = v', ca = C.KeyHash fp, app = hostAppInfo, kem = kemPubKey}
|
||||
sharedKey = kemHybridOrDHSecret dhPubKey dhPrivKey kemSharedKey
|
||||
encBody <- liftEitherWith (const RCEBlockSize) $ kcbEncrypt sharedKey nonce (LB.toStrict $ J.encode helloBody) helloBlockSize
|
||||
-- let sessKeys = CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey}
|
||||
let hostEncHello = RCHostEncHello {dhPubKey = C.publicKey dhPrivKey, nonce, encBody}
|
||||
pure (sharedKey, kemPrivKey, hostEncHello)
|
||||
|
||||
prepareCtrlSession :: RCCtrlPairing -> RCInvitation -> KEMHybridOrDHSecret -> KEMSecretKey -> RCCtrlEncHello -> ExceptT RCErrorType IO (CtrlSessKeys, RCCtrlPairing)
|
||||
prepareCtrlSession
|
||||
pairing@RCCtrlPairing {idPubKey, storedSessKeys = ssk@StoredCtrlSessKeys {dhPrivKey}}
|
||||
RCInvitation {skey, dh = dhPubKey}
|
||||
sharedKey
|
||||
kemPrivKey = \case
|
||||
RCCtrlEncHello {kem = kemCiphertext, nonce, encBody} -> do
|
||||
kemSharedKey <- liftIO $ sntrup761Dec kemCiphertext kemPrivKey
|
||||
let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
|
||||
helloBody <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt hybridKey nonce encBody
|
||||
logDebug "Decrypted ctrl HELLO"
|
||||
RCCtrlHello {} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody
|
||||
let sessKeys = CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey}
|
||||
pairing' = (pairing :: RCCtrlPairing) {storedSessKeys = ssk {kemSharedKey = Just kemSharedKey}}
|
||||
pure (sessKeys, pairing')
|
||||
RCCtrlEncError {nonce, encMessage} -> do
|
||||
message <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt sharedKey nonce encMessage
|
||||
throwError $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message
|
||||
|
||||
-- The application should save updated RCHostPairing after user confirmation of the session
|
||||
-- TMVar resolves when TLS is connected
|
||||
connectKnownRCCtrlMulticast :: TVar ChaChaDRG -> TVar Int -> NonEmpty RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
|
||||
connectKnownRCCtrlMulticast drg _subscribers pairings hostAppInfo = do
|
||||
-- start multicast
|
||||
-- receive packets
|
||||
let loop = undefined -- catch and log errors, fail on timeout
|
||||
receive = undefined
|
||||
parse = undefined
|
||||
(pairing, inv) <- loop $ receive >>= parse >>= findRCCtrlPairing pairings
|
||||
connectRCCtrl drg inv pairing hostAppInfo
|
||||
|
||||
findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErrorType IO (RCCtrlPairing, RCInvitation)
|
||||
findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do
|
||||
(pairing, signedInvStr) <- liftEither $ decrypt (L.toList pairings)
|
||||
signedInv@RCSignedInvitation {invitation} <- liftEitherWith RCESyntax $ smpDecode signedInvStr
|
||||
unless (verifySignedInvitationMulticast signedInv) $ throwError RCECtrlAuth
|
||||
pure (pairing, invitation)
|
||||
where
|
||||
decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString)
|
||||
decrypt [] = Left RCECtrlNotFound
|
||||
decrypt (pairing@RCCtrlPairing {storedSessKeys, prevStoredSessKeys} : rest) =
|
||||
let r = decrypt_ storedSessKeys <|> (decrypt_ =<< prevStoredSessKeys)
|
||||
in maybe (decrypt rest) (Right . (pairing,)) r
|
||||
decrypt_ :: StoredCtrlSessKeys -> Maybe ByteString
|
||||
decrypt_ StoredCtrlSessKeys {dhPrivKey, kemSharedKey} =
|
||||
let key = kemHybridOrDHSecret dhPubKey dhPrivKey kemSharedKey
|
||||
in eitherToMaybe $ kcbDecrypt key nonce encInvitation
|
||||
|
||||
-- application should call this function when TMVar resolves
|
||||
confirmCtrlSession :: RCCtrlClient -> Bool -> IO ()
|
||||
confirmCtrlSession RCCtrlClient {client_ = RCCClient_ {confirmSession}} res = do
|
||||
atomically $ putTMVar confirmSession res
|
||||
-- controler does takeTMVar, freeing the slot
|
||||
-- TODO add timeout
|
||||
atomically $ putTMVar confirmSession res -- wait for Ctrl to take the var
|
||||
|
||||
cancelCtrlClient :: RCCtrlClient -> IO ()
|
||||
cancelCtrlClient RCCtrlClient {action, client_ = RCCClient_ {endSession}} = do
|
||||
atomically $ putTMVar endSession ()
|
||||
uninterruptibleCancel action
|
||||
|
||||
-- | Long-term part of controller (desktop) connection to host (mobile)
|
||||
data RCHostPairing = RCHostPairing
|
||||
{ caKey :: C.APrivateSignKey,
|
||||
caCert :: C.SignedCertificate,
|
||||
idPrivKey :: C.PrivateKeyEd25519,
|
||||
knownHost :: Maybe KnownHostPairing
|
||||
}
|
||||
|
||||
data KnownHostPairing = KnownHostPairing
|
||||
{ hostFingerprint :: C.KeyHash, -- this is only changed in the first session, long-term identity of connected remote host
|
||||
storedSessKeys :: StoredHostSessKeys
|
||||
}
|
||||
|
||||
data StoredHostSessKeys = StoredHostSessKeys
|
||||
{ hostDHPublicKey :: C.PublicKeyX25519, -- sent by host in HELLO block. Matches one of the DH keys in RCCtrlPairing
|
||||
kemSharedKey :: KEMSharedKey
|
||||
}
|
||||
|
||||
-- | Long-term part of host (mobile) connection to controller (desktop)
|
||||
data RCCtrlPairing = RCCtrlPairing
|
||||
{ caKey :: C.APrivateSignKey,
|
||||
caCert :: C.SignedCertificate,
|
||||
ctrlFingerprint :: C.KeyHash, -- long-term identity of connected remote controller
|
||||
idPubKey :: C.PublicKeyEd25519,
|
||||
storedSessKeys :: StoredCtrlSessKeys,
|
||||
prevStoredSessKeys :: Maybe StoredCtrlSessKeys
|
||||
}
|
||||
|
||||
data StoredCtrlSessKeys = StoredCtrlSessKeys
|
||||
{ dhPrivKey :: C.PrivateKeyX25519,
|
||||
kemSharedKey :: Maybe KEMSharedKey -- this is Nothing only for a new pairing, and once connected it is always Just.
|
||||
}
|
||||
|
||||
data RCHostKeys = RCHostKeys
|
||||
{ sessKeys :: C.KeyPair 'C.Ed25519,
|
||||
dhKeys :: C.KeyPair 'C.X25519
|
||||
}
|
||||
|
||||
-- Connected session with Host
|
||||
data RCHostSession = RCHostSession
|
||||
{ tls :: TLS,
|
||||
sessionKeys :: HostSessKeys
|
||||
}
|
||||
|
||||
data HostSessKeys = HostSessKeys
|
||||
{ hybridKey :: KEMHybridSecret,
|
||||
idPrivKey :: C.PrivateKeyEd25519,
|
||||
sessPrivKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
|
||||
-- Host: RCCtrlPairing + RCInvitation => (RCCtrlSession, RCCtrlPairing)
|
||||
|
||||
data RCCtrlSession = RCCtrlSession
|
||||
{ tls :: TLS,
|
||||
sessionKeys :: CtrlSessKeys
|
||||
}
|
||||
|
||||
data CtrlSessKeys = CtrlSessKeys
|
||||
{ hybridKey :: KEMHybridSecret,
|
||||
idPubKey :: C.PublicKeyEd25519,
|
||||
sessPubKey :: C.PublicKeyEd25519
|
||||
}
|
||||
|
||||
data RCHostEncHello = RCHostEncHello
|
||||
{ dhPubKey :: C.PublicKeyX25519,
|
||||
nonce :: C.CbNonce,
|
||||
encBody :: ByteString
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Encoding RCHostEncHello where
|
||||
smpEncode RCHostEncHello {dhPubKey, nonce, encBody} =
|
||||
"HELLO " <> smpEncode (dhPubKey, nonce, Tail encBody)
|
||||
smpP = do
|
||||
(dhPubKey, nonce, Tail encBody) <- "HELLO " *> smpP
|
||||
pure RCHostEncHello {dhPubKey, nonce, encBody}
|
||||
|
||||
data RCCtrlEncHello
|
||||
= RCCtrlEncHello {kem :: KEMCiphertext, nonce :: C.CbNonce, encBody :: ByteString}
|
||||
| RCCtrlEncError {nonce :: C.CbNonce, encMessage :: ByteString}
|
||||
deriving (Show)
|
||||
|
||||
instance Encoding RCCtrlEncHello where
|
||||
smpEncode = \case
|
||||
RCCtrlEncHello {kem, nonce, encBody} -> "HELLO " <> smpEncode (kem, nonce, Tail encBody)
|
||||
RCCtrlEncError {nonce, encMessage} -> "ERROR " <> smpEncode (nonce, Tail encMessage)
|
||||
smpP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"HELLO" -> do
|
||||
(kem, nonce, Tail encBody) <- _smpP
|
||||
pure RCCtrlEncHello {kem, nonce, encBody}
|
||||
"ERROR" -> do
|
||||
(nonce, Tail encMessage) <- _smpP
|
||||
pure RCCtrlEncError {nonce, encMessage}
|
||||
_ -> fail "bad RCCtrlEncHello"
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@@ -8,24 +7,23 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
-- XXX: remove non-discovery functions
|
||||
module Simplex.RemoteControl.Discovery where
|
||||
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Crypto.Random (getRandomBytes)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Base64.URL as B64U
|
||||
import Data.Default (def)
|
||||
import Data.Maybe (listToMaybe, mapMaybe)
|
||||
import Data.String (IsString)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.Time.Clock.System (getSystemTime)
|
||||
import Data.Word (Word16)
|
||||
import Network.Info (IPv4 (..), NetworkInterface (..), getNetworkInterfaces)
|
||||
import qualified Network.Socket as N
|
||||
import qualified Network.TLS as TLS
|
||||
import qualified Network.UDP as UDP
|
||||
import Simplex.RemoteControl.Discovery.Multicast (setMembership)
|
||||
import Simplex.RemoteControl.Types
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding (Encoding (..))
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
@@ -34,7 +32,9 @@ import qualified Simplex.Messaging.Transport as Transport
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportClientConfig, runTransportClient)
|
||||
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer)
|
||||
import Simplex.Messaging.Util (ifM, tshow)
|
||||
import Simplex.Messaging.Version (mkVersionRange)
|
||||
import Simplex.Messaging.Version (VersionRange)
|
||||
import Simplex.RemoteControl.Discovery.Multicast (setMembership)
|
||||
import Simplex.RemoteControl.Types
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent
|
||||
|
||||
@@ -48,39 +48,18 @@ pattern ANY_ADDR_V4 = "0.0.0.0"
|
||||
pattern DISCOVERY_PORT :: (IsString a, Eq a) => a
|
||||
pattern DISCOVERY_PORT = "5227"
|
||||
|
||||
startSession :: MonadIO m => Maybe Text -> (N.HostAddress, Word16) -> C.KeyHash -> m ((C.APublicDhKey, C.APrivateDhKey), C.PrivateKeyEd25519, Announce, SignedOOB)
|
||||
startSession deviceName serviceAddress caFingerprint = liftIO $ do
|
||||
sessionStart <- getSystemTime
|
||||
dh@(C.APublicDhKey C.SX25519 sessionDH, _) <- C.generateDhKeyPair C.SX25519
|
||||
(C.APublicVerifyKey C.SEd25519 sigPubKey, C.APrivateSignKey C.SEd25519 sigSecretKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||
let
|
||||
announce =
|
||||
Announce
|
||||
{ versionRange = announceVersionRange,
|
||||
sessionStart,
|
||||
announceCounter = 0,
|
||||
serviceAddress,
|
||||
caFingerprint,
|
||||
sessionDH,
|
||||
announceKey = sigPubKey
|
||||
}
|
||||
authToken <- decodeUtf8 . B64U.encode <$> getRandomBytes 12
|
||||
let
|
||||
oob =
|
||||
OOB
|
||||
{ caFingerprint,
|
||||
authToken,
|
||||
host = decodeUtf8 . strEncode $ THIPv4 . N.hostAddressToTuple $ fst serviceAddress,
|
||||
port = snd serviceAddress,
|
||||
version = mkVersionRange 1 1,
|
||||
appName = "simplex-chat",
|
||||
sigPubKey,
|
||||
deviceName
|
||||
}
|
||||
pure (dh, sigSecretKey, announce, signOOB sigSecretKey oob)
|
||||
getLocalAddress :: MonadIO m => m (Maybe TransportHost)
|
||||
getLocalAddress = listToMaybe . mapMaybe usable <$> liftIO getNetworkInterfaces
|
||||
where
|
||||
usable NetworkInterface {ipv4 = IPv4 ha} = case N.hostAddressToTuple ha of
|
||||
(0, 0, 0, 0) -> Nothing -- "no" address
|
||||
(255, 255, 255, 255) -> Nothing -- broadcast
|
||||
(127, _, _, _) -> Nothing -- localhost
|
||||
(169, 254, _, _) -> Nothing -- link-local
|
||||
ok -> Just $ THIPv4 ok
|
||||
|
||||
getLocalAddress :: MonadIO m => TMVar Int -> m (Maybe N.HostAddress)
|
||||
getLocalAddress subscribers = liftIO $ do
|
||||
getLocalAddressMulticast :: MonadIO m => TMVar Int -> m (Maybe TransportHost)
|
||||
getLocalAddressMulticast subscribers = liftIO $ do
|
||||
probe <- mkIpProbe
|
||||
let bytes = smpEncode probe
|
||||
withListener subscribers $ \receiver ->
|
||||
@@ -89,7 +68,7 @@ getLocalAddress subscribers = liftIO $ do
|
||||
let expect = do
|
||||
UDP.recvFrom receiver >>= \case
|
||||
(p, _) | p /= bytes -> expect
|
||||
(_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure host
|
||||
(_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure $ THIPv4 (N.hostAddressToTuple host)
|
||||
(_, UDP.ClientSockAddr _badAddr _) -> error "receiving from IPv4 socket"
|
||||
timeout 1000000 expect
|
||||
|
||||
@@ -101,57 +80,77 @@ mkIpProbe = do
|
||||
-- | Announce tls server, wait for connection and attach http2 client to it.
|
||||
--
|
||||
-- Announcer is started when TLS server is started and stopped when a connection is made.
|
||||
announceCtrl :: MonadUnliftIO m => (MVar () -> MVar rc -> Transport.TLS -> IO ()) -> Tasks -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> m () -> m rc
|
||||
announceCtrl runCtrl tasks (sigKey, announce@Announce {caFingerprint, serviceAddress=(host, _port)}) credentials finishAction = do
|
||||
announceCtrl ::
|
||||
MonadUnliftIO m =>
|
||||
(MVar rc -> MVar () -> Transport.TLS -> IO ()) ->
|
||||
Tasks ->
|
||||
TMVar (Maybe N.PortNumber) ->
|
||||
Maybe (Text, VersionRange) ->
|
||||
Maybe Text ->
|
||||
C.PrivateKeyEd25519 ->
|
||||
CtrlSessionKeys ->
|
||||
-- | Session address to announce
|
||||
TransportHost ->
|
||||
m () ->
|
||||
m rc
|
||||
announceCtrl runCtrl tasks started app_ device_ idkey sk@CtrlSessionKeys {ca, credentials} host finishAction = do
|
||||
ctrlStarted <- newEmptyMVar
|
||||
started <- newEmptyTMVarIO
|
||||
ctrlFinished <- newEmptyMVar
|
||||
_ <- forkIO $ readMVar ctrlFinished >> finishAction -- attach external cleanup action to session lock
|
||||
announcer <- async . liftIO $ atomically (takeTMVar started) >>= \case
|
||||
Nothing -> pure () -- TLS server failed to start, skipping announcer
|
||||
Just givenPort -> do
|
||||
logInfo $ "Starting announcer for " <> ident <> " at " <> tshow (host, givenPort)
|
||||
runAnnouncer (sigKey, announce {serviceAddress = (host, fromIntegral givenPort)})
|
||||
announcer <-
|
||||
async . liftIO $
|
||||
atomically (readTMVar started) >>= \case
|
||||
Nothing -> pure () -- TLS server failed to start, skipping announcer
|
||||
Just givenPort -> do
|
||||
logInfo $ "Starting announcer for " <> ident <> " at " <> tshow (host, givenPort)
|
||||
runAnnouncer app_ device_ idkey sk (host, givenPort) -- (sigKey, announce {serviceAddress = (host, fromIntegral givenPort)})
|
||||
tasks `registerAsync` announcer
|
||||
tlsServer <- startTLSServer started credentials $ \tls -> do
|
||||
let hooks = undefined -- TODO
|
||||
tlsServer <- startTLSServer started credentials hooks $ \tls -> do
|
||||
logInfo $ "Incoming connection for " <> ident
|
||||
cancel announcer
|
||||
runCtrl ctrlFinished ctrlStarted tls `catchAny` (logError . tshow)
|
||||
runCtrl ctrlStarted ctrlFinished tls `catchAny` (logError . tshow)
|
||||
logInfo $ "Client finished for " <> ident
|
||||
_ <- forkIO $ waitCatch tlsServer >> void (tryPutMVar ctrlFinished ())
|
||||
tasks `registerAsync` tlsServer
|
||||
logInfo $ "Waiting for client for " <> ident
|
||||
readMVar ctrlStarted
|
||||
where
|
||||
ident = decodeUtf8 $ strEncode caFingerprint
|
||||
ident = decodeUtf8 $ strEncode ca
|
||||
|
||||
runAnnouncer :: Maybe (Text, VersionRange) -> Maybe Text -> C.PrivateKeyEd25519 -> CtrlSessionKeys -> (TransportHost, N.PortNumber) -> IO ()
|
||||
runAnnouncer app_ device_ idSigKey sk (host, port) = error "runAnnouncer: make invites, encrypt and send"
|
||||
|
||||
-- | Send replay-proof announce datagrams
|
||||
runAnnouncer :: (C.PrivateKeyEd25519, Announce) -> IO ()
|
||||
runAnnouncer (announceKey, initialAnnounce) = withSender $ loop initialAnnounce
|
||||
where
|
||||
loop announce sock = do
|
||||
UDP.send sock $ smpEncode (signAnnounce announceKey announce)
|
||||
threadDelay 1000000
|
||||
loop announce {announceCounter = announceCounter announce + 1} sock
|
||||
-- runAnnouncer :: (C.PrivateKeyEd25519, Announce) -> IO ()
|
||||
-- runAnnouncer (announceKey, initialAnnounce) = withSender $ loop initialAnnounce
|
||||
-- where
|
||||
-- loop announce sock = do
|
||||
-- UDP.send sock $ smpEncode (signAnnounce announceKey announce)
|
||||
-- threadDelay 1000000
|
||||
-- loop announce {announceCounter = announceCounter announce + 1} sock
|
||||
|
||||
startTLSServer :: (MonadUnliftIO m) => TMVar (Maybe N.PortNumber) -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
|
||||
startTLSServer started credentials server = async . liftIO $ do
|
||||
startedOk <- newEmptyTMVarIO
|
||||
bracketOnError (startTCPServer startedOk "0") (\_e -> void . atomically $ tryPutTMVar started Nothing) $ \socket ->
|
||||
-- XXX: move to RemoteControl.Client
|
||||
startTLSServer :: MonadUnliftIO m => TMVar (Maybe N.PortNumber) -> TLS.Credentials -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> m (Async ())
|
||||
startTLSServer startedOnPort credentials hooks server = async . liftIO $ do
|
||||
started <- newEmptyTMVarIO
|
||||
bracketOnError (startTCPServer started "0") (\_e -> setPort Nothing) $ \socket ->
|
||||
ifM
|
||||
(atomically $ readTMVar startedOk)
|
||||
do
|
||||
port <- N.socketPort socket
|
||||
logInfo $ "System-assigned port: " <> tshow port
|
||||
atomically $ putTMVar started (Just port)
|
||||
runTransportServerSocket startedOk (pure socket) "RCP TLS" serverParams defaultTransportServerConfig server
|
||||
(void . atomically $ tryPutTMVar started Nothing)
|
||||
(atomically $ readTMVar started)
|
||||
(runServer started socket)
|
||||
(setPort Nothing)
|
||||
where
|
||||
runServer started socket = do
|
||||
port <- N.socketPort socket
|
||||
logInfo $ "System-assigned port: " <> tshow port
|
||||
setPort $ Just port
|
||||
runTransportServerSocket started (pure socket) "RCP TLS" serverParams defaultTransportServerConfig server
|
||||
setPort = void . atomically . tryPutTMVar startedOnPort
|
||||
serverParams =
|
||||
def
|
||||
{ TLS.serverWantClientCert = False,
|
||||
{ TLS.serverWantClientCert = True,
|
||||
TLS.serverShared = def {TLS.sharedCredentials = credentials},
|
||||
TLS.serverHooks = def,
|
||||
TLS.serverHooks = hooks,
|
||||
TLS.serverSupported = supportedParameters
|
||||
}
|
||||
|
||||
@@ -171,8 +170,9 @@ openListener subscribers = liftIO $ do
|
||||
pure sock
|
||||
|
||||
closeListener :: MonadIO m => TMVar Int -> UDP.ListenSocket -> m ()
|
||||
closeListener subscribers sock = liftIO $
|
||||
partMulticast subscribers (UDP.listenSocket sock) (listenerHostAddr4 sock) `finally` UDP.stop sock
|
||||
closeListener subscribers sock =
|
||||
liftIO $
|
||||
partMulticast subscribers (UDP.listenSocket sock) (listenerHostAddr4 sock) `finally` UDP.stop sock
|
||||
|
||||
joinMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO ()
|
||||
joinMulticast subscribers sock group = do
|
||||
@@ -195,10 +195,19 @@ listenerHostAddr4 sock = case UDP.mySockAddr sock of
|
||||
N.SockAddrInet _port host -> host
|
||||
_ -> error "MULTICAST_ADDR_V4 is V4"
|
||||
|
||||
recvAnnounce :: (MonadIO m) => UDP.ListenSocket -> m (N.SockAddr, ByteString)
|
||||
recvAnnounce :: MonadIO m => UDP.ListenSocket -> m (N.SockAddr, ByteString)
|
||||
recvAnnounce sock = liftIO $ do
|
||||
(invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock
|
||||
pure (source, invite)
|
||||
|
||||
connectTLSClient :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (Transport.TLS -> m a) -> m a
|
||||
connectTLSClient (host, port) caFingerprint = runTransportClient defaultTransportClientConfig Nothing host (show port) (Just caFingerprint)
|
||||
connectTLSClient ::
|
||||
MonadUnliftIO m =>
|
||||
(TransportHost, Word16) ->
|
||||
HostSessionKeys ->
|
||||
(HostCryptoHandle -> Transport.TLS -> m a) ->
|
||||
m a
|
||||
connectTLSClient (host, port) HostSessionKeys {ca} client =
|
||||
runTransportClient defaultTransportClientConfig Nothing host (show port) (Just ca) $ \tls -> do
|
||||
-- TODO: set up host side using
|
||||
let hch = HostCryptoHandle
|
||||
client hch tls
|
||||
|
||||
176
src/Simplex/RemoteControl/Invitation.hs
Normal file
176
src/Simplex/RemoteControl/Invitation.hs
Normal file
@@ -0,0 +1,176 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.RemoteControl.Invitation where
|
||||
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.TH as JQ
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Time.Clock.System (SystemTime)
|
||||
import Data.Word (Word16)
|
||||
import Network.HTTP.Types (parseSimpleQuery)
|
||||
import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery, urlDecode)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, parseAll)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Version (VersionRange)
|
||||
|
||||
data RCInvitation = RCInvitation
|
||||
{ -- | CA TLS certificate fingerprint of the controller.
|
||||
--
|
||||
-- This is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements.
|
||||
ca :: C.KeyHash,
|
||||
host :: TransportHost,
|
||||
port :: Word16,
|
||||
-- | Supported version range for remote control protocol
|
||||
v :: VersionRange,
|
||||
-- | Application information
|
||||
app :: J.Value,
|
||||
-- | Session start time in seconds since epoch
|
||||
ts :: SystemTime,
|
||||
-- | Session Ed25519 public key used to verify the announcement and commands
|
||||
--
|
||||
-- This mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first.
|
||||
skey :: C.PublicKeyEd25519,
|
||||
-- | Long-term Ed25519 public key used to verify the announcement and commands.
|
||||
--
|
||||
-- Is apart of the long term controller identity.
|
||||
idkey :: C.PublicKeyEd25519,
|
||||
-- | Session X25519 DH key
|
||||
dh :: C.PublicKeyX25519
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance StrEncoding RCInvitation where
|
||||
strEncode RCInvitation {ca, host, port, v, app, ts, skey, idkey, dh} =
|
||||
mconcat
|
||||
[ "xrcp:/",
|
||||
strEncode ca,
|
||||
"@",
|
||||
strEncode host,
|
||||
":",
|
||||
strEncode port,
|
||||
"#/?",
|
||||
renderSimpleQuery False query
|
||||
]
|
||||
where
|
||||
query =
|
||||
[ ("v", strEncode v),
|
||||
("app", LB.toStrict $ J.encode app),
|
||||
("ts", strEncode ts),
|
||||
("skey", strEncode skey),
|
||||
("idkey", strEncode idkey),
|
||||
("dh", strEncode dh)
|
||||
]
|
||||
|
||||
strP = do
|
||||
_ <- A.string "xrcp:/"
|
||||
ca <- strP
|
||||
_ <- A.char '@'
|
||||
host <- A.takeWhile (/= ':') >>= either fail pure . strDecode . urlDecode True
|
||||
_ <- A.char ':'
|
||||
port <- strP
|
||||
_ <- A.string "#/?"
|
||||
|
||||
q <- parseSimpleQuery <$> A.takeWhile (/= ' ')
|
||||
v <- requiredP q "v" strDecode
|
||||
app <- requiredP q "app" $ J.eitherDecodeStrict . urlDecode True
|
||||
ts <- requiredP q "ts" $ strDecode . urlDecode True
|
||||
skey <- requiredP q "skey" $ parseAll strP
|
||||
idkey <- requiredP q "idkey" $ parseAll strP
|
||||
dh <- requiredP q "dh" $ parseAll strP
|
||||
pure RCInvitation {ca, host, port, v, app, ts, skey, idkey, dh}
|
||||
|
||||
data RCSignedInvitation = RCSignedInvitation
|
||||
{ invitation :: RCInvitation,
|
||||
ssig :: C.Signature 'C.Ed25519,
|
||||
idsig :: C.Signature 'C.Ed25519
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | URL-encoded and signed for showing in QR code
|
||||
instance StrEncoding RCSignedInvitation where
|
||||
strEncode RCSignedInvitation {invitation, ssig, idsig} =
|
||||
mconcat
|
||||
[ strEncode invitation,
|
||||
"&ssig=",
|
||||
strEncode $ C.signatureBytes ssig,
|
||||
"&idsig=",
|
||||
strEncode $ C.signatureBytes idsig
|
||||
]
|
||||
|
||||
strP = do
|
||||
-- TODO this assumes some order or parameters, can be made independent
|
||||
(url, invitation) <- A.match strP
|
||||
sigs <- case B.breakSubstring "&ssig=" url of
|
||||
(_, sigs) | B.null sigs -> fail "missing signatures"
|
||||
(_, sigs) -> pure $ parseSimpleQuery $ B.drop 1 sigs
|
||||
ssig <- requiredP sigs "ssig" $ parseAll strP
|
||||
idsig <- requiredP sigs "idsig" $ parseAll strP
|
||||
pure RCSignedInvitation {invitation, ssig, idsig}
|
||||
|
||||
signInviteURL :: C.PrivateKey C.Ed25519 -> C.PrivateKey C.Ed25519 -> RCInvitation -> RCSignedInvitation
|
||||
signInviteURL sKey idKey invitation = RCSignedInvitation {invitation, ssig, idsig}
|
||||
where
|
||||
inviteUrl = strEncode invitation
|
||||
ssig =
|
||||
case C.sign (C.APrivateSignKey C.SEd25519 sKey) inviteUrl of
|
||||
C.ASignature C.SEd25519 s -> s
|
||||
_ -> error "signing with ed25519"
|
||||
inviteUrlSigned = mconcat [inviteUrl, "&ssig=", strEncode ssig]
|
||||
idsig =
|
||||
case C.sign (C.APrivateSignKey C.SEd25519 idKey) inviteUrlSigned of
|
||||
C.ASignature C.SEd25519 s -> s
|
||||
_ -> error "signing with ed25519"
|
||||
|
||||
verifySignedInviteURI :: RCSignedInvitation -> Bool
|
||||
verifySignedInviteURI RCSignedInvitation {invitation, ssig, idsig} =
|
||||
C.verify aSKey aSSig inviteURL && C.verify aIdKey aIdSig inviteURLS
|
||||
where
|
||||
RCInvitation {skey, idkey} = invitation
|
||||
inviteURL = strEncode invitation
|
||||
inviteURLS = mconcat [inviteURL, "&ssig=", strEncode ssig]
|
||||
aSKey = C.APublicVerifyKey C.SEd25519 skey
|
||||
aSSig = C.ASignature C.SEd25519 ssig
|
||||
aIdKey = C.APublicVerifyKey C.SEd25519 idkey
|
||||
aIdSig = C.ASignature C.SEd25519 idsig
|
||||
|
||||
instance Encoding RCSignedInvitation where
|
||||
smpEncode RCSignedInvitation {} = error "TODO: RCSignedInvitation.smpEncode"
|
||||
smpP = error "TODO: RCSignedInvitation.smpP"
|
||||
|
||||
verifySignedInvitationMulticast :: RCSignedInvitation -> Bool
|
||||
verifySignedInvitationMulticast RCSignedInvitation {invitation, ssig, idsig} = undefined
|
||||
|
||||
data RCEncInvitation = RCEncInvitation
|
||||
{ dhPubKey :: C.PublicKeyX25519,
|
||||
nonce :: C.CbNonce,
|
||||
encInvitation :: ByteString
|
||||
}
|
||||
|
||||
instance Encoding RCEncInvitation where
|
||||
smpEncode RCEncInvitation {dhPubKey, nonce, encInvitation} =
|
||||
smpEncode (dhPubKey, nonce, Tail encInvitation)
|
||||
smpP = do
|
||||
(dhPubKey, nonce, Tail encInvitation) <- smpP
|
||||
pure RCEncInvitation {dhPubKey, nonce, encInvitation}
|
||||
|
||||
-- * Utils
|
||||
|
||||
requiredP :: MonadFail m => SimpleQuery -> ByteString -> (ByteString -> Either String a) -> m a
|
||||
requiredP q k f = maybe (fail $ "missing " <> show k) (either fail pure . f) $ lookup k q
|
||||
|
||||
-- optionalP :: MonadFail m => SimpleQuery -> ByteString -> (ByteString -> Either String a) -> m (Maybe a)
|
||||
-- optionalP q k f = maybe (pure Nothing) (either fail (pure . Just) . f) $ lookup k q
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''RCInvitation)
|
||||
@@ -2,190 +2,140 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module Simplex.RemoteControl.Types where
|
||||
|
||||
import Control.Monad
|
||||
import Crypto.Error (eitherCryptoError)
|
||||
import qualified Crypto.PubKey.Ed25519 as Ed25519
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import qualified Data.Aeson.TH as J
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteArray (convert)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Foldable (toList)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8)
|
||||
import Data.Time.Clock.System (SystemTime)
|
||||
import Data.Word (Word16)
|
||||
import Network.HTTP.Types (parseSimpleQuery)
|
||||
import Network.HTTP.Types.URI (renderSimpleQuery, urlDecode, urlEncode)
|
||||
import qualified Network.Socket as N
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Time.Clock.System (SystemTime, getSystemTime)
|
||||
import qualified Network.TLS as TLS
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding (Encoding (..))
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings (KEMPublicKey, KEMSecretKey, sntrup761Keypair)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
||||
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
import Simplex.Messaging.Version (VersionRange, mkVersionRange)
|
||||
import UnliftIO
|
||||
|
||||
data RCErrorType
|
||||
= RCEInternal {internalErr :: String}
|
||||
| RCEIdentity
|
||||
| RCENoLocalAddress
|
||||
| RCETLSStartFailed
|
||||
| RCEException {exception :: String}
|
||||
| RCECtrlAuth
|
||||
| RCECtrlNotFound
|
||||
| RCECtrlError {ctrlErr :: String}
|
||||
| RCEVersion
|
||||
| RCEDecrypt
|
||||
| RCEBlockSize
|
||||
| RCESyntax {syntaxErr :: String}
|
||||
deriving (Eq, Show, Exception)
|
||||
|
||||
instance StrEncoding RCErrorType where
|
||||
strEncode = \case
|
||||
RCEInternal err -> "INTERNAL" <> text err
|
||||
RCEIdentity -> "IDENTITY"
|
||||
RCENoLocalAddress -> "NO_LOCAL_ADDR"
|
||||
RCETLSStartFailed -> "CTRL_TLS_START"
|
||||
RCEException err -> "EXCEPTION" <> text err
|
||||
RCECtrlAuth -> "CTRL_AUTH"
|
||||
RCECtrlNotFound -> "CTRL_NOT_FOUND"
|
||||
RCECtrlError err -> "CTRL_ERROR" <> text err
|
||||
RCEVersion -> "VERSION"
|
||||
RCEDecrypt -> "DECRYPT"
|
||||
RCEBlockSize -> "BLOCK_SIZE"
|
||||
RCESyntax err -> "SYNTAX" <> text err
|
||||
where
|
||||
text = (" " <>) . encodeUtf8 . T.pack
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"INTERNAL" -> RCEInternal <$> textP
|
||||
"IDENTITY" -> pure RCEIdentity
|
||||
"NO_LOCAL_ADDR" -> pure RCENoLocalAddress
|
||||
"CTRL_TLS_START" -> pure RCETLSStartFailed
|
||||
"EXCEPTION" -> RCEException <$> textP
|
||||
"CTRL_AUTH" -> pure RCECtrlAuth
|
||||
"CTRL_NOT_FOUND" -> pure RCECtrlNotFound
|
||||
"CTRL_ERROR" -> RCECtrlError <$> textP
|
||||
"VERSION" -> pure RCEVersion
|
||||
"DECRYPT" -> pure RCEDecrypt
|
||||
"BLOCK_SIZE" -> pure RCEBlockSize
|
||||
"SYNTAX" -> RCESyntax <$> textP
|
||||
_ -> fail "bad RCErrorType"
|
||||
where
|
||||
textP = T.unpack . safeDecodeUtf8 <$> (A.space *> A.takeByteString)
|
||||
|
||||
-- * Discovery
|
||||
|
||||
ipProbeVersionRange :: VersionRange
|
||||
ipProbeVersionRange = mkVersionRange 1 1
|
||||
|
||||
data IpProbe = IpProbe
|
||||
{ versionRange :: VersionRange,
|
||||
randomNonce :: ByteString
|
||||
} deriving (Show)
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Encoding IpProbe where
|
||||
smpEncode IpProbe {versionRange, randomNonce} = smpEncode (versionRange, 'I', randomNonce)
|
||||
|
||||
smpP = IpProbe <$> (smpP <* "I") *> smpP
|
||||
|
||||
announceVersionRange :: VersionRange
|
||||
announceVersionRange = mkVersionRange 1 1
|
||||
-- * Controller
|
||||
|
||||
data Announce = Announce
|
||||
{ versionRange :: VersionRange,
|
||||
sessionStart :: SystemTime,
|
||||
announceCounter :: Word16,
|
||||
serviceAddress :: (N.HostAddress, Word16),
|
||||
caFingerprint :: C.KeyHash,
|
||||
sessionDH :: C.PublicKeyX25519,
|
||||
announceKey :: C.PublicKeyEd25519
|
||||
} deriving (Show)
|
||||
|
||||
instance Encoding Announce where
|
||||
smpEncode Announce {versionRange, sessionStart, announceCounter, serviceAddress, caFingerprint, sessionDH, announceKey} =
|
||||
smpEncode (versionRange, 'A', sessionStart, announceCounter, serviceAddress)
|
||||
<> smpEncode (caFingerprint, sessionDH, announceKey)
|
||||
|
||||
smpP = Announce <$> (smpP <* "A") <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
|
||||
|
||||
data SignedAnnounce = SignedAnnounce Announce (C.Signature 'C.Ed25519)
|
||||
|
||||
instance Encoding SignedAnnounce where
|
||||
smpEncode (SignedAnnounce ann (C.SignatureEd25519 sig)) = smpEncode (ann, convert sig :: ByteString)
|
||||
|
||||
smpP = do
|
||||
sa <- SignedAnnounce <$> smpP <*> signatureP
|
||||
unless (verifySignedAnnounce sa) $ fail "bad announce signature"
|
||||
pure sa
|
||||
where
|
||||
signatureP = do
|
||||
bs <- smpP :: A.Parser ByteString
|
||||
case eitherCryptoError (Ed25519.signature bs) of
|
||||
Left ce -> fail $ show ce
|
||||
Right ok -> pure $ C.SignatureEd25519 ok
|
||||
|
||||
signAnnounce :: C.PrivateKey C.Ed25519 -> Announce -> SignedAnnounce
|
||||
signAnnounce announceSecret ann = SignedAnnounce ann sig
|
||||
where
|
||||
sig =
|
||||
case C.sign (C.APrivateSignKey C.SEd25519 announceSecret) (smpEncode ann) of
|
||||
C.ASignature C.SEd25519 s -> s
|
||||
_ -> error "signing with ed25519"
|
||||
|
||||
verifySignedAnnounce :: SignedAnnounce -> Bool
|
||||
verifySignedAnnounce (SignedAnnounce ann@Announce {announceKey} sig) = C.verify aKey aSig (smpEncode ann)
|
||||
where
|
||||
aKey = C.APublicVerifyKey C.SEd25519 announceKey
|
||||
aSig = C.ASignature C.SEd25519 sig
|
||||
|
||||
data OOB = OOB
|
||||
{ -- authority part
|
||||
caFingerprint :: C.KeyHash,
|
||||
authToken :: Text,
|
||||
host :: Text,
|
||||
port :: Word16,
|
||||
-- query part
|
||||
version :: VersionRange, -- v=
|
||||
appName :: Text, -- app=
|
||||
sigPubKey :: C.PublicKeyEd25519, -- key=
|
||||
deviceName :: Maybe Text -- device=
|
||||
-- | A bunch of keys that should be generated by a controller to start a new remote session and produce invites
|
||||
data CtrlSessionKeys = CtrlSessionKeys
|
||||
{ ts :: SystemTime,
|
||||
ca :: C.KeyHash,
|
||||
credentials :: TLS.Credentials,
|
||||
sSigKey :: C.PrivateKeyEd25519,
|
||||
dhKey :: C.PrivateKeyX25519,
|
||||
kem :: (KEMPublicKey, KEMSecretKey)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance StrEncoding OOB where
|
||||
strEncode OOB {caFingerprint, authToken, host, port, version, appName, sigPubKey, deviceName} =
|
||||
schema <> "://" <> authority <> "#/?" <> renderSimpleQuery False query
|
||||
where
|
||||
schema = "xrcp"
|
||||
authority =
|
||||
mconcat
|
||||
[ strEncode caFingerprint,
|
||||
":",
|
||||
encodeUtf8 authToken,
|
||||
"@",
|
||||
encodeUtf8 host,
|
||||
":",
|
||||
strEncode port
|
||||
]
|
||||
query =
|
||||
[ ("v", strEncode version),
|
||||
("app", encodeUtf8 appName),
|
||||
("key", strEncode $ C.encodePubKey sigPubKey)
|
||||
]
|
||||
++ [("device", urlEncode True $ encodeUtf8 name) | name <- toList deviceName]
|
||||
newCtrlSessionKeys :: TVar ChaChaDRG -> (C.APrivateSignKey, C.SignedCertificate) -> IO CtrlSessionKeys
|
||||
newCtrlSessionKeys rng (caKey, caCert) = do
|
||||
ts <- getSystemTime
|
||||
(_, C.APrivateDhKey C.SX25519 dhKey) <- C.generateDhKeyPair C.SX25519
|
||||
(_, C.APrivateSignKey C.SEd25519 sSigKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||
|
||||
strP = do
|
||||
_ <- A.string "xrcp://"
|
||||
caFingerprint <- strP
|
||||
_ <- A.char ':'
|
||||
authToken <- decodeUtf8Lenient <$> A.takeWhile (/= '@')
|
||||
_ <- A.char '@'
|
||||
host <- decodeUtf8Lenient <$> A.takeWhile (/= ':')
|
||||
_ <- A.char ':'
|
||||
port <- strP
|
||||
let parent = (C.signatureKeyPair caKey, caCert)
|
||||
sessionCreds <- genCredentials (Just parent) (0, 24) "Session"
|
||||
let (ca, credentials) = tlsCredentials $ sessionCreds :| [parent]
|
||||
kem <- sntrup761Keypair rng
|
||||
|
||||
_ <- A.string "#/?"
|
||||
q <- parseSimpleQuery <$> A.takeByteString
|
||||
version <- maybe (fail "missing version") (either fail pure . strDecode) (lookup "v" q)
|
||||
appName <- maybe (fail "missing appName") (pure . decodeUtf8Lenient) (lookup "app" q)
|
||||
sigPubKeyB64 <- maybe (fail "missing key") pure (lookup "key" q)
|
||||
sigPubKey <- either fail pure $ strDecode sigPubKeyB64 >>= C.decodePubKey
|
||||
let deviceName = fmap (decodeUtf8Lenient . urlDecode True) (lookup "device" q)
|
||||
pure OOB {caFingerprint, authToken, host, port, version, appName, sigPubKey, deviceName}
|
||||
pure CtrlSessionKeys {ts, ca, credentials, sSigKey, dhKey, kem}
|
||||
|
||||
data SignedOOB = SignedOOB OOB (C.Signature 'C.Ed25519)
|
||||
deriving (Eq, Show)
|
||||
data CtrlCryptoHandle = CtrlCryptoHandle
|
||||
|
||||
instance StrEncoding SignedOOB where
|
||||
strEncode (SignedOOB oob sig) = strEncode oob <> "&sig=" <> strEncode (C.signatureBytes sig)
|
||||
-- TODO
|
||||
|
||||
strDecode s = do
|
||||
unless (B.length sig == sigLen) $ Left "bad size"
|
||||
unless ("&sig=" `B.isPrefixOf` sig) $ Left "bad signature prefix"
|
||||
signedOOB <- SignedOOB <$> strDecode oob <*> (strDecode (B.drop 5 sig) >>= C.decodeSignature)
|
||||
unless (verifySignedOOB signedOOB) $ Left "bad signature"
|
||||
pure signedOOB
|
||||
where
|
||||
l = B.length s
|
||||
(oob, sig) = B.splitAt (l - sigLen) s
|
||||
sigLen = 93 -- &sig= + ed25519 sig size in base64 (88)
|
||||
-- * Host
|
||||
|
||||
-- XXX: strP is used in chat command parser, but default strP assumes bas64url-encoded bytestring, where OOB is an URL-like
|
||||
strP = A.takeWhile (/= ' ') >>= either fail pure . strDecode
|
||||
data HostSessionKeys = HostSessionKeys
|
||||
{ ca :: C.KeyHash
|
||||
-- TODO
|
||||
}
|
||||
|
||||
signOOB :: C.PrivateKey C.Ed25519 -> OOB -> SignedOOB
|
||||
signOOB key oob = SignedOOB oob sig
|
||||
where
|
||||
sig =
|
||||
case C.sign (C.APrivateSignKey C.SEd25519 key) (strEncode oob) of
|
||||
C.ASignature C.SEd25519 s -> s
|
||||
_ -> error "signing with ed25519"
|
||||
data HostCryptoHandle = HostCryptoHandle
|
||||
|
||||
verifySignedOOB :: SignedOOB -> Bool
|
||||
verifySignedOOB (SignedOOB oob@OOB {sigPubKey} sig) = C.verify aKey aSig (strEncode oob)
|
||||
where
|
||||
aKey = C.APublicVerifyKey C.SEd25519 sigPubKey
|
||||
aSig = C.ASignature C.SEd25519 sig
|
||||
-- TODO
|
||||
|
||||
decodeOOBLink :: Text -> Either String OOB
|
||||
decodeOOBLink = fmap (\(SignedOOB oob _verified) -> oob) . strDecode . encodeUtf8
|
||||
-- * Utils
|
||||
|
||||
-- XXX: Move to utils?
|
||||
type Tasks = TVar [Async ()]
|
||||
|
||||
asyncRegistered :: MonadUnliftIO m => Tasks -> m () -> m ()
|
||||
@@ -194,5 +144,7 @@ asyncRegistered tasks action = async action >>= registerAsync tasks
|
||||
registerAsync :: MonadIO m => Tasks -> Async () -> m ()
|
||||
registerAsync tasks = atomically . modifyTVar tasks . (:)
|
||||
|
||||
cancelTasks :: (MonadIO m) => Tasks -> m ()
|
||||
cancelTasks :: MonadIO m => Tasks -> m ()
|
||||
cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel
|
||||
|
||||
$(J.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RCErrorType)
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module CoreTests.ProtocolErrorTests where
|
||||
@@ -17,6 +18,7 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (CommandError (..), ErrorType (..))
|
||||
import Simplex.Messaging.Transport (HandshakeError (..), TransportError (..))
|
||||
import Simplex.RemoteControl.Types (RCErrorType (..))
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck (modifyMaxSuccess)
|
||||
import Test.QuickCheck
|
||||
@@ -58,6 +60,8 @@ deriving instance Generic HandshakeError
|
||||
|
||||
deriving instance Generic XFTPErrorType
|
||||
|
||||
deriving instance Generic RCErrorType
|
||||
|
||||
instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary CommandErrorType where arbitrary = genericArbitraryU
|
||||
@@ -79,3 +83,5 @@ instance Arbitrary TransportError where arbitrary = genericArbitraryU
|
||||
instance Arbitrary HandshakeError where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary XFTPErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary RCErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
66
tests/RemoteControl.hs
Normal file
66
tests/RemoteControl.hs
Normal file
@@ -0,0 +1,66 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module RemoteControl where
|
||||
|
||||
import AgentTests.FunctionalAPITests (runRight_)
|
||||
import Control.Logger.Simple
|
||||
import Crypto.Random (drgNew)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Simplex.RemoteControl.Client as RC
|
||||
import Test.Hspec
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent
|
||||
|
||||
remoteControlTests :: Spec
|
||||
remoteControlTests = do
|
||||
describe "New controller/host pairing" $ do
|
||||
it "should connect" testNewPairing
|
||||
|
||||
testNewPairing :: IO ()
|
||||
testNewPairing = do
|
||||
drg <- drgNew >>= newTVarIO
|
||||
hp <- RC.newRCHostPairing
|
||||
invVar <- newEmptyMVar
|
||||
ctrl <- async . runRight_ $ do
|
||||
logNote "c 1"
|
||||
(inv, hc, r) <- RC.connectRCHost drg hp (J.String "app")
|
||||
logNote "c 2"
|
||||
putMVar invVar (inv, hc)
|
||||
logNote "c 3"
|
||||
Right (_sessId, r') <- atomically $ takeTMVar r
|
||||
logNote "c 4"
|
||||
Right (_rcHostSession, _rcHelloBody, _hp') <- atomically $ takeTMVar r'
|
||||
logNote "c 5"
|
||||
threadDelay 1000000
|
||||
logNote "ctrl: ciao"
|
||||
liftIO $ RC.cancelHostClient hc
|
||||
|
||||
(inv, hc) <- takeMVar invVar
|
||||
-- logNote $ decodeUtf8 $ strEncode inv
|
||||
|
||||
host <- async . runRight_ $ do
|
||||
logNote "h 1"
|
||||
(rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv Nothing (J.String "app")
|
||||
logNote "h 2"
|
||||
Right (_sessId', r') <- atomically $ takeTMVar r
|
||||
logNote "h 3"
|
||||
liftIO $ RC.confirmCtrlSession rcCtrlClient True
|
||||
logNote "h 4"
|
||||
Right (_rcCtrlSession, _rcCtrlPairing) <- atomically $ takeTMVar r'
|
||||
logNote "h 5"
|
||||
threadDelay 1000000
|
||||
logNote "ctrl: adios"
|
||||
|
||||
timeout 10000000 (waitCatch ctrl) >>= \case
|
||||
Just (Right ()) -> pure ()
|
||||
err -> fail $ "Unexpected controller result: " <> show err
|
||||
|
||||
waitCatch hc.action >>= \case
|
||||
Left err -> fromException err `shouldBe` Just AsyncCancelled
|
||||
Right () -> fail "Unexpected controller finish"
|
||||
|
||||
timeout 10000000 (waitCatch host) >>= \case
|
||||
Just (Right ()) -> pure ()
|
||||
err -> fail $ "Unexpected host result: " <> show err
|
||||
@@ -14,6 +14,7 @@ import CoreTests.UtilTests
|
||||
import CoreTests.VersionRangeTests
|
||||
import FileDescriptionTests (fileDescriptionTests)
|
||||
import NtfServerTests (ntfServerTests)
|
||||
import RemoteControl (remoteControlTests)
|
||||
import ServerTests
|
||||
import Simplex.Messaging.Transport (TLS, Transport (..))
|
||||
import Simplex.Messaging.Transport.WebSockets (WS)
|
||||
@@ -56,4 +57,5 @@ main = do
|
||||
describe "XFTP file description" fileDescriptionTests
|
||||
describe "XFTP CLI" xftpCLITests
|
||||
describe "XFTP agent" xftpAgentTests
|
||||
describe "XRCP" remoteControlTests
|
||||
describe "Server CLIs" cliTests
|
||||
|
||||
Reference in New Issue
Block a user