diff --git a/cbits/README.md b/cbits/README.md new file mode 100644 index 000000000..88e72d008 --- /dev/null +++ b/cbits/README.md @@ -0,0 +1,3 @@ +# Streamlined NTRU Prime: sntrup761 + +The implementation of sntrup761 is the _exact_ copy from this [Internet draft](https://www.ietf.org/archive/id/draft-josefsson-ntruprime-streamlined-00.html). diff --git a/cbits/sha512.c b/cbits/sha512.c new file mode 100644 index 000000000..54b838674 --- /dev/null +++ b/cbits/sha512.c @@ -0,0 +1,9 @@ +#include +#include "sha512.h" + +void crypto_hash_sha512 (unsigned char *out, + const unsigned char *in, + unsigned long long inlen) +{ + SHA512(in, inlen, out); +} diff --git a/cbits/sha512.h b/cbits/sha512.h new file mode 100644 index 000000000..af16f5888 --- /dev/null +++ b/cbits/sha512.h @@ -0,0 +1,3 @@ +void crypto_hash_sha512 (unsigned char *out, + const unsigned char *in, + unsigned long long inlen); diff --git a/cbits/sntrup761.c b/cbits/sntrup761.c new file mode 100644 index 000000000..7d64eeb08 --- /dev/null +++ b/cbits/sntrup761.c @@ -0,0 +1,1035 @@ +/* + * Derived from public domain source, written by (in alphabetical order): + * - Daniel J. Bernstein + * - Chitchanok Chuengsatiansup + * - Tanja Lange + * - Christine van Vredendaal + */ + +#include "sntrup761.h" + +#include "sha512.h" + +/* from supercop-20201130/crypto_sort/int32/portable4/int32_minmax.inc */ +#define int32_MINMAX(a,b) \ +do { \ + int64_t ab = (int64_t)b ^ (int64_t)a; \ + int64_t c = (int64_t)b - (int64_t)a; \ + c ^= ab & (c ^ b); \ + c >>= 31; \ + c &= ab; \ + a ^= c; \ + b ^= c; \ +} while(0) + +/* from supercop-20201130/crypto_sort/int32/portable4/sort.c */ +static void +crypto_sort_int32 (void *array, long long n) +{ + long long top, p, q, r, i, j; + int32_t *x = array; + + if (n < 2) + return; + top = 1; + while (top < n - top) + top += top; + + for (p = top; p >= 1; p >>= 1) + { + i = 0; + while (i + 2 * p <= n) + { + for (j = i; j < i + p; ++j) + int32_MINMAX (x[j], x[j + p]); + i += 2 * p; + } + for (j = i; j < n - p; ++j) + int32_MINMAX (x[j], x[j + p]); + + i = 0; + j = 0; + for (q = top; q > p; q >>= 1) + { + if (j != i) + for (;;) + { + if (j == n - q) + goto done; + int32_t a = x[j + p]; + for (r = q; r > p; r >>= 1) + int32_MINMAX (a, x[j + r]); + x[j + p] = a; + ++j; + if (j == i + p) + { + i += 2 * p; + break; + } + } + while (i + p <= n - q) + { + for (j = i; j < i + p; ++j) + { + int32_t a = x[j + p]; + for (r = q; r > p; r >>= 1) + int32_MINMAX (a, x[j + r]); + x[j + p] = a; + } + i += 2 * p; + } + /* now i + p > n - q */ + j = i; + while (j < n - q) + { + int32_t a = x[j + p]; + for (r = q; r > p; r >>= 1) + int32_MINMAX (a, x[j + r]); + x[j + p] = a; + ++j; + } + + done:; + } + } +} + +/* from supercop-20201130/crypto_sort/uint32/useint32/sort.c */ + +/* can save time by vectorizing xor loops */ +/* can save time by integrating xor loops with int32_sort */ + +static void +crypto_sort_uint32 (void *array, long long n) +{ + uint32_t *x = array; + long long j; + for (j = 0; j < n; ++j) + x[j] ^= 0x80000000; + crypto_sort_int32 (array, n); + for (j = 0; j < n; ++j) + x[j] ^= 0x80000000; +} + +/* from supercop-20201130/crypto_kem/sntrup761/ref/uint32.c */ + +/* +CPU division instruction typically takes time depending on x. +This software is designed to take time independent of x. +Time still varies depending on m; user must ensure that m is constant. +Time also varies on CPUs where multiplication is variable-time. +There could be more CPU issues. +There could also be compiler issues. +*/ + +static void +uint32_divmod_uint14 (uint32_t * q, uint16_t * r, uint32_t x, uint16_t m) +{ + uint32_t v = 0x80000000; + uint32_t qpart; + uint32_t mask; + + v /= m; + + /* caller guarantees m > 0 */ + /* caller guarantees m < 16384 */ + /* vm <= 2^31 <= vm+m-1 */ + /* xvm <= 2^31 x <= xvm+x(m-1) */ + + *q = 0; + + qpart = (x * (uint64_t) v) >> 31; + /* 2^31 qpart <= xv <= 2^31 qpart + 2^31-1 */ + /* 2^31 qpart m <= xvm <= 2^31 qpart m + (2^31-1)m */ + /* 2^31 qpart m <= 2^31 x <= 2^31 qpart m + (2^31-1)m + x(m-1) */ + /* 0 <= 2^31 newx <= (2^31-1)m + x(m-1) */ + /* 0 <= newx <= (1-1/2^31)m + x(m-1)/2^31 */ + /* 0 <= newx <= (1-1/2^31)(2^14-1) + (2^32-1)((2^14-1)-1)/2^31 */ + + x -= qpart * m; + *q += qpart; + /* x <= 49146 */ + + qpart = (x * (uint64_t) v) >> 31; + /* 0 <= newx <= (1-1/2^31)m + x(m-1)/2^31 */ + /* 0 <= newx <= m + 49146(2^14-1)/2^31 */ + /* 0 <= newx <= m + 0.4 */ + /* 0 <= newx <= m */ + + x -= qpart * m; + *q += qpart; + /* x <= m */ + + x -= m; + *q += 1; + mask = -(x >> 31); + x += mask & (uint32_t) m; + *q += mask; + /* x < m */ + + *r = x; +} + + +static uint16_t +uint32_mod_uint14 (uint32_t x, uint16_t m) +{ + uint32_t q; + uint16_t r; + uint32_divmod_uint14 (&q, &r, x, m); + return r; +} + +/* from supercop-20201130/crypto_kem/sntrup761/ref/int32.c */ + +static void +int32_divmod_uint14 (int32_t * q, uint16_t * r, int32_t x, uint16_t m) +{ + uint32_t uq, uq2; + uint16_t ur, ur2; + uint32_t mask; + + uint32_divmod_uint14 (&uq, &ur, 0x80000000 + (uint32_t) x, m); + uint32_divmod_uint14 (&uq2, &ur2, 0x80000000, m); + ur -= ur2; + uq -= uq2; + mask = -(uint32_t) (ur >> 15); + ur += mask & m; + uq += mask; + *r = ur; + *q = uq; +} + + +static uint16_t +int32_mod_uint14 (int32_t x, uint16_t m) +{ + int32_t q; + uint16_t r; + int32_divmod_uint14 (&q, &r, x, m); + return r; +} + +/* from supercop-20201130/crypto_kem/sntrup761/ref/paramsmenu.h */ +#define p 761 +#define q 4591 +#define Rounded_bytes 1007 +#define Rq_bytes 1158 +#define w 286 + +/* from supercop-20201130/crypto_kem/sntrup761/ref/Decode.h */ + +/* Decode(R,s,M,len) */ +/* assumes 0 < M[i] < 16384 */ +/* produces 0 <= R[i] < M[i] */ + +/* from supercop-20201130/crypto_kem/sntrup761/ref/Decode.c */ + +static void +Decode (uint16_t * out, const unsigned char *S, const uint16_t * M, + long long len) +{ + if (len == 1) + { + if (M[0] == 1) + *out = 0; + else if (M[0] <= 256) + *out = uint32_mod_uint14 (S[0], M[0]); + else + *out = uint32_mod_uint14 (S[0] + (((uint16_t) S[1]) << 8), M[0]); + } + if (len > 1) + { + uint16_t R2[(len + 1) / 2]; + uint16_t M2[(len + 1) / 2]; + uint16_t bottomr[len / 2]; + uint32_t bottomt[len / 2]; + long long i; + for (i = 0; i < len - 1; i += 2) + { + uint32_t m = M[i] * (uint32_t) M[i + 1]; + if (m > 256 * 16383) + { + bottomt[i / 2] = 256 * 256; + bottomr[i / 2] = S[0] + 256 * S[1]; + S += 2; + M2[i / 2] = (((m + 255) >> 8) + 255) >> 8; + } + else if (m >= 16384) + { + bottomt[i / 2] = 256; + bottomr[i / 2] = S[0]; + S += 1; + M2[i / 2] = (m + 255) >> 8; + } + else + { + bottomt[i / 2] = 1; + bottomr[i / 2] = 0; + M2[i / 2] = m; + } + } + if (i < len) + M2[i / 2] = M[i]; + Decode (R2, S, M2, (len + 1) / 2); + for (i = 0; i < len - 1; i += 2) + { + uint32_t r = bottomr[i / 2]; + uint32_t r1; + uint16_t r0; + r += bottomt[i / 2] * R2[i / 2]; + uint32_divmod_uint14 (&r1, &r0, r, M[i]); + r1 = uint32_mod_uint14 (r1, M[i + 1]); /* only needed for invalid inputs */ + *out++ = r0; + *out++ = r1; + } + if (i < len) + *out++ = R2[i / 2]; + } +} + +/* from supercop-20201130/crypto_kem/sntrup761/ref/Encode.h */ + +/* Encode(s,R,M,len) */ +/* assumes 0 <= R[i] < M[i] < 16384 */ + +/* from supercop-20201130/crypto_kem/sntrup761/ref/Encode.c */ + +/* 0 <= R[i] < M[i] < 16384 */ +static void +Encode (unsigned char *out, const uint16_t * R, const uint16_t * M, + long long len) +{ + if (len == 1) + { + uint16_t r = R[0]; + uint16_t m = M[0]; + while (m > 1) + { + *out++ = r; + r >>= 8; + m = (m + 255) >> 8; + } + } + if (len > 1) + { + uint16_t R2[(len + 1) / 2]; + uint16_t M2[(len + 1) / 2]; + long long i; + for (i = 0; i < len - 1; i += 2) + { + uint32_t m0 = M[i]; + uint32_t r = R[i] + R[i + 1] * m0; + uint32_t m = M[i + 1] * m0; + while (m >= 16384) + { + *out++ = r; + r >>= 8; + m = (m + 255) >> 8; + } + R2[i / 2] = r; + M2[i / 2] = m; + } + if (i < len) + { + R2[i / 2] = R[i]; + M2[i / 2] = M[i]; + } + Encode (out, R2, M2, (len + 1) / 2); + } +} + +/* from supercop-20201130/crypto_kem/sntrup761/ref/kem.c */ + +/* ----- masks */ + +/* return -1 if x!=0; else return 0 */ +static int +int16_t_nonzero_mask (int16_t x) +{ + uint16_t u = x; /* 0, else 1...65535 */ + uint32_t v = u; /* 0, else 1...65535 */ + v = -v; /* 0, else 2^32-65535...2^32-1 */ + v >>= 31; /* 0, else 1 */ + return -v; /* 0, else -1 */ +} + +/* return -1 if x<0; otherwise return 0 */ +static int +int16_t_negative_mask (int16_t x) +{ + uint16_t u = x; + u >>= 15; + return -(int) u; + /* alternative with gcc -fwrapv: */ + /* x>>15 compiles to CPU's arithmetic right shift */ +} + +/* ----- arithmetic mod 3 */ + +typedef int8_t small; + +/* F3 is always represented as -1,0,1 */ +/* so ZZ_fromF3 is a no-op */ + +/* x must not be close to top int16_t */ +static small +F3_freeze (int16_t x) +{ + return int32_mod_uint14 (x + 1, 3) - 1; +} + +/* ----- arithmetic mod q */ + +#define q12 ((q-1)/2) +typedef int16_t Fq; +/* always represented as -q12...q12 */ +/* so ZZ_fromFq is a no-op */ + +/* x must not be close to top int32 */ +static Fq +Fq_freeze (int32_t x) +{ + return int32_mod_uint14 (x + q12, q) - q12; +} + +static Fq +Fq_recip (Fq a1) +{ + int i = 1; + Fq ai = a1; + + while (i < q - 2) + { + ai = Fq_freeze (a1 * (int32_t) ai); + i += 1; + } + return ai; +} + +/* ----- small polynomials */ + +/* 0 if Weightw_is(r), else -1 */ +static int +Weightw_mask (small * r) +{ + int weight = 0; + int i; + + for (i = 0; i < p; ++i) + weight += r[i] & 1; + return int16_t_nonzero_mask (weight - w); +} + +/* R3_fromR(R_fromRq(r)) */ +static void +R3_fromRq (small * out, const Fq * r) +{ + int i; + for (i = 0; i < p; ++i) + out[i] = F3_freeze (r[i]); +} + +/* h = f*g in the ring R3 */ +static void +R3_mult (small * h, const small * f, const small * g) +{ + small fg[p + p - 1]; + small result; + int i, j; + + for (i = 0; i < p; ++i) + { + result = 0; + for (j = 0; j <= i; ++j) + result = F3_freeze (result + f[j] * g[i - j]); + fg[i] = result; + } + for (i = p; i < p + p - 1; ++i) + { + result = 0; + for (j = i - p + 1; j < p; ++j) + result = F3_freeze (result + f[j] * g[i - j]); + fg[i] = result; + } + + for (i = p + p - 2; i >= p; --i) + { + fg[i - p] = F3_freeze (fg[i - p] + fg[i]); + fg[i - p + 1] = F3_freeze (fg[i - p + 1] + fg[i]); + } + + for (i = 0; i < p; ++i) + h[i] = fg[i]; +} + +/* returns 0 if recip succeeded; else -1 */ +static int +R3_recip (small * out, const small * in) +{ + small f[p + 1], g[p + 1], v[p + 1], r[p + 1]; + int i, loop, delta; + int sign, swap, t; + + for (i = 0; i < p + 1; ++i) + v[i] = 0; + for (i = 0; i < p + 1; ++i) + r[i] = 0; + r[0] = 1; + for (i = 0; i < p; ++i) + f[i] = 0; + f[0] = 1; + f[p - 1] = f[p] = -1; + for (i = 0; i < p; ++i) + g[p - 1 - i] = in[i]; + g[p] = 0; + + delta = 1; + + for (loop = 0; loop < 2 * p - 1; ++loop) + { + for (i = p; i > 0; --i) + v[i] = v[i - 1]; + v[0] = 0; + + sign = -g[0] * f[0]; + swap = int16_t_negative_mask (-delta) & int16_t_nonzero_mask (g[0]); + delta ^= swap & (delta ^ -delta); + delta += 1; + + for (i = 0; i < p + 1; ++i) + { + t = swap & (f[i] ^ g[i]); + f[i] ^= t; + g[i] ^= t; + t = swap & (v[i] ^ r[i]); + v[i] ^= t; + r[i] ^= t; + } + + for (i = 0; i < p + 1; ++i) + g[i] = F3_freeze (g[i] + sign * f[i]); + for (i = 0; i < p + 1; ++i) + r[i] = F3_freeze (r[i] + sign * v[i]); + + for (i = 0; i < p; ++i) + g[i] = g[i + 1]; + g[p] = 0; + } + + sign = f[0]; + for (i = 0; i < p; ++i) + out[i] = sign * v[p - 1 - i]; + + return int16_t_nonzero_mask (delta); +} + +/* ----- polynomials mod q */ + +/* h = f*g in the ring Rq */ +static void +Rq_mult_small (Fq * h, const Fq * f, const small * g) +{ + Fq fg[p + p - 1]; + Fq result; + int i, j; + + for (i = 0; i < p; ++i) + { + result = 0; + for (j = 0; j <= i; ++j) + result = Fq_freeze (result + f[j] * (int32_t) g[i - j]); + fg[i] = result; + } + for (i = p; i < p + p - 1; ++i) + { + result = 0; + for (j = i - p + 1; j < p; ++j) + result = Fq_freeze (result + f[j] * (int32_t) g[i - j]); + fg[i] = result; + } + + for (i = p + p - 2; i >= p; --i) + { + fg[i - p] = Fq_freeze (fg[i - p] + fg[i]); + fg[i - p + 1] = Fq_freeze (fg[i - p + 1] + fg[i]); + } + + for (i = 0; i < p; ++i) + h[i] = fg[i]; +} + +/* h = 3f in Rq */ +static void +Rq_mult3 (Fq * h, const Fq * f) +{ + int i; + + for (i = 0; i < p; ++i) + h[i] = Fq_freeze (3 * f[i]); +} + +/* out = 1/(3*in) in Rq */ +/* returns 0 if recip succeeded; else -1 */ +static int +Rq_recip3 (Fq * out, const small * in) +{ + Fq f[p + 1], g[p + 1], v[p + 1], r[p + 1]; + int i, loop, delta; + int swap, t; + int32_t f0, g0; + Fq scale; + + for (i = 0; i < p + 1; ++i) + v[i] = 0; + for (i = 0; i < p + 1; ++i) + r[i] = 0; + r[0] = Fq_recip (3); + for (i = 0; i < p; ++i) + f[i] = 0; + f[0] = 1; + f[p - 1] = f[p] = -1; + for (i = 0; i < p; ++i) + g[p - 1 - i] = in[i]; + g[p] = 0; + + delta = 1; + + for (loop = 0; loop < 2 * p - 1; ++loop) + { + for (i = p; i > 0; --i) + v[i] = v[i - 1]; + v[0] = 0; + + swap = int16_t_negative_mask (-delta) & int16_t_nonzero_mask (g[0]); + delta ^= swap & (delta ^ -delta); + delta += 1; + + for (i = 0; i < p + 1; ++i) + { + t = swap & (f[i] ^ g[i]); + f[i] ^= t; + g[i] ^= t; + t = swap & (v[i] ^ r[i]); + v[i] ^= t; + r[i] ^= t; + } + + f0 = f[0]; + g0 = g[0]; + for (i = 0; i < p + 1; ++i) + g[i] = Fq_freeze (f0 * g[i] - g0 * f[i]); + for (i = 0; i < p + 1; ++i) + r[i] = Fq_freeze (f0 * r[i] - g0 * v[i]); + + for (i = 0; i < p; ++i) + g[i] = g[i + 1]; + g[p] = 0; + } + + scale = Fq_recip (f[0]); + for (i = 0; i < p; ++i) + out[i] = Fq_freeze (scale * (int32_t) v[p - 1 - i]); + + return int16_t_nonzero_mask (delta); +} + +/* ----- rounded polynomials mod q */ + +static void +Round (Fq * out, const Fq * a) +{ + int i; + for (i = 0; i < p; ++i) + out[i] = a[i] - F3_freeze (a[i]); +} + +/* ----- sorting to generate short polynomial */ + +static void +Short_fromlist (small * out, const uint32_t * in) +{ + uint32_t L[p]; + int i; + + for (i = 0; i < w; ++i) + L[i] = in[i] & (uint32_t) - 2; + for (i = w; i < p; ++i) + L[i] = (in[i] & (uint32_t) - 3) | 1; + crypto_sort_uint32 (L, p); + for (i = 0; i < p; ++i) + out[i] = (L[i] & 3) - 1; +} + +/* ----- underlying hash function */ + +#define Hash_bytes 32 + +/* e.g., b = 0 means out = Hash0(in) */ +static void +Hash_prefix (unsigned char *out, int b, const unsigned char *in, int inlen) +{ + unsigned char x[inlen + 1]; + unsigned char h[64]; + int i; + + x[0] = b; + for (i = 0; i < inlen; ++i) + x[i + 1] = in[i]; + crypto_hash_sha512 (h, x, inlen + 1); + for (i = 0; i < 32; ++i) + out[i] = h[i]; +} + +/* ----- higher-level randomness */ + +static uint32_t +urandom32 (void *random_ctx, sntrup761_random_func * random) +{ + unsigned char c[4]; + uint32_t out[4]; + + random (random_ctx, 4, c); + out[0] = (uint32_t) c[0]; + out[1] = ((uint32_t) c[1]) << 8; + out[2] = ((uint32_t) c[2]) << 16; + out[3] = ((uint32_t) c[3]) << 24; + return out[0] + out[1] + out[2] + out[3]; +} + +static void +Short_random (small * out, void *random_ctx, sntrup761_random_func * random) +{ + uint32_t L[p]; + int i; + + for (i = 0; i < p; ++i) + L[i] = urandom32 (random_ctx, random); + Short_fromlist (out, L); +} + +static void +Small_random (small * out, void *random_ctx, sntrup761_random_func * random) +{ + int i; + + for (i = 0; i < p; ++i) + out[i] = (((urandom32 (random_ctx, random) & 0x3fffffff) * 3) >> 30) - 1; +} + +/* ----- Streamlined NTRU Prime Core */ + +/* h,(f,ginv) = KeyGen() */ +static void +KeyGen (Fq * h, small * f, small * ginv, void *random_ctx, + sntrup761_random_func * random) +{ + small g[p]; + Fq finv[p]; + + for (;;) + { + Small_random (g, random_ctx, random); + if (R3_recip (ginv, g) == 0) + break; + } + Short_random (f, random_ctx, random); + Rq_recip3 (finv, f); /* always works */ + Rq_mult_small (h, finv, g); +} + +/* c = Encrypt(r,h) */ +static void +Encrypt (Fq * c, const small * r, const Fq * h) +{ + Fq hr[p]; + + Rq_mult_small (hr, h, r); + Round (c, hr); +} + +/* r = Decrypt(c,(f,ginv)) */ +static void +Decrypt (small * r, const Fq * c, const small * f, const small * ginv) +{ + Fq cf[p]; + Fq cf3[p]; + small e[p]; + small ev[p]; + int mask; + int i; + + Rq_mult_small (cf, c, f); + Rq_mult3 (cf3, cf); + R3_fromRq (e, cf3); + R3_mult (ev, e, ginv); + + mask = Weightw_mask (ev); /* 0 if weight w, else -1 */ + for (i = 0; i < w; ++i) + r[i] = ((ev[i] ^ 1) & ~mask) ^ 1; + for (i = w; i < p; ++i) + r[i] = ev[i] & ~mask; +} + +/* ----- encoding small polynomials (including short polynomials) */ + +#define Small_bytes ((p+3)/4) + +/* these are the only functions that rely on p mod 4 = 1 */ + +static void +Small_encode (unsigned char *s, const small * f) +{ + small x; + int i; + + for (i = 0; i < p / 4; ++i) + { + x = *f++ + 1; + x += (*f++ + 1) << 2; + x += (*f++ + 1) << 4; + x += (*f++ + 1) << 6; + *s++ = x; + } + x = *f++ + 1; + *s++ = x; +} + +static void +Small_decode (small * f, const unsigned char *s) +{ + unsigned char x; + int i; + + for (i = 0; i < p / 4; ++i) + { + x = *s++; + *f++ = ((small) (x & 3)) - 1; + x >>= 2; + *f++ = ((small) (x & 3)) - 1; + x >>= 2; + *f++ = ((small) (x & 3)) - 1; + x >>= 2; + *f++ = ((small) (x & 3)) - 1; + } + x = *s++; + *f++ = ((small) (x & 3)) - 1; +} + +/* ----- encoding general polynomials */ + +static void +Rq_encode (unsigned char *s, const Fq * r) +{ + uint16_t R[p], M[p]; + int i; + + for (i = 0; i < p; ++i) + R[i] = r[i] + q12; + for (i = 0; i < p; ++i) + M[i] = q; + Encode (s, R, M, p); +} + +static void +Rq_decode (Fq * r, const unsigned char *s) +{ + uint16_t R[p], M[p]; + int i; + + for (i = 0; i < p; ++i) + M[i] = q; + Decode (R, s, M, p); + for (i = 0; i < p; ++i) + r[i] = ((Fq) R[i]) - q12; +} + +/* ----- encoding rounded polynomials */ + +static void +Rounded_encode (unsigned char *s, const Fq * r) +{ + uint16_t R[p], M[p]; + int i; + + for (i = 0; i < p; ++i) + R[i] = ((r[i] + q12) * 10923) >> 15; + for (i = 0; i < p; ++i) + M[i] = (q + 2) / 3; + Encode (s, R, M, p); +} + +static void +Rounded_decode (Fq * r, const unsigned char *s) +{ + uint16_t R[p], M[p]; + int i; + + for (i = 0; i < p; ++i) + M[i] = (q + 2) / 3; + Decode (R, s, M, p); + for (i = 0; i < p; ++i) + r[i] = R[i] * 3 - q12; +} + +/* ----- Streamlined NTRU Prime Core plus encoding */ + +typedef small Inputs[p]; /* passed by reference */ +#define Inputs_random Short_random +#define Inputs_encode Small_encode +#define Inputs_bytes Small_bytes + +#define Ciphertexts_bytes Rounded_bytes +#define SecretKeys_bytes (2*Small_bytes) +#define PublicKeys_bytes Rq_bytes + +/* pk,sk = ZKeyGen() */ +static void +ZKeyGen (unsigned char *pk, unsigned char *sk, void *random_ctx, + sntrup761_random_func * random) +{ + Fq h[p]; + small f[p], v[p]; + + KeyGen (h, f, v, random_ctx, random); + Rq_encode (pk, h); + Small_encode (sk, f); + sk += Small_bytes; + Small_encode (sk, v); +} + +/* C = ZEncrypt(r,pk) */ +static void +ZEncrypt (unsigned char *C, const Inputs r, const unsigned char *pk) +{ + Fq h[p]; + Fq c[p]; + Rq_decode (h, pk); + Encrypt (c, r, h); + Rounded_encode (C, c); +} + +/* r = ZDecrypt(C,sk) */ +static void +ZDecrypt (Inputs r, const unsigned char *C, const unsigned char *sk) +{ + small f[p], v[p]; + Fq c[p]; + + Small_decode (f, sk); + sk += Small_bytes; + Small_decode (v, sk); + Rounded_decode (c, C); + Decrypt (r, c, f, v); +} + +/* ----- confirmation hash */ + +#define Confirm_bytes 32 + +/* h = HashConfirm(r,pk,cache); cache is Hash4(pk) */ +static void +HashConfirm (unsigned char *h, const unsigned char *r, + /* const unsigned char *pk, */ const unsigned char *cache) +{ + unsigned char x[Hash_bytes * 2]; + int i; + + Hash_prefix (x, 3, r, Inputs_bytes); + for (i = 0; i < Hash_bytes; ++i) + x[Hash_bytes + i] = cache[i]; + Hash_prefix (h, 2, x, sizeof x); +} + +/* ----- session-key hash */ + +/* k = HashSession(b,y,z) */ +static void +HashSession (unsigned char *k, int b, const unsigned char *y, + const unsigned char *z) +{ + unsigned char x[Hash_bytes + Ciphertexts_bytes + Confirm_bytes]; + int i; + + Hash_prefix (x, 3, y, Inputs_bytes); + for (i = 0; i < Ciphertexts_bytes + Confirm_bytes; ++i) + x[Hash_bytes + i] = z[i]; + Hash_prefix (k, b, x, sizeof x); +} + +/* ----- Streamlined NTRU Prime */ + +/* pk,sk = KEM_KeyGen() */ +void +sntrup761_keypair (unsigned char *pk, unsigned char *sk, void *random_ctx, + sntrup761_random_func * random) +{ + int i; + + ZKeyGen (pk, sk, random_ctx, random); + sk += SecretKeys_bytes; + for (i = 0; i < PublicKeys_bytes; ++i) + *sk++ = pk[i]; + random (random_ctx, Inputs_bytes, sk); + sk += Inputs_bytes; + Hash_prefix (sk, 4, pk, PublicKeys_bytes); +} + +/* c,r_enc = Hide(r,pk,cache); cache is Hash4(pk) */ +static void +Hide (unsigned char *c, unsigned char *r_enc, const Inputs r, + const unsigned char *pk, const unsigned char *cache) +{ + Inputs_encode (r_enc, r); + ZEncrypt (c, r, pk); + c += Ciphertexts_bytes; + HashConfirm (c, r_enc, cache); +} + +/* c,k = Encap(pk) */ +void +sntrup761_enc (unsigned char *c, unsigned char *k, const unsigned char *pk, + void *random_ctx, sntrup761_random_func * random) +{ + Inputs r; + unsigned char r_enc[Inputs_bytes]; + unsigned char cache[Hash_bytes]; + + Hash_prefix (cache, 4, pk, PublicKeys_bytes); + Inputs_random (r, random_ctx, random); + Hide (c, r_enc, r, pk, cache); + HashSession (k, 1, r_enc, c); +} + +/* 0 if matching ciphertext+confirm, else -1 */ +static int +Ciphertexts_diff_mask (const unsigned char *c, const unsigned char *c2) +{ + uint16_t differentbits = 0; + int len = Ciphertexts_bytes + Confirm_bytes; + + while (len-- > 0) + differentbits |= (*c++) ^ (*c2++); + return (1 & ((differentbits - 1) >> 8)) - 1; +} + +/* k = Decap(c,sk) */ +void +sntrup761_dec (unsigned char *k, const unsigned char *c, const unsigned char *sk) +{ + const unsigned char *pk = sk + SecretKeys_bytes; + const unsigned char *rho = pk + PublicKeys_bytes; + const unsigned char *cache = rho + Inputs_bytes; + Inputs r; + unsigned char r_enc[Inputs_bytes]; + unsigned char cnew[Ciphertexts_bytes + Confirm_bytes]; + int mask; + int i; + + ZDecrypt (r, c, sk); + Hide (cnew, r_enc, r, pk, cache); + mask = Ciphertexts_diff_mask (c, cnew); + for (i = 0; i < Inputs_bytes; ++i) + r_enc[i] ^= mask & (r_enc[i] ^ rho[i]); + HashSession (k, 1 + mask, r_enc, c); +} diff --git a/cbits/sntrup761.h b/cbits/sntrup761.h new file mode 100644 index 000000000..4b1a23bd9 --- /dev/null +++ b/cbits/sntrup761.h @@ -0,0 +1,33 @@ +/* + * Derived from public domain source, written by (in alphabetical order): + * - Daniel J. Bernstein + * - Chitchanok Chuengsatiansup + * - Tanja Lange + * - Christine van Vredendaal + */ + +#ifndef SNTRUP761_H +#define SNTRUP761_H + +#include +#include + +#define SNTRUP761_SECRETKEY_SIZE 1763 +#define SNTRUP761_PUBLICKEY_SIZE 1158 +#define SNTRUP761_CIPHERTEXT_SIZE 1039 +#define SNTRUP761_SIZE 32 + +typedef void sntrup761_random_func (void *ctx, size_t length, uint8_t *dst); + +void +sntrup761_keypair (uint8_t *pk, uint8_t *sk, + void *random_ctx, sntrup761_random_func *random); + +void +sntrup761_enc (uint8_t *c, uint8_t *k, const uint8_t *pk, + void *random_ctx, sntrup761_random_func *random); + +void +sntrup761_dec (uint8_t *k, const uint8_t *c, const uint8_t *sk); + +#endif /* SNTRUP761_H */ diff --git a/package.yaml b/package.yaml index b578a3dd0..be72fafaf 100644 --- a/package.yaml +++ b/package.yaml @@ -20,6 +20,8 @@ category: Chat, Network, Web, System, Cryptography extra-source-files: - README.md - CHANGELOG.md + - cbits/sha512.h + - cbits/sntrup761.h dependencies: - aeson == 2.2.* @@ -50,7 +52,9 @@ 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 - process == 1.6.* - random >= 1.1 && < 1.3 @@ -87,6 +91,11 @@ when: library: source-dirs: src + c-sources: + - cbits/sha512.c + - cbits/sntrup761.c + include-dirs: cbits + extra-libraries: crypto executables: smp-server: diff --git a/rfcs/2023-10-25-remote-control.md b/rfcs/2023-10-25-remote-control.md new file mode 100644 index 000000000..444185307 --- /dev/null +++ b/rfcs/2023-10-25-remote-control.md @@ -0,0 +1,361 @@ +# SimpleX Remote Control protocol + +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 without reducing security of double ratchet. + +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 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. + +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, with post-quantum algorithm in key agreement. +- Protect host device from unauthorized access in case of controller compromise. +- 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 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 invitation +- establishing session TLS connection +- session verification and protocol negotiation +- session operation + +### Session invitation + +The invitation to the first session between host and controller pair MUST be shared out-of-band, to establish a long term identity keys/certificates of the controller to host device. + +The subsequent sessions can be announced via an application-defined site-local multicast group, e.g. `224.0.0.251` (also used in mDNS/bonjour) and an application-defined port (SimpleX Chat uses 5227). + +The session invitation contains this data: +- supported version range for remote control protocol +- application-specific information, e.g. device name, application name and supported version range, settings, etc. +- session start time in seconds since epoch +- if multicast is used, counter of announce packets sent by controller +- network address (ipv4 address and port) of the controller +- CA TLS certificate fingerprint of the controller - this is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements. +- Session Ed25519 public key used to verify the announcement and commands - this mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first. +- Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity. +- Session X25519 DH key and sntrup761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. 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 invitation: +- Session signature is valid. +- Timestamp is within some window from the current time. +- Long-term key signature is valid. +- Long-term CA and signature key are the same as in the first session. +- Some version in the offered range is supported. + +OOB session invitation is a URI with this syntax: + +```abnf +sessionAddressUri = "xrcp://" encodedCAFingerprint "@" host ":" port "#/?" qsParams +encodedCAFingerprint = base64url +qsParams = param *("&" param) +param = versionRangeParam / appInfoParam / sessionTsParam / + sessPubKeyParam / idPubKeyParam / kemEncKeyParam / dhPubKeyParam / + sessSignatureParam / idSignatureParam +versionRangeParam = "v=" (versionParam / (versionParam "-" versionParam)) +versionParam = 1*DIGIT +appInfoParam = "app=" escapedJSON ; optional +sessionTsParam = "ts=" 1*DIGIT +sessPubKeyParam = "skey=" base64url ; required +idPubKeyParam = "idkey=" base64url ; required +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 = ; RFC4648, section 5 +``` + +Multicast session announcement is a binary encoded packet with this syntax: + +```abnf +sessionAddressPacket = dhPubKey nonce encrypted(unpaddedSize sessionAddress packetPad) +dhPubKey = length x509encoded ; same as announced +nonce = length *OCTET +sessionAddress = largeLength sessionAddressUri ; as above +length = 1*1 OCTET ; for binary data up to 255 bytes +largeLength = 2*2 OCTET ; for binary data up to 65535 bytes +packetPad = ; possibly, we may need to move KEM agreement one step later, +; with encapsulation key in HELLO block and KEM ciphertext in reply to HELLO. +``` + +### Establishing 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 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, 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. + +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. + - 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 +hostHello = unpaddedSize %s"HELLO " dhPubKey nonce encrypted(unpaddedSize hostHelloJSON helloPad) pad +unpaddedSize = largeLength +dhPubKey = length x509encoded +pad = +helloPad = +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 host HELLO block `hostHelloJSON`: + +```json +{ + "definitions": { + "version": { + "type": "string", + "metadata": { + "format": "[0-9]+" + } + }, + "base64url": { + "type": "string", + "metadata": { + "format": "base64url" + } + } + }, + "properties": { + "v": {"ref": "version"}, + "ca": {"ref": "base64url"}, + "kem": {"ref": "base64url"} + }, + "optionalProperties": { + "app": {"properties": {}, "additionalProperties": true} + }, + "additionalProperties": true +} +``` + +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 = +helloPad = +largeLength = 2*2 OCTET + +ctrlError = unpaddedSize %s"ERROR " nonce encrypted(unpaddedSize ctrlErrorJSON helloPad) pad +; ctrlErrorJSON is encrypted using previously agreed DH secret. +``` + +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 hybrid shared secret agreed during session establishment. + +Commands of the controller must be signed after the encryption using the controller's session and long term Ed25519 keys. + +tlsunique channel binding from TLS session MUST be included in commands (included in the signed body). + +The syntax for encrypted command and response body encoding: + +``` +commandBody = encBody sessSignature idSignature (attachment / noAttachment) +responseBody = encBody attachment; should match counter in the command +encBody = nonce encLength32 encrypted(tlsunique counter body) +attachment = %x01 nonce encLength32 encrypted(attachment) +noAttachment = %x00 +tlsunique = length 1*OCTET +counter = 8*8 OCTET ; int64 +encLength32 = 4*4 OCTET ; uint32, includes authTag +``` + +If the command or response includes attachment, it's hash must be included in command/response and validated. + +## Key agreement for announcement packet and for session + +Initial announcement is shared out-of-band (URI with xrcp scheme), and it is not encrypted. + +This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will 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 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 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 +hostHelloSecret(1) = dhSecret(1) +sessionSecret(1) = sha256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello +dhSecret(1) = dh(hostHelloDhKey(1), controllerInvitationDhKey(1)) +kemCiphertext(1) = enc(kemSecret(1), kemEncKey(1)) +// kemEncKey is included in host HELLO, kemCiphertext - in controller HELLO +kemSecret(1) = dec(kemCiphertext(1), kemDecKey(1)) + +// multicast announcement for session n +announcementSecret(n) = sha256(dhSecret(n')) +dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerDhKey(n)) + +// session n +hostHelloSecret(n) = dhSecret(n) +sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello +dhSecret(n) = dh(hostHelloDhKey(n), controllerDhKey(n)) +// controllerDhKey(n) is either from invitation or from multicast announcement +kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n)) +kemSecret(n) = dec(kemCiphertext(n), kemDecKey(n)) +``` + +If controller fails to store the new host DH key after receiving HELLO block, the encryption will become out of sync and the host won't be able to decrypt the next announcement. To mitigate it, the host should keep the last session DH key and also previous session DH key to try to decrypt the next announcement computing shared secret using both keys (first the new one, and in case it fails - the previous). + +To decrypt multicast announcement, the host should try to decrypt it using the keys of all known (paired) remote controllers. + +## Other options + +The proposed design has these pros/cons: + +Pros: +- mobile host that has sensitive data doesn't act as TLS server. +- multicast is optional - all sessions can happen via QR code only. + +Cons: +- reversing of client/server roles between TLS and HTTP2. +- in the first session mobile host TLS client credentials are verified after TLS connection is accepted. +- cannot be used with host that runs in VM. + +The alternative design will use mobile host device as TLS server. The session negotiation process: + +- desktop shares its initial credentials via QR code, only for the first session +- mobile sends encrypted multicast with session address, TLS CA fingerprint, DH key in clear text +- desktop connects to mobile +- session tlsunique presented to users on both devices - either user would have to confirm session on both devices or the mobile would have to send an additional "ready" block. + +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. + +Cons: +- multicast is mandatory, as there is no efficient way to communicate from mobile to desktop. +- still needs hello or confirmation on both devices +- mobile is now acting as TLS server creating additional attack vector + +In both proposed and alternative design mobile host has chat data, acts as HTTP2 server, commands are signed with desktop key presented out-of–band, and both commands and responses are encrypted inside TLS session. + +Other considered options: +- SSH - more work integrating it. +- use SMP connection to negotiate TLS session - it seems wrong to require Internet connection to negotiate a local network connection between desktop and mobile. +- other multicast service discovery protocols - quite insecure. + +## Threat model + +#### A passive network adversary able to monitor the site-local traffic: + +*can:* +- observe session times, duration and volume of the transmitted data between host and controller. + +*cannot:* +- observe the content of the transmitted data. +- substitute the transmitted commands or responses. +- replay transmitted commands or events from the hosts. + +#### An active network adversary able to intercept and substitute the site-local traffic: + +*can:* +- prevent host and controller devices from establishing the session + +*cannot:* +- same as passive adversary, provided that user visually verified session code out-of-band. + +#### An active adversary with the access to the network: + +*can:* +- spam controller device. + +*cannot:* +- compromise host or controller devices. + +#### An active adversary with the access to the network who also observed OOB announcement: + +*can:* +- connect to controller instead of the host. +- present incorrect data to the controller. + +*cannot:* +- connect to the host or make host connect to itself. + +#### Compromised controller device: + +*can:* +- observe the content of the transmitted data. +- access any data of the controlled host application, within the capabilities of the provided API. + +*cannot:* +- access other data on the host device. +- compromise host device. + +#### Compromised host device: + +*can:* +- present incorrect data to the controller. +- incorrectly interpret controller commands. + +*cannot:* +- access controller data, even related to this host device. diff --git a/simplexmq.cabal b/simplexmq.cabal index 369fbb242..f6714d8f2 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -26,6 +26,8 @@ build-type: Simple extra-source-files: README.md CHANGELOG.md + cbits/sha512.h + cbits/sntrup761.h flag swift description: Enable swift JSON format @@ -99,6 +101,11 @@ library Simplex.Messaging.Crypto.File Simplex.Messaging.Crypto.Lazy Simplex.Messaging.Crypto.Ratchet + Simplex.Messaging.Crypto.SNTRUP761 + Simplex.Messaging.Crypto.SNTRUP761.Bindings + Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines + Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI + Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG Simplex.Messaging.Encoding Simplex.Messaging.Encoding.String Simplex.Messaging.Notifications.Client @@ -141,11 +148,23 @@ 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 hs-source-dirs: src ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns + include-dirs: + cbits + c-sources: + cbits/sha512.c + cbits/sntrup761.c + extra-libraries: + crypto build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -175,7 +194,9 @@ 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 , process ==1.6.* , random >=1.1 && <1.3 @@ -238,7 +259,9 @@ 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 , process ==1.6.* , random >=1.1 && <1.3 @@ -302,7 +325,9 @@ 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 , process ==1.6.* , random >=1.1 && <1.3 @@ -366,7 +391,9 @@ 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 , process ==1.6.* , random >=1.1 && <1.3 @@ -430,7 +457,9 @@ 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 , process ==1.6.* , random >=1.1 && <1.3 @@ -494,7 +523,9 @@ 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 , process ==1.6.* , random >=1.1 && <1.3 @@ -546,6 +577,7 @@ test-suite simplexmq-test FileDescriptionTests NtfClient NtfServerTests + RemoteControl ServerTests SMPAgentClient SMPClient @@ -593,7 +625,9 @@ 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 , process ==1.6.* , random >=1.1 && <1.3 diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 9d87a8f52..58392d685 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -51,7 +51,6 @@ import Simplex.Messaging.Protocol tEncode, tEncodeBatch, tParse, - _smpP, ) import Simplex.Messaging.Transport (SessionId, TransportError (..)) import Simplex.Messaging.Util (bshow, (<$?>)) diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index 1309b9c31..90b1a8a44 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -6,9 +6,11 @@ module Simplex.FileTransfer.Transport ( supportedFileServerVRange, XFTPRcvChunkSpec (..), + ReceiveFileError (..), receiveFile, sendEncFile, receiveEncFile, + receiveSbFile, ) where @@ -16,6 +18,7 @@ import qualified Control.Exception as E import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Data.Bifunctor (first) import qualified Data.ByteArray as BA import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Char8 (ByteString) @@ -59,25 +62,34 @@ receiveFile getBody = receiveFile_ receive receiveEncFile :: (Int -> IO ByteString) -> LC.SbState -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () receiveEncFile getBody = receiveFile_ . receive where - receive sbState h sz = do + receive sbState h sz = first err <$> receiveSbFile getBody h sbState sz + err RFESize = SIZE + err RFECrypto = CRYPTO + +data ReceiveFileError = RFESize | RFECrypto + +receiveSbFile :: (Int -> IO ByteString) -> Handle -> LC.SbState -> Word32 -> IO (Either ReceiveFileError ()) +receiveSbFile getBody h = receive + where + receive sbState sz = do ch <- getBody fileBlockSize let chSize = fromIntegral $ B.length ch if - | chSize > sz + authSz -> pure $ Left SIZE + | chSize > sz + authSz -> pure $ Left RFESize | chSize > 0 -> do let (ch', rest) = B.splitAt (fromIntegral sz) ch (decCh, sbState') = LC.sbDecryptChunk sbState ch' sz' = sz - fromIntegral (B.length ch') B.hPut h decCh if sz' > 0 - then receive sbState' h sz' + then receive sbState' sz' else do let tag' = B.take C.authTagSize rest tagSz = B.length tag' tag = LC.sbAuth sbState' tag'' <- if tagSz == C.authTagSize then pure tag' else (tag' <>) <$> getBody (C.authTagSize - tagSz) - pure $ if BA.constEq tag'' tag then Right () else Left CRYPTO - | otherwise -> pure $ Left SIZE + pure $ if BA.constEq tag'' tag then Right () else Left RFECrypto + | otherwise -> pure $ Left RFESize authSz = fromIntegral C.authTagSize receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index c7795644e..6a0701136 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -93,6 +93,10 @@ module Simplex.Messaging.Agent xftpSendFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, + rcNewHostPairing, + rcConnectHost, + rcConnectCtrl, + rcDiscoverCtrl, 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,9 @@ 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 Simplex.RemoteControl.Types import UnliftIO.Async (async, race_) import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay) import UnliftIO.STM @@ -379,6 +387,37 @@ 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 multicast + +-- | connect to remote controller via URI +rcConnectCtrl :: AgentErrorMonad m => AgentClient -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection +rcConnectCtrl c = withAgentEnv c .:. rcConnectCtrl' + +rcConnectCtrl' :: AgentMonad m => RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection +rcConnectCtrl' verifiedInv pairing_ hostAppInfo = do + drg <- asks random + liftError RCP $ connectRCCtrl drg verifiedInv pairing_ hostAppInfo + +-- | connect to known remote controller via multicast +rcDiscoverCtrl :: AgentErrorMonad m => AgentClient -> NonEmpty RCCtrlPairing -> m (RCCtrlPairing, RCVerifiedInvitation) +rcDiscoverCtrl c = withAgentEnv c . rcDiscoverCtrl' + +rcDiscoverCtrl' :: AgentMonad m => NonEmpty RCCtrlPairing -> m (RCCtrlPairing, RCVerifiedInvitation) +rcDiscoverCtrl' pairings = do + subs <- asks multicastSubscribers + liftError RCP $ discoverRCCtrl subs pairings + -- | Activate operations foregroundAgent :: MonadUnliftIO m => AgentClient -> m () foregroundAgent c = withAgentEnv c $ foregroundAgent' c diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 23ba9f8be..190a4bf12 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -74,6 +74,7 @@ module Simplex.Messaging.Agent.Client removeSubscription, hasActiveSubscription, agentClientStore, + agentDRG, getAgentSubscriptions, SubscriptionsInfo (..), SubInfo (..), @@ -117,7 +118,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader -import Crypto.Random (getRandomBytes) +import Crypto.Random (ChaChaDRG, getRandomBytes) import qualified Data.Aeson.TH as J import Data.Bifunctor (bimap, first, second) import Data.ByteString.Base64 @@ -380,6 +381,9 @@ newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do agentClientStore :: AgentClient -> SQLiteStore agentClientStore AgentClient {agentEnv = Env {store}} = store +agentDRG :: AgentClient -> TVar ChaChaDRG +agentDRG AgentClient {agentEnv = Env {random}} = random + class (Encoding err, Show err) => ProtocolServerClient err msg | msg -> err where type Client msg = c | c -> msg getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (Client msg) diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index cbdae289c..6f2347391 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -182,7 +182,8 @@ data Env = Env clientCounter :: TVar Int, randomServer :: TVar StdGen, ntfSupervisor :: NtfSupervisor, - xftpAgent :: XFTPAgent + xftpAgent :: XFTPAgent, + multicastSubscribers :: TMVar Int } newSMPAgentEnv :: AgentConfig -> SQLiteStore -> IO Env @@ -192,7 +193,8 @@ newSMPAgentEnv config@AgentConfig {initialClientId} store = do randomServer <- newTVarIO =<< liftIO newStdGen ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config xftpAgent <- atomically newXFTPAgent - pure Env {config, store, random, clientCounter, randomServer, ntfSupervisor, xftpAgent} + multicastSubscribers <- newTMVarIO 0 + pure Env {config, store, random, clientCounter, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers} createAgentStore :: FilePath -> String -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore) createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index d447b92b5..efe75e2f5 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -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 @@ -1528,6 +1531,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) @@ -1544,6 +1548,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 diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 11d75b7ee..1b11f6465 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index cfc8156cf..65c58919c 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -84,6 +85,7 @@ module Simplex.Messaging.Crypto SignatureAlgorithm, AlgorithmI (..), sign, + sign', verify, verify', validSignatureSize, @@ -115,6 +117,8 @@ module Simplex.Messaging.Crypto cbEncrypt, cbEncryptMaxLenBS, cbDecrypt, + sbDecrypt_, + sbEncrypt_, cbNonce, randomCbNonce, pseudoRandomCbNonce, @@ -676,6 +680,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 diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs index e0117108c..ebb3692c1 100644 --- a/src/Simplex/Messaging/Crypto/Lazy.hs +++ b/src/Simplex/Messaging/Crypto/Lazy.hs @@ -14,13 +14,16 @@ module Simplex.Messaging.Crypto.Lazy sbEncrypt, sbDecrypt, sbEncryptTailTag, + kcbEncryptTailTag, sbDecryptTailTag, + kcbDecryptTailTag, fastReplicate, secretBox, secretBoxTailTag, SbState, cbInit, sbInit, + kcbInit, sbEncryptChunk, sbDecryptChunk, sbEncryptChunkLazy, @@ -48,6 +51,7 @@ import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty (..)) import Foreign (sizeOf) import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey) +import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret (..)) import Simplex.Messaging.Encoding type LazyByteString = LB.ByteString @@ -127,13 +131,33 @@ secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce -- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files). sbEncryptTailTag :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString -sbEncryptTailTag (SbKey key) (CbNonce nonce) msg len paddedLen = +sbEncryptTailTag (SbKey key) = sbEncryptTailTag_ key +{-# INLINE sbEncryptTailTag #-} + +-- | NaCl @crypto_box@ lazy encrypt with with a shared hybrid KEM+DH 256-bit secret and 192-bit nonce with appended auth tag (more efficient with large strings/files). +kcbEncryptTailTag :: KEMHybridSecret -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString +kcbEncryptTailTag (KEMHybridSecret key) = sbEncryptTailTag_ key +{-# INLINE kcbEncryptTailTag #-} + +sbEncryptTailTag_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString +sbEncryptTailTag_ key (CbNonce nonce) msg len paddedLen = LB.fromChunks <$> (secretBoxTailTag sbEncryptChunk key nonce =<< pad msg len paddedLen) -- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files). -- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag. sbDecryptTailTag :: SbKey -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString) -sbDecryptTailTag (SbKey key) (CbNonce nonce) paddedLen packet = +sbDecryptTailTag (SbKey key) = sbDecryptTailTag_ key +{-# INLINE sbDecryptTailTag #-} + +-- | NaCl @crypto_box@ lazy decrypt with a shared hybrid KEM+DH 256-bit secret and 192-bit nonce with appended auth tag (more efficient with large strings/files). +-- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag. +kcbDecryptTailTag :: KEMHybridSecret -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString) +kcbDecryptTailTag (KEMHybridSecret key) = sbDecryptTailTag_ key +{-# INLINE kcbDecryptTailTag #-} + +-- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag. +sbDecryptTailTag_ :: ByteArrayAccess key => key -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString) +sbDecryptTailTag_ key (CbNonce nonce) paddedLen packet = case secretBox sbDecryptChunk key nonce c of Right (tag :| cs) -> let valid = LB.length tag' == 16 && BA.constEq (LB.toStrict tag') tag @@ -165,6 +189,10 @@ sbInit :: SbKey -> CbNonce -> Either CryptoError SbState sbInit (SbKey secret) (CbNonce nonce) = sbInit_ secret nonce {-# INLINE sbInit #-} +kcbInit :: KEMHybridSecret -> CbNonce -> Either CryptoError SbState +kcbInit (KEMHybridSecret k) (CbNonce nonce) = sbInit_ k nonce +{-# INLINE kcbInit #-} + sbInit_ :: ByteArrayAccess key => key -> ByteString -> Either CryptoError SbState sbInit_ secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs) where diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761.hs b/src/Simplex/Messaging/Crypto/SNTRUP761.hs new file mode 100644 index 000000000..99b2771f6 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} + +module Simplex.Messaging.Crypto.SNTRUP761 where + +import Crypto.Hash (Digest, SHA256, hash) +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/ + +newtype KEMHybridSecret = KEMHybridSecret ScrubbedBytes + +-- | NaCl @crypto_box@ decrypt with a shared hybrid DH + KEM secret and 192-bit nonce. +kcbDecrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Either CryptoError ByteString +kcbDecrypt (KEMHybridSecret k) = sbDecrypt_ k + +-- | 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 k) = sbEncrypt_ k + +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) diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs new file mode 100644 index 000000000..0940c53ba --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TypeApplications #-} + +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 +import Data.ByteString (ByteString) +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.ToField +import Foreign (nullPtr) +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (withDRG) +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) + +type KEMKeyPair = (KEMPublicKey, KEMSecretKey) + +sntrup761Keypair :: TVar ChaChaDRG -> IO KEMKeyPair +sntrup761Keypair drg = + bimap KEMPublicKey KEMSecretKey + <$> BA.allocRet + c_SNTRUP761_SECRETKEY_SIZE + ( \skPtr -> + BA.alloc c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr -> + withDRG drg $ c_sntrup761_keypair pkPtr skPtr nullPtr + ) + +sntrup761Enc :: TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey) +sntrup761Enc drg (KEMPublicKey pk) = + BA.withByteArray pk $ \pkPtr -> + bimap KEMCiphertext KEMSharedKey + <$> BA.allocRet + c_SNTRUP761_SIZE + ( \kPtr -> + BA.alloc c_SNTRUP761_CIPHERTEXT_SIZE $ \cPtr -> + withDRG drg $ c_sntrup761_enc cPtr kPtr pkPtr nullPtr + ) + +sntrup761Dec :: KEMCiphertext -> KEMSecretKey -> IO KEMSharedKey +sntrup761Dec (KEMCiphertext c) (KEMSecretKey sk) = + BA.withByteArray sk $ \skPtr -> + BA.withByteArray c $ \cPtr -> + KEMSharedKey + <$> BA.alloc c_SNTRUP761_SIZE (\kPtr -> c_sntrup761_dec kPtr cPtr skPtr) + +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 . 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" + +instance ToField KEMSharedKey where + toField (KEMSharedKey k) = toField (BA.convert k :: ByteString) + +instance FromField KEMSharedKey where + fromField f = KEMSharedKey . BA.convert @ByteString <$> fromField f diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc new file mode 100644 index 000000000..1f18e16d0 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc @@ -0,0 +1,15 @@ +module Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines where + +#include "sntrup761.h" + +c_SNTRUP761_SECRETKEY_SIZE :: Int +c_SNTRUP761_SECRETKEY_SIZE = #{const SNTRUP761_SECRETKEY_SIZE} + +c_SNTRUP761_PUBLICKEY_SIZE :: Int +c_SNTRUP761_PUBLICKEY_SIZE = #{const SNTRUP761_PUBLICKEY_SIZE} + +c_SNTRUP761_CIPHERTEXT_SIZE :: Int +c_SNTRUP761_CIPHERTEXT_SIZE = #{const SNTRUP761_CIPHERTEXT_SIZE} + +c_SNTRUP761_SIZE :: Int +c_SNTRUP761_SIZE = #{const SNTRUP761_SIZE} diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs new file mode 100644 index 000000000..4983e9210 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI + ( c_sntrup761_keypair, + c_sntrup761_enc, + c_sntrup761_dec, + ) where + +import Foreign +import Foreign.C +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (RNGContext, RNGFunc) + +-- void sntrup761_keypair (uint8_t *pk, uint8_t *sk, void *random_ctx, sntrup761_random_func *random); +foreign import ccall "sntrup761_keypair" + c_sntrup761_keypair :: Ptr Word8 -> Ptr Word8 -> Ptr RNGContext -> FunPtr RNGFunc -> IO () + +-- void sntrup761_enc (uint8_t *c, uint8_t *k, const uint8_t *pk, void *random_ctx, sntrup761_random_func *random); +foreign import ccall "sntrup761_enc" + c_sntrup761_enc :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr RNGContext -> FunPtr RNGFunc -> IO () + +-- void sntrup761_dec (uint8_t *k, const uint8_t *c, const uint8_t *sk); +foreign import ccall "sntrup761_dec" + c_sntrup761_dec :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO () diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs new file mode 100644 index 000000000..e776f610d --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs @@ -0,0 +1,30 @@ +module Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG + ( withDRG, + RNGContext, + RNGFunc, + ) where + +import Control.Concurrent.STM +import Control.Exception (bracket) +import Crypto.Random (ChaChaDRG) +import Data.ByteArray (ByteArrayAccess (copyByteArrayToPtr)) +import Foreign +import Foreign.C +import qualified Simplex.Messaging.Crypto as C + +withDRG :: TVar ChaChaDRG -> (FunPtr RNGFunc -> IO a) -> IO a +withDRG drg = bracket (createRNGFunc drg) freeHaskellFunPtr + +createRNGFunc :: TVar ChaChaDRG -> IO (FunPtr RNGFunc) +createRNGFunc drg = + mkRNGFunc $ \_ctx sz buf -> do + bs <- atomically $ C.pseudoRandomBytes (fromIntegral sz) drg + copyByteArrayToPtr bs buf + +type RNGContext = () + +-- typedef void random_func (void *ctx, size_t length, uint8_t *dst); +type RNGFunc = Ptr RNGContext -> CSize -> Ptr Word8 -> IO () + +foreign import ccall "wrapper" + mkRNGFunc :: RNGFunc -> IO (FunPtr RNGFunc) diff --git a/src/Simplex/Messaging/Encoding.hs b/src/Simplex/Messaging/Encoding.hs index f2b0609bd..814a536c4 100644 --- a/src/Simplex/Messaging/Encoding.hs +++ b/src/Simplex/Messaging/Encoding.hs @@ -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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 3d5d44c7d..c130d117e 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -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 = diff --git a/src/Simplex/Messaging/Transport/Buffer.hs b/src/Simplex/Messaging/Transport/Buffer.hs index 251471679..6de9326f8 100644 --- a/src/Simplex/Messaging/Transport/Buffer.hs +++ b/src/Simplex/Messaging/Transport/Buffer.hs @@ -6,6 +6,7 @@ module Simplex.Messaging.Transport.Buffer where import Control.Concurrent.STM import qualified Control.Exception as E +import Control.Monad (forM_) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import GHC.IO.Exception (IOErrorType (..), IOException (..), ioException) @@ -28,6 +29,14 @@ withBufferLock TBuffer {getLock} = (atomically $ takeTMVar getLock) (atomically $ putTMVar getLock ()) +-- | Attempt to read some bytes, appending it to the existing buffer +peekBuffered :: TBuffer -> Int -> IO ByteString -> IO (ByteString, Maybe ByteString) +peekBuffered tb@TBuffer {buffer} t getChunk = withBufferLock tb $ do + old <- readTVarIO buffer + next_ <- timeout t getChunk + forM_ next_ $ \next -> atomically $ writeTVar buffer $! old <> next + pure (old, next_) + getBuffered :: TBuffer -> Int -> Maybe Int -> IO ByteString -> IO ByteString getBuffered tb@TBuffer {buffer} n t_ getChunk = withBufferLock tb $ do b <- readChunks True =<< readTVarIO buffer diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index a8ccdd9c9..2cd2a8ded 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -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] diff --git a/src/Simplex/Messaging/Transport/Credentials.hs b/src/Simplex/Messaging/Transport/Credentials.hs index db03b5c3a..e935ba2ad 100644 --- a/src/Simplex/Messaging/Transport/Credentials.hs +++ b/src/Simplex/Messaging/Transport/Credentials.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs index 595ab411e..17ddb9807 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 2dca0956a..373a19172 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With) import Data.Time (NominalDiffTime) import GHC.Conc -import UnliftIO.Async +import UnliftIO hiding (handle) import qualified UnliftIO.Exception as UE raceAny_ :: MonadUnliftIO m => [m a] -> m () @@ -136,6 +136,9 @@ safeDecodeUtf8 = decodeUtf8With onError where onError _ _ = Just '?' +timeoutThrow :: (MonadUnliftIO m, MonadError e m) => e -> Int -> m a -> m a +timeoutThrow e ms action = timeout ms action >>= maybe (throwError e) pure + threadDelay' :: Int64 -> IO () threadDelay' time | time <= 0 = pure () diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs new file mode 100644 index 000000000..9f2c75463 --- /dev/null +++ b/src/Simplex/RemoteControl/Client.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +module Simplex.RemoteControl.Client + ( RCHostClient (action), + RCHostConnection, + newRCHostPairing, + connectRCHost, + cancelHostClient, + RCCtrlClient (action), + RCCtrlConnection, + connectRCCtrl, + discoverRCCtrl, + confirmCtrlSession, + cancelCtrlClient, + RCStepTMVar, + rcEncryptBody, + rcDecryptBody, + xrcpBlockSize, + ) 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 Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Default (def) +import Data.Functor (($>)) +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, SockAddr (..), hostAddressToTuple) +import qualified Network.TLS as TLS +import qualified Network.UDP as UDP +import Simplex.Messaging.Agent.Client () +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Lazy (LazyByteString) +import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Crypto.SNTRUP761 +import Simplex.Messaging.Crypto.SNTRUP761.Bindings +import Simplex.Messaging.Encoding +import Simplex.Messaging.Encoding.String (StrEncoding (..)) +import Simplex.Messaging.Transport (TLS (..), cGet, cPut) +import Simplex.Messaging.Transport.Buffer (peekBuffered) +import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTransportClient) +import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) +import Simplex.Messaging.Util +import Simplex.Messaging.Version +import Simplex.RemoteControl.Discovery (getLocalAddress, recvAnnounce, startTLSServer, withListener, withSender) +import Simplex.RemoteControl.Invitation +import Simplex.RemoteControl.Types +import UnliftIO +import UnliftIO.Concurrent + +currentRCVersion :: Version +currentRCVersion = 1 + +supportedRCVRange :: VersionRange +supportedRCVRange = mkVersionRange 1 currentRCVersion + +xrcpBlockSize :: Int +xrcpBlockSize = 16384 + +helloBlockSize :: Int +helloBlockSize = 12288 + +encInvitationSize :: Int +encInvitationSize = 900 + +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), + announcer :: TMVar (Async (Either RCErrorType ())), + hostCAHash :: TMVar C.KeyHash, + endSession :: TMVar () + } + +type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))) + +connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> Bool -> ExceptT RCErrorType IO RCHostConnection +connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo multicast = do + r <- newEmptyTMVarIO + host <- getLocalAddress >>= maybe (throwError RCENoLocalAddress) pure + c@RCHClient_ {startedPort, announcer} <- liftIO mkClient + hostKeys <- liftIO genHostKeys + action <- runClient c r hostKeys `putRCError` r + -- 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@RCSignedInvitation {invitation} <- maybe (throwError RCETLSStartFailed) (liftIO . mkInvitation hostKeys host) portNum + when multicast $ case knownHost of + Nothing -> throwError RCENewController + Just KnownHostPairing {hostDhPubKey} -> do + ann <- async . liftIO . runExceptT $ announceRC drg 60 idPrivKey hostDhPubKey hostKeys invitation + atomically $ putTMVar announcer ann + pure (signedInv, RCHostClient {action, client_ = c}, r) + where + mkClient :: IO RCHClient_ + mkClient = do + startedPort <- newEmptyTMVarIO + announcer <- newEmptyTMVarIO + endSession <- newEmptyTMVarIO + hostCAHash <- newEmptyTMVarIO + pure RCHClient_ {startedPort, announcer, hostCAHash, endSession} + runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> ExceptT RCErrorType IO (Async ()) + runClient RCHClient_ {startedPort, announcer, hostCAHash, endSession} r hostKeys = do + tlsCreds <- liftIO $ genTLSCredentials caKey caCert + startTLSServer startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls -> + void . runExceptT $ do + r' <- newEmptyTMVarIO + whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, tls, r')) $ + runSession tls r' `putRCError` r' + where + runSession tls r' = do + logDebug "Incoming TLS connection" + 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" + whenM (atomically $ tryPutTMVar r' $ Right (RCHostSession {tls, sessionKeys}, helloBody, pairing')) $ do + atomically (tryReadTMVar announcer) >>= mapM_ uninterruptibleCancel + -- can use `RCHostSession` until `endSession` is signalled + logDebug "Holding session" + atomically $ takeTMVar endSession + tlsHooks :: TMVar a -> Maybe KnownHostPairing -> TMVar C.KeyHash -> TLS.ServerHooks + tlsHooks r knownHost_ hostCAHash = + def + { TLS.onNewHandshake = \_ -> atomically $ isNothing <$> tryReadTMVar r, + TLS.onClientCertificate = \(X509.CertificateChain chain) -> + case chain of + [_leaf, ca] -> do + let kh = certFingerprint ca + accept = maybe True (\h -> h.hostFingerprint == kh) knownHost_ + if accept + then atomically (putTMVar hostCAHash kh) $> TLS.CertificateUsageAccept + else pure $ 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 + } + pure $ signInvitation (snd sessKeys) idPrivKey inv + +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_ {announcer, endSession}} = do + atomically $ putTMVar endSession () + atomically (tryTakeTMVar announcer) >>= mapM_ uninterruptibleCancel + 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 = C.dh' dhPubKey dhPrivKey + helloBody <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encBody + hostHello@RCHostHello {v, ca, kem = kemPubKey} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody + unless (ca == tlsHostFingerprint) $ throwError RCEIdentity + (kemCiphertext, kemSharedKey) <- liftIO $ sntrup761Enc drg kemPubKey + let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey + unless (isCompatible v supportedRCVRange) $ throwError RCEVersion + let keys = HostSessKeys {hybridKey, idPrivKey, sessPrivKey} + knownHost' <- updateKnownHost ca dhPubKey + 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 -> C.PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing + updateKnownHost ca hostDhPubKey = 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" + pure (h :: KnownHostPairing) {hostDhPubKey} + Nothing -> pure KnownHostPairing {hostFingerprint = ca, hostDhPubKey} + +data RCCtrlClient = RCCtrlClient + { action :: Async (), + client_ :: RCCClient_ + } + +data RCCClient_ = RCCClient_ + { confirmSession :: TMVar Bool, + endSession :: TMVar () + } + +type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing))) + +-- app should determine whether it is a new or known pairing based on CA fingerprint in the invitation +connectRCCtrl :: TVar ChaChaDRG -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection +connectRCCtrl drg (RCVerifiedInvitation 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' + pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, dhPrivKey, prevDhPrivKey = Nothing} + updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing + updateCtrlPairing pairing@RCCtrlPairing {ctrlFingerprint, idPubKey, dhPrivKey = currDhPrivKey} = do + unless (ca == ctrlFingerprint && idPubKey == idkey) $ throwError RCEIdentity + (_, dhPrivKey) <- liftIO C.generateKeyPair' + pure pairing {dhPrivKey, prevDhPrivKey = Just currDhPrivKey} + +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 `putRCError` r + pure (RCCtrlClient {action, client_ = c}, r) + where + mkClient :: IO RCCClient_ + mkClient = do + confirmSession <- newEmptyTMVarIO + endSession <- newEmptyTMVarIO + pure RCCClient_ {confirmSession, endSession} + runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO () + runClient RCCClient_ {confirmSession, endSession} r = do + clientCredentials <- + liftIO (genTLSCredentials caKey caCert) >>= \case + TLS.Credentials (creds : _) -> pure $ Just creds + _ -> throwError $ RCEInternal "genTLSCredentials must generate credentials" + let clientConfig = defaultTransportClientConfig {clientCredentials} + runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls@TLS {tlsBuffer, tlsContext} -> do + -- pump socket to detect connection problems + liftIO $ peekBuffered tlsBuffer 100000 (TLS.recvData tlsContext) >>= logDebug . tshow -- should normally be ("", Nothing) here + logDebug "Got TLS connection" + r' <- newEmptyTMVarIO + whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, tls, r')) $ do + logDebug "Waiting for session confirmation" + whenM (atomically $ readTMVar confirmSession) $ runSession tls r' `putRCError` r' + where + runSession tls r' = do + (sharedKey, kemPrivKey, hostEncHello) <- prepareHostHello drg pairing' inv hostAppInfo + sendRCPacket tls hostEncHello + ctrlEncHello <- receiveRCPacket tls + logDebug "Received ctrl HELLO" + ctrlSessKeys <- prepareCtrlSession pairing' inv sharedKey kemPrivKey ctrlEncHello + whenM (atomically $ tryPutTMVar r' $ Right (RCCtrlSession {tls, sessionKeys = ctrlSessKeys}, pairing')) $ do + logDebug "Session started" + -- release second putTMVar in confirmCtrlSession + void . atomically $ takeTMVar confirmSession + atomically $ takeTMVar endSession + logDebug "Session ended" + +catchRCError :: ExceptT RCErrorType IO a -> (RCErrorType -> ExceptT RCErrorType IO a) -> ExceptT RCErrorType IO a +catchRCError = catchAllErrors (RCEException . show) +{-# INLINE catchRCError #-} + +putRCError :: ExceptT RCErrorType IO a -> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a +a `putRCError` r = a `catchRCError` \e -> atomically (tryPutTMVar r $ Left e) >> throwError e + +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 (C.DhSecretX25519, KEMSecretKey, RCHostEncHello) +prepareHostHello + drg + RCCtrlPairing {caCert, dhPrivKey} + 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 helloBody = RCHostHello {v = v', ca = certFingerprint caCert, app = hostAppInfo, kem = kemPubKey} + sharedKey = C.dh' dhPubKey dhPrivKey + encBody <- liftEitherWith (const RCEBlockSize) $ C.cbEncrypt 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 -> C.DhSecretX25519 -> KEMSecretKey -> RCCtrlEncHello -> ExceptT RCErrorType IO CtrlSessKeys +prepareCtrlSession + RCCtrlPairing {idPubKey, 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 + pure CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey} + RCCtrlEncError {nonce, encMessage} -> do + message <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encMessage + throwError $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message + +-- * Multicast discovery + +announceRC :: TVar ChaChaDRG -> Int -> C.PrivateKeyEd25519 -> C.PublicKeyX25519 -> RCHostKeys -> RCInvitation -> ExceptT RCErrorType IO () +announceRC drg maxCount idPrivKey knownDhPub RCHostKeys {sessKeys, dhKeys} inv = withSender $ \sender -> do + replicateM_ maxCount $ do + logDebug "Announcing..." + nonce <- atomically $ C.pseudoRandomCbNonce drg + encInvitation <- liftEitherWith undefined $ C.cbEncrypt sharedKey nonce sigInvitation encInvitationSize + liftIO . UDP.send sender $ smpEncode RCEncInvitation {dhPubKey, nonce, encInvitation} + threadDelay 1000000 + where + sigInvitation = strEncode $ signInvitation sPrivKey idPrivKey inv + (_sPub, sPrivKey) = sessKeys + sharedKey = C.dh' knownDhPub dhPrivKey + (dhPubKey, dhPrivKey) = dhKeys + +discoverRCCtrl :: TMVar Int -> NonEmpty RCCtrlPairing -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation) +discoverRCCtrl subscribers pairings = + timeoutThrow RCENotDiscovered 30000000 $ withListener subscribers $ \listener -> + loop $ do + (source, bytes) <- recvAnnounce listener + encInvitation <- liftEitherWith (const RCEInvitation) $ smpDecode bytes + r@(_, RCVerifiedInvitation RCInvitation {host}) <- findRCCtrlPairing pairings encInvitation + case source of + SockAddrInet _ ha | THIPv4 (hostAddressToTuple ha) == host -> pure () + _ -> throwError RCEInvitation + pure r + where + loop :: ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a + loop action = + liftIO (runExceptT action) >>= \case + Left err -> logError (tshow err) >> loop action + Right res -> pure res + +findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation) +findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do + (pairing, signedInvStr) <- liftEither $ decrypt (L.toList pairings) + signedInv <- liftEitherWith RCESyntax $ strDecode signedInvStr + inv@(RCVerifiedInvitation RCInvitation {dh = invDh}) <- maybe (throwError RCEInvitation) pure $ verifySignedInvitation signedInv + unless (invDh == dhPubKey) $ throwError RCEInvitation + pure (pairing, inv) + where + decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString) + decrypt [] = Left RCECtrlNotFound + decrypt (pairing@RCCtrlPairing {dhPrivKey, prevDhPrivKey} : rest) = + let r = decrypt_ dhPrivKey <|> (decrypt_ =<< prevDhPrivKey) + in maybe (decrypt rest) (Right . (pairing,)) r + decrypt_ :: C.PrivateKeyX25519 -> Maybe ByteString + decrypt_ dhPrivKey = + let key = C.dh' dhPubKey dhPrivKey + in eitherToMaybe $ C.cbDecrypt key nonce encInvitation + +-- * Controller handle operations + +-- 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 + +-- * Session encryption + +rcEncryptBody :: TVar ChaChaDRG -> KEMHybridSecret -> LazyByteString -> ExceptT RCErrorType IO (C.CbNonce, LazyByteString) +rcEncryptBody drg hybridKey s = do + nonce <- atomically $ C.pseudoRandomCbNonce drg + let len = LB.length s + ct <- liftEitherWith (const RCEEncrypt) $ LC.kcbEncryptTailTag hybridKey nonce s len (len + 8) + pure (nonce, ct) + +rcDecryptBody :: KEMHybridSecret -> C.CbNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString +rcDecryptBody hybridKey nonce ct = do + let len = LB.length ct - 16 + when (len < 0) $ throwError RCEDecrypt + (ok, s) <- liftEitherWith (const RCEDecrypt) $ LC.kcbDecryptTailTag hybridKey nonce len ct + unless ok $ throwError RCEDecrypt + pure s diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs new file mode 100644 index 000000000..ab4400ed3 --- /dev/null +++ b/src/Simplex/RemoteControl/Discovery.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# 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 Data.Default (def) +import Data.Maybe (listToMaybe, mapMaybe) +import Data.String (IsString) +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.Messaging.Encoding (Encoding (..)) +import Simplex.Messaging.Transport (supportedParameters) +import qualified Simplex.Messaging.Transport as Transport +import Simplex.Messaging.Transport.Client (TransportHost (..)) +import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer) +import Simplex.Messaging.Util (ifM, tshow) +import Simplex.RemoteControl.Discovery.Multicast (setMembership) +import Simplex.RemoteControl.Types +import UnliftIO + +-- | mDNS multicast group +pattern MULTICAST_ADDR_V4 :: (IsString a, Eq a) => a +pattern MULTICAST_ADDR_V4 = "224.0.0.251" + +pattern ANY_ADDR_V4 :: (IsString a, Eq a) => a +pattern ANY_ADDR_V4 = "0.0.0.0" + +pattern DISCOVERY_PORT :: (IsString a, Eq a) => a +pattern DISCOVERY_PORT = "5227" + +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 + +getLocalAddressMulticast :: MonadIO m => TMVar Int -> m (Maybe TransportHost) +getLocalAddressMulticast subscribers = liftIO $ do + probe <- mkIpProbe + let bytes = smpEncode probe + withListener subscribers $ \receiver -> + withSender $ \sender -> do + UDP.send sender bytes + let expect = do + UDP.recvFrom receiver >>= \case + (p, _) | p /= bytes -> expect + (_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure $ THIPv4 (N.hostAddressToTuple host) + (_, UDP.ClientSockAddr _badAddr _) -> error "receiving from IPv4 socket" + timeout 1000000 expect + +mkIpProbe :: MonadIO m => m IpProbe +mkIpProbe = do + randomNonce <- liftIO $ getRandomBytes 32 + pure IpProbe {versionRange = ipProbeVersionRange, randomNonce} + +-- | 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 + +-- 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 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 = True, + TLS.serverShared = def {TLS.sharedCredentials = credentials}, + TLS.serverHooks = hooks, + TLS.serverSupported = supportedParameters + } + +withSender :: MonadUnliftIO m => (UDP.UDPSocket -> m a) -> m a +withSender = bracket (liftIO $ UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) (liftIO . UDP.close) + +withListener :: MonadUnliftIO m => TMVar Int -> (UDP.ListenSocket -> m a) -> m a +withListener subscribers = bracket (openListener subscribers) (closeListener subscribers) + +openListener :: MonadIO m => TMVar Int -> m UDP.ListenSocket +openListener subscribers = liftIO $ do + sock <- UDP.serverSocket (MULTICAST_ADDR_V4, read DISCOVERY_PORT) + logDebug $ "Discovery listener socket: " <> tshow sock + let raw = UDP.listenSocket sock + -- N.setSocketOption raw N.Broadcast 1 + joinMulticast subscribers raw (listenerHostAddr4 sock) + 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 + +joinMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO () +joinMulticast subscribers sock group = do + now <- atomically $ takeTMVar subscribers + when (now == 0) $ do + setMembership sock group True >>= \case + Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e) + Right () -> atomically $ putTMVar subscribers (now + 1) + +partMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO () +partMulticast subscribers sock group = do + now <- atomically $ takeTMVar subscribers + when (now == 1) $ + setMembership sock group False >>= \case + Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e) + Right () -> atomically $ putTMVar subscribers (now - 1) + +listenerHostAddr4 :: UDP.ListenSocket -> N.HostAddress +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 sock = liftIO $ do + (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock + pure (source, invite) diff --git a/src/Simplex/RemoteControl/Discovery/Multicast.hsc b/src/Simplex/RemoteControl/Discovery/Multicast.hsc new file mode 100644 index 000000000..1a5260da3 --- /dev/null +++ b/src/Simplex/RemoteControl/Discovery/Multicast.hsc @@ -0,0 +1,48 @@ +module Simplex.RemoteControl.Discovery.Multicast + ( setMembership + ) where + +import Foreign (Ptr, allocaBytes, castPtr, pokeByteOff) +import Foreign.C.Types (CInt (..)) +import Network.Socket + +#include + +{- | Toggle multicast group membership. + +NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups. +-} +setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ()) +setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do + #{poke struct ip_mreq, imr_multiaddr} mReqPtr group + #{poke struct ip_mreq, imr_interface} mReqPtr (0 :: HostAddress) -- attempt to contact the group on ANY interface + withFdSocket sock $ \fd -> do + rc <- c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq}) + if rc == 0 + then pure $ Right () + else pure $ Left rc + where + flag = if membership then c_IP_ADD_MEMBERSHIP else c_IP_DROP_MEMBERSHIP + +#ifdef mingw32_HOST_OS + +foreign import stdcall unsafe "setsockopt" + c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt + +c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt +c_IP_ADD_MEMBERSHIP = 12 +c_IP_DROP_MEMBERSHIP = 13 + +#else + +foreign import ccall unsafe "setsockopt" + c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt + +c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt +c_IP_ADD_MEMBERSHIP = #const IP_ADD_MEMBERSHIP +c_IP_DROP_MEMBERSHIP = #const IP_DROP_MEMBERSHIP + +#endif + +c_IPPROTO_IP :: CInt +c_IPPROTO_IP = #const IPPROTO_IP diff --git a/src/Simplex/RemoteControl/Invitation.hs b/src/Simplex/RemoteControl/Invitation.hs new file mode 100644 index 000000000..f5deac9a8 --- /dev/null +++ b/src/Simplex/RemoteControl/Invitation.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.RemoteControl.Invitation + ( RCInvitation (..) + , signInvitation + , RCSignedInvitation (..) + , verifySignedInvitation + , RCVerifiedInvitation (..) + , RCEncInvitation (..) + ) where + +import qualified Data.Aeson as J +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 (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} + +signInvitation :: C.PrivateKey C.Ed25519 -> C.PrivateKey C.Ed25519 -> RCInvitation -> RCSignedInvitation +signInvitation sKey idKey invitation = RCSignedInvitation {invitation, ssig, idsig} + where + uri = strEncode invitation + ssig = + case C.sign (C.APrivateSignKey C.SEd25519 sKey) uri of + C.ASignature C.SEd25519 s -> s + _ -> error "signing with ed25519" + inviteUrlSigned = mconcat [uri, "&ssig=", strEncode ssig] + idsig = + case C.sign (C.APrivateSignKey C.SEd25519 idKey) inviteUrlSigned of + C.ASignature C.SEd25519 s -> s + _ -> error "signing with ed25519" + +newtype RCVerifiedInvitation = RCVerifiedInvitation RCInvitation + deriving (Show) + +verifySignedInvitation :: RCSignedInvitation -> Maybe RCVerifiedInvitation +verifySignedInvitation RCSignedInvitation {invitation, ssig, idsig} = + if C.verify' skey ssig inviteURL && C.verify' idkey idsig inviteURLS + then Just $ RCVerifiedInvitation invitation + else Nothing + where + RCInvitation {skey, idkey} = invitation + inviteURL = strEncode invitation + inviteURLS = mconcat [inviteURL, "&ssig=", strEncode ssig] + +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 diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs new file mode 100644 index 000000000..7f99079b2 --- /dev/null +++ b/src/Simplex/RemoteControl/Types.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.RemoteControl.Types 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.Text as T +import Data.Text.Encoding (encodeUtf8) +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.Encoding.String +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON) +import Simplex.Messaging.Transport (TLS) +import Simplex.Messaging.Util (safeDecodeUtf8) +import Simplex.Messaging.Version (Version, VersionRange, mkVersionRange) +import UnliftIO + +data RCErrorType + = RCEInternal {internalErr :: String} + | RCEIdentity + | RCENoLocalAddress + | RCENewController + | RCENotDiscovered + | RCETLSStartFailed + | RCEException {exception :: String} + | RCECtrlAuth + | RCECtrlNotFound + | RCECtrlError {ctrlErr :: String} + | RCEInvitation + | RCEVersion + | RCEEncrypt + | 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" + RCENewController -> "NEW_CONTROLLER" + RCENotDiscovered -> "NOT_DISCOVERED" + RCETLSStartFailed -> "CTRL_TLS_START" + RCEException err -> "EXCEPTION" <> text err + RCECtrlAuth -> "CTRL_AUTH" + RCECtrlNotFound -> "CTRL_NOT_FOUND" + RCECtrlError err -> "CTRL_ERROR" <> text err + RCEInvitation -> "INVITATION" + RCEVersion -> "VERSION" + RCEEncrypt -> "ENCRYPT" + 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 + "NEW_CONTROLLER" -> pure RCENewController + "NOT_DISCOVERED" -> pure RCENotDiscovered + "CTRL_TLS_START" -> pure RCETLSStartFailed + "EXCEPTION" -> RCEException <$> textP + "CTRL_AUTH" -> pure RCECtrlAuth + "CTRL_NOT_FOUND" -> pure RCECtrlNotFound + "CTRL_ERROR" -> RCECtrlError <$> textP + "INVITATION" -> pure RCEInvitation + "VERSION" -> pure RCEVersion + "ENCRYPT" -> pure RCEEncrypt + "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) + +instance Encoding IpProbe where + smpEncode IpProbe {versionRange, randomNonce} = smpEncode (versionRange, 'I', randomNonce) + + smpP = IpProbe <$> (smpP <* "I") *> smpP + +-- * Session + +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) + +-- | 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 + hostDhPubKey :: C.PublicKeyX25519 + } + +-- | 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, + dhPrivKey :: C.PrivateKeyX25519, + prevDhPrivKey :: Maybe C.PrivateKeyX25519 + } + +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" + +-- * Utils + +-- | tlsunique channel binding +type SessionCode = ByteString + +type RCStepTMVar a = TMVar (Either RCErrorType a) + +type Tasks = TVar [Async ()] + +asyncRegistered :: MonadUnliftIO m => Tasks -> m () -> m () +asyncRegistered tasks action = async action >>= registerAsync tasks + +registerAsync :: MonadIO m => Tasks -> Async () -> m () +registerAsync tasks = atomically . modifyTVar tasks . (:) + +cancelTasks :: MonadIO m => Tasks -> m () +cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RCErrorType) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 8f19c776e..8c37579fc 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -143,7 +143,7 @@ prevRange vr = vr {maxVersion = maxVersion vr - 1} runRight_ :: (Eq e, Show e, HasCallStack) => ExceptT e IO () -> Expectation runRight_ action = runExceptT action `shouldReturn` Right () -runRight :: HasCallStack => ExceptT AgentErrorType IO a -> IO a +runRight :: (Show e, HasCallStack) => ExceptT e IO a -> IO a runRight action = runExceptT action >>= \case Right x -> pure x diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index 6ecc865c1..fb902a41e 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -3,8 +3,9 @@ module CoreTests.CryptoTests (cryptoTests) where +import Control.Concurrent.STM import Control.Monad.Except -import Crypto.Random (getRandomBytes) +import Crypto.Random (drgNew, getRandomBytes) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (isRight) @@ -15,6 +16,7 @@ import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LE import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -87,6 +89,8 @@ cryptoTests = do describe "Ed448" $ testEncoding C.SEd448 describe "X25519" $ testEncoding C.SX25519 describe "X448" $ testEncoding C.SX448 + describe "sntrup761" $ + it "should enc/dec key" testSNTRUP761 testPadUnpadFile :: IO () testPadUnpadFile = do @@ -197,3 +201,11 @@ testEncoding alg = it "should encode / decode key" . ioProperty $ do pure $ \(_ :: Int) -> C.decodePubKey (C.encodePubKey k) == Right k && C.decodePrivKey (C.encodePrivKey pk) == Right pk + +testSNTRUP761 :: IO () +testSNTRUP761 = do + drg <- newTVarIO =<< drgNew + (pk, sk) <- sntrup761Keypair drg + (c, KEMSharedKey k) <- sntrup761Enc drg pk + KEMSharedKey k' <- sntrup761Dec c sk + k' `shouldBe` k diff --git a/tests/CoreTests/ProtocolErrorTests.hs b/tests/CoreTests/ProtocolErrorTests.hs index cc6da7b6c..6dc6f2c02 100644 --- a/tests/CoreTests/ProtocolErrorTests.hs +++ b/tests/CoreTests/ProtocolErrorTests.hs @@ -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 diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs new file mode 100644 index 000000000..d70fbc7e7 --- /dev/null +++ b/tests/RemoteControl.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module RemoteControl where + +import AgentTests.FunctionalAPITests (runRight) +import Control.Logger.Simple +import Crypto.Random (ChaChaDRG, drgNew) +import qualified Data.Aeson as J +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Simplex.RemoteControl.Client as RC +import Simplex.RemoteControl.Invitation (RCSignedInvitation, verifySignedInvitation) +import Simplex.RemoteControl.Types +import Test.Hspec +import UnliftIO +import UnliftIO.Concurrent + +remoteControlTests :: Spec +remoteControlTests = do + describe "New controller/host pairing" $ do + it "should connect to new pairing" testNewPairing + it "should connect to existing pairing" testExistingPairing + describe "Multicast discovery" $ do + it "should find paired host and connect" testMulticast + +testNewPairing :: IO () +testNewPairing = do + drg <- drgNew >>= newTVarIO + hp <- RC.newRCHostPairing + invVar <- newEmptyMVar + ctrlSessId <- async . runRight $ do + logNote "c 1" + (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") False + logNote "c 2" + putMVar invVar (inv, hc) + logNote "c 3" + Right (sessId, _tls, r') <- atomically $ takeTMVar r + logNote "c 4" + Right (_rcHostSession, _rcHelloBody, _hp') <- atomically $ takeTMVar r' + logNote "c 5" + threadDelay 250000 + logNote "ctrl: ciao" + liftIO $ RC.cancelHostClient hc + pure sessId + + (signedInv, hc) <- takeMVar invVar + -- logNote $ decodeUtf8 $ strEncode inv + inv <- maybe (fail "bad invite") pure $ verifySignedInvitation signedInv + + hostSessId <- async . runRight $ do + logNote "h 1" + (rcCtrlClient, r) <- RC.connectRCCtrl drg inv Nothing (J.String "app") + logNote "h 2" + Right (sessId', _tls, 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 250000 + logNote "ctrl: adios" + pure sessId' + + waitCatch hc.action >>= \case + Left err -> fromException err `shouldBe` Just AsyncCancelled + Right () -> fail "Unexpected controller finish" + + timeout 5000000 (waitBoth ctrlSessId hostSessId) >>= \case + Just (sessId, sessId') -> sessId `shouldBe` sessId' + _ -> fail "timeout" + +testExistingPairing :: IO () +testExistingPairing = do + drg <- drgNew >>= newTVarIO + invVar <- newEmptyMVar + hp <- liftIO $ RC.newRCHostPairing + ctrl <- runCtrl drg False hp invVar + inv <- takeMVar invVar + let cp_ = Nothing + host <- runHostURI drg cp_ inv + timeout 5000000 (waitBoth ctrl host) >>= \case + Nothing -> fail "timeout" + Just (hp', cp') -> do + ctrl' <- runCtrl drg False hp' invVar + inv' <- takeMVar invVar + host' <- runHostURI drg (Just cp') inv' + timeout 5000000 (waitBoth ctrl' host') >>= \case + Nothing -> fail "timeout" + Just (_hp2, cp2) -> do + ctrl2 <- runCtrl drg False hp' invVar -- old host pairing used to test controller not updating state + inv2 <- takeMVar invVar + host2 <- runHostURI drg (Just cp2) inv2 + timeout 5000000 (waitBoth ctrl2 host2) >>= \case + Nothing -> fail "timeout" + Just (hp3, cp3) -> do + ctrl3 <- runCtrl drg False hp3 invVar + inv3 <- takeMVar invVar + host3 <- runHostURI drg (Just cp3) inv3 + timeout 5000000 (waitBoth ctrl3 host3) >>= \case + Nothing -> fail "timeout" + Just _ -> pure () + +testMulticast :: IO () +testMulticast = do + drg <- drgNew >>= newTVarIO + subscribers <- newTMVarIO 0 + invVar <- newEmptyMVar + hp <- liftIO RC.newRCHostPairing + ctrl <- runCtrl drg False hp invVar + inv <- takeMVar invVar + let cp_ = Nothing + host <- runHostURI drg cp_ inv + timeout 5000000 (waitBoth ctrl host) >>= \case + Nothing -> fail "timeout" + Just (hp', cp') -> do + ctrl' <- runCtrl drg True hp' invVar + _inv <- takeMVar invVar + host' <- runHostMulticast drg subscribers cp' + timeout 5000000 (waitBoth ctrl' host') >>= \case + Nothing -> fail "timeout" + Just _ -> pure () + +runCtrl :: TVar ChaChaDRG -> Bool -> RCHostPairing -> MVar RCSignedInvitation -> IO (Async RCHostPairing) +runCtrl drg multicast hp invVar = async . runRight $ do + (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") multicast + putMVar invVar inv + Right (_sessId, _tls, r') <- atomically $ takeTMVar r + Right (_rcHostSession, _rcHelloBody, hp') <- atomically $ takeTMVar r' + threadDelay 250000 + liftIO $ RC.cancelHostClient hc + pure hp' + +runHostURI :: TVar ChaChaDRG -> Maybe RCCtrlPairing -> RCSignedInvitation -> IO (Async RCCtrlPairing) +runHostURI drg cp_ signedInv = async . runRight $ do + inv <- maybe (fail "bad invite") pure $ verifySignedInvitation signedInv + (rcCtrlClient, r) <- RC.connectRCCtrl drg inv cp_ (J.String "app") + Right (_sessId', _tls, r') <- atomically $ takeTMVar r + liftIO $ RC.confirmCtrlSession rcCtrlClient True + Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r' + threadDelay 250000 + pure cp' + +runHostMulticast :: TVar ChaChaDRG -> TMVar Int -> RCCtrlPairing -> IO (Async RCCtrlPairing) +runHostMulticast drg subscribers cp = async . runRight $ do + (pairing, inv) <- RC.discoverRCCtrl subscribers (cp :| []) + (rcCtrlClient, r) <- RC.connectRCCtrl drg inv (Just pairing) (J.String "app") + Right (_sessId', _tls, r') <- atomically $ takeTMVar r + liftIO $ RC.confirmCtrlSession rcCtrlClient True + Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r' + threadDelay 250000 + pure cp' diff --git a/tests/Test.hs b/tests/Test.hs index 5c07cde1e..6493ba860 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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