diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index f4c44cff9..04a2acdf0 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -49,7 +49,7 @@ jobs: run: cabal build --enable-tests - name: Test - timeout-minutes: 30 + timeout-minutes: 40 shell: bash run: cabal test --test-show-details=direct @@ -63,7 +63,7 @@ jobs: mv $(cabal list-bin xftp) xftp-ubuntu-${{ matrix.platform_name}} - name: Build changelog - if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04' + if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-22.04' id: build_changelog uses: mikepenz/release-changelog-builder-action@v1 with: @@ -75,7 +75,7 @@ jobs: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - name: Create release - if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04' && matrix.ghc == '9.6.3' + if: startsWith(github.ref, 'refs/tags/v') && matrix.ghc != '8.10.7' uses: softprops/action-gh-release@v1 with: body: | diff --git a/CHANGELOG.md b/CHANGELOG.md index ad8862b0f..90706a19e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,87 @@ +# 5.8.2 + +Agent: +- fast handshake support (disabled). +- new statistics api. + +SMP server: +- fast handshake support (SKEY command). +- minor changes to reduce memory usage. + +# 5.8.1 + +Agent: +- API to reconnect one server. +- Better error handling of file errors and remote control connection errors. +- Only start uploading file once all chunks were registered on the servers. + +SMP server: +- additional stats for sent message notifications. +- fix server page layout. + +# 5.8.0 + +Version 5.8.0.10 + +SMP server and client: +- protocol extension to forward messages to the destination servers, to protect sending client IP address and transport session. + +Agent: +- process timed out subscription responses to reduce the number of resubscriptions. +- avoid sending messages and commands when waiting for response timed out (except batched SUB and DEL commands). +- fix issue with stuck message reception on slow connection (when response to ACK timed out, and the new message was not processed until resubscribed). +- fix issue when temporary file sending or receiving error was treated as permanent. + +SMP server: +- include OK responses to all batched SUB requests to reduce subscription timeouts. + +XFTP server: +- report file upload timeout as TIMEOUT, to avoid delivery failure. + +# 5.7.6 + +XFTP agent: +- treat XFTP handshake timeouts and network errors as temporary, to retry file operations. + +# 5.7.5 + +SMP agent: +- fail if non-unique connection IDs are passed to sendMessages (to prevent client errors and deadlocks). + +# 5.7.4 + +SMP agent: +- remove re-subscription timeouts (as they are tracked per operation, and could cause failed subscriptions). +- reconnect XFTP clients when network settings changes. +- fix lock contention resulting in stuck subscriptions on network change. + +# 5.7.3 + +SMP/NTF protocol: +- add ALPN for handshake version negotiation, similar to XFTP (to preserve backwards compatibility with the old clients). +- upgrade clients to versions v7/v2 of the protocols. + +SMP server: +- faster responses to subscription requests. + +XFTP client: +- fix network exception during file download treated as permanent file error. + +SMP agent: +- do not report subscription timeouts while client is offline. + +# 5.7.2 + +SMP agent: +- fix connections failing when connecting via link due to race condition on slow network. +- remove concurrency limit when waiting for connection subscription. +- remove TLS timeout. + +# 5.7.1 + +SMP agent: +- increase timeout for TLS connection via SOCKS + # 5.7.0 Version 5.7.0.4 diff --git a/README.md b/README.md index d946b8ec6..2c475ffd5 100644 --- a/README.md +++ b/README.md @@ -208,14 +208,17 @@ On Linux, you can build smp server using Docker. #### Using your distribution -1. Install [Haskell GHCup](https://www.haskell.org/ghcup/), GHC 8.10.7 and cabal: +1. Install dependencies and build tools (`GHC`, `cabal` and dev libs): ```sh - curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh - ghcup install ghc 8.10.7 - ghcup install cabal - ghcup set ghc 8.10.7 - ghcup set cabal + # On Ubuntu. Depending on your distribution, use your package manager to determine package names. + sudo apt-get update && apt-get install -y build-essential curl libffi-dev libffi7 libgmp3-dev libgmp10 libncurses-dev libncurses5 libtinfo5 pkg-config zlib1g-dev libnuma-dev libssl-dev + export BOOTSTRAP_HASKELL_GHC_VERSION=9.6.3 + export BOOTSTRAP_HASKELL_CABAL_VERSION=3.10.3.0 + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 sh + ghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}" + ghcup set cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}" + source ~/.ghcup/env ``` 2. Build the project: @@ -224,10 +227,20 @@ On Linux, you can build smp server using Docker. git clone https://github.com/simplex-chat/simplexmq cd simplexmq git checkout stable - # On Ubuntu. Depending on your distribution, use your package manager to determine package names. - apt-get update && apt-get install -y build-essential libgmp3-dev zlib1g-dev cabal update - cabal install + cabal build exe:smp-server exe:xftp-server + ``` + +3. List compiled binaries: + + `smp-server` + ```sh + cabal list-bin exe:smp-server + ``` + + `xftp-server` + ```sh + cabal list-bin exe:xftp-server ``` - Initialize SMP server with `smp-server init [-l] -n ` or `smp-server init [-l] --ip ` - depending on how you initialize it, either FQDN or IP will be used for server's address. diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs index d5cc5e732..d0de4b4f1 100644 --- a/apps/smp-server/Main.hs +++ b/apps/smp-server/Main.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE LambdaCase #-} - module Main where import Control.Logger.Simple import Simplex.Messaging.Server.CLI (getEnvPath) import Simplex.Messaging.Server.Main +import qualified Static defaultCfgPath :: FilePath defaultCfgPath = "/etc/opt/simplex" @@ -20,4 +19,4 @@ main = do setLogLevel LogDebug cfgPath <- getEnvPath "SMP_SERVER_CFG_PATH" defaultCfgPath logPath <- getEnvPath "SMP_SERVER_LOG_PATH" defaultLogPath - withGlobalLogging logCfg $ smpServerCLI cfgPath logPath + withGlobalLogging logCfg $ smpServerCLI_ Static.generateSite Static.serveStaticFiles cfgPath logPath diff --git a/apps/smp-server/static/contact/index.html b/apps/smp-server/static/contact/index.html new file mode 120000 index 000000000..1140bcf31 --- /dev/null +++ b/apps/smp-server/static/contact/index.html @@ -0,0 +1 @@ +../link.html \ No newline at end of file diff --git a/apps/smp-server/static/index.html b/apps/smp-server/static/index.html new file mode 100644 index 000000000..e276ff596 --- /dev/null +++ b/apps/smp-server/static/index.html @@ -0,0 +1,531 @@ + + + + + + + SimpleX Chat - Server Information + + + + + + + + + + + + + +
+
+
+ +
+
+ +
+ +
+
+
+

Server + information

+ +
+
+

+ Public information +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Source code:${sourceCode}
Web site:${website}
Usage conditions:${usageConditions}
Amendments:${usageAmendments}
Operator:${operatorEntity} (${operatorCountry})
Administrator contacts: + +
Complaints and feedback: + +
Hosting provider:${hostingEntity} (${hostingCountry})
Server country:${serverCountry}
+
+ +
+

+ Configuration

+ + + + + + + + + + + + + + + + + + + + + +
Persistence:${persistence}
Message expiration:${messageExpiration}
Stats enabled:${statsEnabled}
New queues allowed:${newQueuesAllowed}
Basic auth enabled:${basicAuthEnabled}
+
+
+
+
+ +
+
+

+ Join SimpleX +

+

We invite you to join the conversation

+
Join + the REDDIT communityJoin + us on GitHubDonate + here to help us
+
+

Get SimpleX desktop app

+
+
+
+ +
+
+
+
logo +
+
SimpleX + WhitepaperSimpleX + Chat protocolTerms + & Privacy PolicyDonate
+
Terminal + CLITypeScript + SDK
+
+
+ +
© + 2020-2023 SimpleX | Open-Source Project +
+
+ + + + + \ No newline at end of file diff --git a/apps/smp-server/static/invitation/index.html b/apps/smp-server/static/invitation/index.html new file mode 120000 index 000000000..1140bcf31 --- /dev/null +++ b/apps/smp-server/static/invitation/index.html @@ -0,0 +1 @@ +../link.html \ No newline at end of file diff --git a/apps/smp-server/static/link.html b/apps/smp-server/static/link.html new file mode 100644 index 000000000..cbab7324f --- /dev/null +++ b/apps/smp-server/static/link.html @@ -0,0 +1,527 @@ + + + + + + + SimpleX Chat - Invitation + + + + + + + + +
+
+
+ +
+
+ +
+ + + +
+
+
+

You received a + 1-time link to connect on SimpleX Chat

+

To make a + connection:

+
+

Install SimpleX app

+
+
+

1

+
+
+
+

Connect in app

Open + Simplex app +
+

2

+
+
+
+

Tap the‘connect’button in the app

+
+

3

+
+
+
+
+
+ + + +
+
+

+ Join SimpleX +

+

We invite you to join the conversation

+
Join + the REDDIT communityJoin + us on GitHubDonate + here to help us
+
+

Get SimpleX desktop app

+
+
+
+
+
+
+
logo +
+
SimpleX + WhitepaperSimpleX + Chat protocolTerms + & Privacy PolicyDonate
+
Terminal + CLITypeScript + SDK
+
+
+ +
© + 2020-2024 SimpleX | Open-Source Project +
+
+ + + + + + + + + + \ No newline at end of file diff --git a/apps/smp-server/static/media/GilroyBold.woff2 b/apps/smp-server/static/media/GilroyBold.woff2 new file mode 100644 index 000000000..687474f86 Binary files /dev/null and b/apps/smp-server/static/media/GilroyBold.woff2 differ diff --git a/apps/smp-server/static/media/GilroyLight.woff2 b/apps/smp-server/static/media/GilroyLight.woff2 new file mode 100644 index 000000000..f4d4fc3e0 Binary files /dev/null and b/apps/smp-server/static/media/GilroyLight.woff2 differ diff --git a/apps/smp-server/static/media/GilroyMedium.woff2 b/apps/smp-server/static/media/GilroyMedium.woff2 new file mode 100644 index 000000000..895b6d4f1 Binary files /dev/null and b/apps/smp-server/static/media/GilroyMedium.woff2 differ diff --git a/apps/smp-server/static/media/GilroyRegular.woff2 b/apps/smp-server/static/media/GilroyRegular.woff2 new file mode 100644 index 000000000..24465fb7d Binary files /dev/null and b/apps/smp-server/static/media/GilroyRegular.woff2 differ diff --git a/apps/smp-server/static/media/GilroyRegularItalic.woff2 b/apps/smp-server/static/media/GilroyRegularItalic.woff2 new file mode 100644 index 000000000..ef01c8d5d Binary files /dev/null and b/apps/smp-server/static/media/GilroyRegularItalic.woff2 differ diff --git a/apps/smp-server/static/media/apk_icon.png b/apps/smp-server/static/media/apk_icon.png new file mode 100644 index 000000000..60ff342d3 Binary files /dev/null and b/apps/smp-server/static/media/apk_icon.png differ diff --git a/apps/smp-server/static/media/apple_store.svg b/apps/smp-server/static/media/apple_store.svg new file mode 100644 index 000000000..b977fa2cf --- /dev/null +++ b/apps/smp-server/static/media/apple_store.svg @@ -0,0 +1,26 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/apps/smp-server/static/media/contact.js b/apps/smp-server/static/media/contact.js new file mode 100644 index 000000000..b1a99b74f --- /dev/null +++ b/apps/smp-server/static/media/contact.js @@ -0,0 +1,66 @@ +(function () { + + let complete = false + run() + window.onload = run + + async function run() { + const connURIel = document.getElementById("conn_req_uri_text"); + const mobileConnURIanchor = document.getElementById("mobile_conn_req_uri"); + const connQRCodes = document.getElementsByClassName("conn_req_uri_qrcode"); + console.log(connQRCodes); + if (complete || !connURIel || !mobileConnURIanchor || connQRCodes < 2) return + complete = true + let connURI = document.location.toString() + const parsedURI = new URL(connURI) + const path = parsedURI.pathname.split("/") + const len = path.length + const action = path[len - (path[len - 1] == "" ? 2 : 1)] + parsedURI.protocol = "https" + parsedURI.pathname = "/" + action + connURI = parsedURI.toString() + console.log("connection URI: ", connURI) + mobileConnURIanchor.href = "simplex:" + parsedURI.pathname + parsedURI.hash + connURIel.innerText = "/c " + connURI + for (const connQRCode of connQRCodes) { + try { + await QRCode.toCanvas(connQRCode, connURI, { + errorCorrectionLevel: "M", + color: {dark: "#062D56"} + }); + connQRCode.style.width = "320px"; + connQRCode.style.height = "320px"; + } catch (err) { + console.error(err); + } + } + + function contentCopyWithTooltip(parent) { + const content = parent.querySelector(".content"); + const tooltip = parent.querySelector(".tooltiptext"); + console.log(parent.querySelector(".content_copy"), 111) + console.log(parent) + const copyButton = parent.querySelector(".content_copy"); + copyButton.addEventListener("click", copyAddress) + copyButton.addEventListener("mouseout", resetTooltip) + + function copyAddress() { + navigator.clipboard.writeText(content.innerText || content.value); + tooltip.innerHTML = "Copied!"; + } + + function resetTooltip() { + tooltip.innerHTML = "Copy to clipboard"; + } + } + + function copyAddress() { + navigator.clipboard.writeText(connURI); + tooltipEl.innerHTML = "Copied!"; + } + + function resetTooltip() { + tooltipEl.innerHTML = "Copy to clipboard"; + } + } +})(); diff --git a/apps/smp-server/static/media/contact_page_mobile.png b/apps/smp-server/static/media/contact_page_mobile.png new file mode 100644 index 000000000..7d829965a Binary files /dev/null and b/apps/smp-server/static/media/contact_page_mobile.png differ diff --git a/apps/smp-server/static/media/f_droid.svg b/apps/smp-server/static/media/f_droid.svg new file mode 100644 index 000000000..2d6ec6871 --- /dev/null +++ b/apps/smp-server/static/media/f_droid.svg @@ -0,0 +1,372 @@ + + + + + + + + + + + + + GET IT ON + F-Droid + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/apps/smp-server/static/media/favicon.ico b/apps/smp-server/static/media/favicon.ico new file mode 100644 index 000000000..c45f3acf0 Binary files /dev/null and b/apps/smp-server/static/media/favicon.ico differ diff --git a/apps/smp-server/static/media/google_play.svg b/apps/smp-server/static/media/google_play.svg new file mode 100644 index 000000000..6cda5f6d3 --- /dev/null +++ b/apps/smp-server/static/media/google_play.svg @@ -0,0 +1,39 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/apps/smp-server/static/media/logo-dark.png b/apps/smp-server/static/media/logo-dark.png new file mode 100644 index 000000000..1886df819 Binary files /dev/null and b/apps/smp-server/static/media/logo-dark.png differ diff --git a/apps/smp-server/static/media/logo-light.png b/apps/smp-server/static/media/logo-light.png new file mode 100644 index 000000000..3da724650 Binary files /dev/null and b/apps/smp-server/static/media/logo-light.png differ diff --git a/apps/smp-server/static/media/logo-symbol-dark.svg b/apps/smp-server/static/media/logo-symbol-dark.svg new file mode 100644 index 000000000..fa598acf3 --- /dev/null +++ b/apps/smp-server/static/media/logo-symbol-dark.svg @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/apps/smp-server/static/media/logo-symbol-light.svg b/apps/smp-server/static/media/logo-symbol-light.svg new file mode 100644 index 000000000..d8b5951a0 --- /dev/null +++ b/apps/smp-server/static/media/logo-symbol-light.svg @@ -0,0 +1,15 @@ + + + + + + + + + + + + + + + diff --git a/apps/smp-server/static/media/moon.svg b/apps/smp-server/static/media/moon.svg new file mode 100644 index 000000000..1054735b5 --- /dev/null +++ b/apps/smp-server/static/media/moon.svg @@ -0,0 +1,3 @@ + + + diff --git a/apps/smp-server/static/media/qrcode.js b/apps/smp-server/static/media/qrcode.js new file mode 100644 index 000000000..c5c56eb37 --- /dev/null +++ b/apps/smp-server/static/media/qrcode.js @@ -0,0 +1 @@ +var QRCode=function(t){"use strict";var r,e=function(){return"function"==typeof Promise&&Promise.prototype&&Promise.prototype.then},n=[0,26,44,70,100,134,172,196,242,292,346,404,466,532,581,655,733,815,901,991,1085,1156,1258,1364,1474,1588,1706,1828,1921,2051,2185,2323,2465,2611,2761,2876,3034,3196,3362,3532,3706],o=function(t){if(!t)throw new Error('"version" cannot be null or undefined');if(t<1||t>40)throw new Error('"version" should be in range from 1 to 40');return 4*t+17},a=function(t){return n[t]},i=function(t){for(var r=0;0!==t;)r++,t>>>=1;return r},u=function(t){if("function"!=typeof t)throw new Error('"toSJISFunc" is not a valid function.');r=t},s=function(){return void 0!==r},f=function(t){return r(t)};function h(t,r){return t(r={exports:{}},r.exports),r.exports}var c=h((function(t,r){r.L={bit:1},r.M={bit:0},r.Q={bit:3},r.H={bit:2},r.isValid=function(t){return t&&void 0!==t.bit&&t.bit>=0&&t.bit<4},r.from=function(t,e){if(r.isValid(t))return t;try{return function(t){if("string"!=typeof t)throw new Error("Param is not a string");switch(t.toLowerCase()){case"l":case"low":return r.L;case"m":case"medium":return r.M;case"q":case"quartile":return r.Q;case"h":case"high":return r.H;default:throw new Error("Unknown EC Level: "+t)}}(t)}catch(t){return e}}}));function g(){this.buffer=[],this.length=0}c.L,c.M,c.Q,c.H,c.isValid,g.prototype={get:function(t){var r=Math.floor(t/8);return 1==(this.buffer[r]>>>7-t%8&1)},put:function(t,r){for(var e=0;e>>r-e-1&1))},getLengthInBits:function(){return this.length},putBit:function(t){var r=Math.floor(this.length/8);this.buffer.length<=r&&this.buffer.push(0),t&&(this.buffer[r]|=128>>>this.length%8),this.length++}};var d=g;function l(t){if(!t||t<1)throw new Error("BitMatrix size must be defined and greater than 0");this.size=t,this.data=new Uint8Array(t*t),this.reservedBit=new Uint8Array(t*t)}l.prototype.set=function(t,r,e,n){var o=t*this.size+r;this.data[o]=e,n&&(this.reservedBit[o]=!0)},l.prototype.get=function(t,r){return this.data[t*this.size+r]},l.prototype.xor=function(t,r,e){this.data[t*this.size+r]^=e},l.prototype.isReserved=function(t,r){return this.reservedBit[t*this.size+r]};var v=l,p=h((function(t,r){var e=o;r.getRowColCoords=function(t){if(1===t)return[];for(var r=Math.floor(t/7)+2,n=e(t),o=145===n?26:2*Math.ceil((n-13)/(2*r-2)),a=[n-7],i=1;i=0&&t<=7},r.from=function(t){return r.isValid(t)?parseInt(t,10):void 0},r.getPenaltyN1=function(t){for(var r=t.size,n=0,o=0,a=0,i=null,u=null,s=0;s=5&&(n+=e+(o-5)),i=h,o=1),(h=t.get(f,s))===u?a++:(a>=5&&(n+=e+(a-5)),u=h,a=1)}o>=5&&(n+=e+(o-5)),a>=5&&(n+=e+(a-5))}return n},r.getPenaltyN2=function(t){for(var r=t.size,e=0,o=0;o=10&&(1488===n||93===n)&&e++,a=a<<1&2047|t.get(u,i),u>=10&&(1488===a||93===a)&&e++}return e*o},r.getPenaltyN4=function(t){for(var r=0,e=t.data.length,n=0;n=0;){for(var n=e[0],o=0;o0){var o=new Uint8Array(this.degree);return o.set(e,n),o}return e};var L=T,b=function(t){return!isNaN(t)&&t>=1&&t<=40},U="(?:[u3000-u303F]|[u3040-u309F]|[u30A0-u30FF]|[uFF00-uFFEF]|[u4E00-u9FAF]|[u2605-u2606]|[u2190-u2195]|u203B|[u2010u2015u2018u2019u2025u2026u201Cu201Du2225u2260]|[u0391-u0451]|[u00A7u00A8u00B1u00B4u00D7u00F7])+",x="(?:(?![A-Z0-9 $%*+\\-./:]|"+(U=U.replace(/u/g,"\\u"))+")(?:.|[\r\n]))+",k=new RegExp(U,"g"),F=new RegExp("[^A-Z0-9 $%*+\\-./:]+","g"),S=new RegExp(x,"g"),D=new RegExp("[0-9]+","g"),Y=new RegExp("[A-Z $%*+\\-./:]+","g"),_=new RegExp("^"+U+"$"),z=new RegExp("^[0-9]+$"),H=new RegExp("^[A-Z0-9 $%*+\\-./:]+$"),J={KANJI:k,BYTE_KANJI:F,BYTE:S,NUMERIC:D,ALPHANUMERIC:Y,testKanji:function(t){return _.test(t)},testNumeric:function(t){return z.test(t)},testAlphanumeric:function(t){return H.test(t)}},K=h((function(t,r){r.NUMERIC={id:"Numeric",bit:1,ccBits:[10,12,14]},r.ALPHANUMERIC={id:"Alphanumeric",bit:2,ccBits:[9,11,13]},r.BYTE={id:"Byte",bit:4,ccBits:[8,16,16]},r.KANJI={id:"Kanji",bit:8,ccBits:[8,10,12]},r.MIXED={bit:-1},r.getCharCountIndicator=function(t,r){if(!t.ccBits)throw new Error("Invalid mode: "+t);if(!b(r))throw new Error("Invalid version: "+r);return r>=1&&r<10?t.ccBits[0]:r<27?t.ccBits[1]:t.ccBits[2]},r.getBestModeForData=function(t){return J.testNumeric(t)?r.NUMERIC:J.testAlphanumeric(t)?r.ALPHANUMERIC:J.testKanji(t)?r.KANJI:r.BYTE},r.toString=function(t){if(t&&t.id)return t.id;throw new Error("Invalid mode")},r.isValid=function(t){return t&&t.bit&&t.ccBits},r.from=function(t,e){if(r.isValid(t))return t;try{return function(t){if("string"!=typeof t)throw new Error("Param is not a string");switch(t.toLowerCase()){case"numeric":return r.NUMERIC;case"alphanumeric":return r.ALPHANUMERIC;case"kanji":return r.KANJI;case"byte":return r.BYTE;default:throw new Error("Unknown mode: "+t)}}(t)}catch(t){return e}}}));K.NUMERIC,K.ALPHANUMERIC,K.BYTE,K.KANJI,K.MIXED,K.getCharCountIndicator,K.getBestModeForData,K.isValid;var O=h((function(t,r){var e=i(7973);function n(t,r){return K.getCharCountIndicator(t,r)+4}function o(t,r){var e=0;return t.forEach((function(t){var o=n(t.mode,r);e+=o+t.getBitsLength()})),e}r.from=function(t,r){return b(t)?parseInt(t,10):r},r.getCapacity=function(t,r,e){if(!b(t))throw new Error("Invalid QR Code version");void 0===e&&(e=K.BYTE);var o=8*(a(t)-M(t,r));if(e===K.MIXED)return o;var i=o-n(e,t);switch(e){case K.NUMERIC:return Math.floor(i/10*3);case K.ALPHANUMERIC:return Math.floor(i/11*2);case K.KANJI:return Math.floor(i/13);case K.BYTE:default:return Math.floor(i/8)}},r.getBestVersionForData=function(t,e){var n,a=c.from(e,c.M);if(Array.isArray(t)){if(t.length>1)return function(t,e){for(var n=1;n<=40;n++){if(o(t,n)<=r.getCapacity(n,e,K.MIXED))return n}}(t,a);if(0===t.length)return 1;n=t[0]}else n=t;return function(t,e,n){for(var o=1;o<=40;o++)if(e<=r.getCapacity(o,n,t))return o}(n.mode,n.getLength(),a)},r.getEncodedBits=function(t){if(!b(t)||t<7)throw new Error("Invalid QR Code version");for(var r=t<<12;i(r)-e>=0;)r^=7973<=0;)n^=1335<0&&(e=this.data.substr(r),n=parseInt(e,10),t.put(n,3*o+1))};var j=q,$=["0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P","Q","R","S","T","U","V","W","X","Y","Z"," ","$","%","*","+","-",".","/",":"];function X(t){this.mode=K.ALPHANUMERIC,this.data=t}X.getBitsLength=function(t){return 11*Math.floor(t/2)+t%2*6},X.prototype.getLength=function(){return this.data.length},X.prototype.getBitsLength=function(){return X.getBitsLength(this.data.length)},X.prototype.write=function(t){var r;for(r=0;r+2<=this.data.length;r+=2){var e=45*$.indexOf(this.data[r]);e+=$.indexOf(this.data[r+1]),t.put(e,11)}this.data.length%2&&t.put($.indexOf(this.data[r]),6)};var Z=X;function W(t){this.mode=K.BYTE,"string"==typeof t&&(t=function(t){for(var r=[],e=t.length,n=0;n=55296&&o<=56319&&e>n+1){var a=t.charCodeAt(n+1);a>=56320&&a<=57343&&(o=1024*(o-55296)+a-56320+65536,n+=1)}o<128?r.push(o):o<2048?(r.push(o>>6|192),r.push(63&o|128)):o<55296||o>=57344&&o<65536?(r.push(o>>12|224),r.push(o>>6&63|128),r.push(63&o|128)):o>=65536&&o<=1114111?(r.push(o>>18|240),r.push(o>>12&63|128),r.push(o>>6&63|128),r.push(63&o|128)):r.push(239,191,189)}return new Uint8Array(r).buffer}(t)),this.data=new Uint8Array(t)}W.getBitsLength=function(t){return 8*t},W.prototype.getLength=function(){return this.data.length},W.prototype.getBitsLength=function(){return W.getBitsLength(this.data.length)},W.prototype.write=function(t){for(var r=0,e=this.data.length;r=33088&&e<=40956)e-=33088;else{if(!(e>=57408&&e<=60351))throw new Error("Invalid SJIS character: "+this.data[r]+"\nMake sure your charset is UTF-8");e-=49472}e=192*(e>>>8&255)+(255&e),t.put(e,13)}};var rt=tt,et=h((function(t){var r={single_source_shortest_paths:function(t,e,n){var o={},a={};a[e]=0;var i,u,s,f,h,c,g,d=r.PriorityQueue.make();for(d.push(e,0);!d.empty();)for(s in u=(i=d.pop()).value,f=i.cost,h=t[u]||{})h.hasOwnProperty(s)&&(c=f+h[s],g=a[s],(void 0===a[s]||g>c)&&(a[s]=c,d.push(s,c),o[s]=u));if(void 0!==n&&void 0===a[n]){var l=["Could not find a path from ",e," to ",n,"."].join("");throw new Error(l)}return o},extract_shortest_path_from_predecessor_list:function(t,r){for(var e=[],n=r;n;)e.push(n),n=t[n];return e.reverse(),e},find_path:function(t,e,n){var o=r.single_source_shortest_paths(t,e,n);return r.extract_shortest_path_from_predecessor_list(o,n)},PriorityQueue:{make:function(t){var e,n=r.PriorityQueue,o={};for(e in t=t||{},n)n.hasOwnProperty(e)&&(o[e]=n[e]);return o.queue=[],o.sorter=t.sorter||n.default_sorter,o},default_sorter:function(t,r){return t.cost-r.cost},push:function(t,r){var e={value:t,cost:r};this.queue.push(e),this.queue.sort(this.sorter)},pop:function(){return this.queue.shift()},empty:function(){return 0===this.queue.length}}};t.exports=r})),nt=h((function(t,r){function e(t){return unescape(encodeURIComponent(t)).length}function n(t,r,e){for(var n,o=[];null!==(n=t.exec(e));)o.push({data:n[0],index:n.index,mode:r,length:n[0].length});return o}function o(t){var r,e,o=n(J.NUMERIC,K.NUMERIC,t),a=n(J.ALPHANUMERIC,K.ALPHANUMERIC,t);return s()?(r=n(J.BYTE,K.BYTE,t),e=n(J.KANJI,K.KANJI,t)):(r=n(J.BYTE_KANJI,K.BYTE,t),e=[]),o.concat(a,r,e).sort((function(t,r){return t.index-r.index})).map((function(t){return{data:t.data,mode:t.mode,length:t.length}}))}function a(t,r){switch(r){case K.NUMERIC:return j.getBitsLength(t);case K.ALPHANUMERIC:return Z.getBitsLength(t);case K.KANJI:return rt.getBitsLength(t);case K.BYTE:return G.getBitsLength(t)}}function i(t,r){var e,n=K.getBestModeForData(t);if((e=K.from(r,n))!==K.BYTE&&e.bit=0?t[t.length-1]:null;return e&&e.mode===r.mode?(t[t.length-1].data+=r.data,t):(t.push(r),t)}),[])}(s))},r.rawSplit=function(t){return r.fromArray(o(t))}}));function ot(t,r,e){var n,o,a=t.size,i=V(r,e);for(n=0;n<15;n++)o=1==(i>>n&1),n<6?t.set(n,8,o,!0):n<8?t.set(n+1,8,o,!0):t.set(a-15+n,8,o,!0),n<8?t.set(8,a-n-1,o,!0):n<9?t.set(8,15-n-1+1,o,!0):t.set(8,15-n-1,o,!0);t.set(a-8,8,1,!0)}function at(t,r,e){var n=new d;e.forEach((function(r){n.put(r.mode.bit,4),n.put(r.getLength(),K.getCharCountIndicator(r.mode,t)),r.write(n)}));var o=8*(a(t)-M(t,r));for(n.getLengthInBits()+4<=o&&n.put(0,4);n.getLengthInBits()%8!=0;)n.putBit(0);for(var i=(o-n.getLengthInBits())/8,u=0;u=0&&u<=6&&(0===s||6===s)||s>=0&&s<=6&&(0===u||6===u)||u>=2&&u<=4&&s>=2&&s<=4?t.set(a+u,i+s,!0,!0):t.set(a+u,i+s,!1,!0))}(c,r),function(t){for(var r=t.size,e=8;e=7&&function(t,r){for(var e,n,o,a=t.size,i=O.getEncodedBits(r),u=0;u<18;u++)e=Math.floor(u/3),n=u%3+a-8-3,o=1==(i>>u&1),t.set(e,n,o,!0),t.set(n,e,o,!0)}(c,r),function(t,r){for(var e=t.size,n=-1,o=e-1,a=7,i=0,u=e-1;u>0;u-=2)for(6===u&&u--;;){for(var s=0;s<2;s++)if(!t.isReserved(o,u-s)){var f=!1;i>>a&1)),t.set(o,u-s,f),-1===--a&&(i++,a=7)}if((o+=n)<0||e<=o){o-=n,n=-n;break}}}(c,f),isNaN(n)&&(n=E.getBestMask(c,ot.bind(null,c,e))),E.applyMask(n,c),ot(c,e,n),{modules:c,version:r,errorCorrectionLevel:e,maskPattern:n,segments:a}}nt.fromArray,nt.fromString,nt.rawSplit;var ut=function(t,r){if(void 0===t||""===t)throw new Error("No input text");var e,n,o=c.M;return void 0!==r&&(o=c.from(r.errorCorrectionLevel,c.M),e=O.from(r.version),n=E.from(r.maskPattern),r.toSJISFunc&&u(r.toSJISFunc)),it(t,e,o,n)},st=h((function(t,r){function e(t){if("number"==typeof t&&(t=t.toString()),"string"!=typeof t)throw new Error("Color should be defined as hex string");var r=t.slice().replace("#","").split("");if(r.length<3||5===r.length||r.length>8)throw new Error("Invalid hex color: "+t);3!==r.length&&4!==r.length||(r=Array.prototype.concat.apply([],r.map((function(t){return[t,t]})))),6===r.length&&r.push("F","F");var e=parseInt(r.join(""),16);return{r:e>>24&255,g:e>>16&255,b:e>>8&255,a:255&e,hex:"#"+r.slice(0,6).join("")}}r.getOptions=function(t){t||(t={}),t.color||(t.color={});var r=void 0===t.margin||null===t.margin||t.margin<0?4:t.margin,n=t.width&&t.width>=21?t.width:void 0,o=t.scale||4;return{width:n,scale:n?4:o,margin:r,color:{dark:e(t.color.dark||"#000000ff"),light:e(t.color.light||"#ffffffff")},type:t.type,rendererOpts:t.rendererOpts||{}}},r.getScale=function(t,r){return r.width&&r.width>=t+2*r.margin?r.width/(t+2*r.margin):r.scale},r.getImageWidth=function(t,e){var n=r.getScale(t,e);return Math.floor((t+2*e.margin)*n)},r.qrToImageData=function(t,e,n){for(var o=e.modules.size,a=e.modules.data,i=r.getScale(o,n),u=Math.floor((o+2*n.margin)*i),s=n.margin*i,f=[n.color.light,n.color.dark],h=0;h=s&&c>=s&&h':"",s="0&&s>0&&t[u-1]||(n+=a?ct("M",s+e,.5+f+e):ct("m",o,0),o=0,a=!1),s+1',f='viewBox="0 0 '+i+" "+i+'"',h=''+u+s+"\n";return"function"==typeof e&&e(null,h),h};function dt(t,r,n,o,a){var i=[].slice.call(arguments,1),u=i.length,s="function"==typeof i[u-1];if(!s&&!e())throw new Error("Callback required as last argument");if(!s){if(u<1)throw new Error("Too few arguments provided");return 1===u?(n=r,r=o=void 0):2!==u||r.getContext||(o=n,n=r,r=void 0),new Promise((function(e,a){try{var i=ut(n,o);e(t(i,r,o))}catch(t){a(t)}}))}if(u<2)throw new Error("Too few arguments provided");2===u?(a=n,n=r,r=o=void 0):3===u&&(r.getContext&&void 0===a?(a=o,o=void 0):(a=o,o=n,n=r,r=void 0));try{var f=ut(n,o);a(null,t(f,r,o))}catch(t){a(t)}}var lt=ut,vt=dt.bind(null,ft.render),pt=dt.bind(null,ft.renderToDataURL),wt=dt.bind(null,(function(t,r,e){return gt(t,e)})),mt={create:lt,toCanvas:vt,toDataURL:pt,toString:wt};return t.create=lt,t.default=mt,t.toCanvas=vt,t.toDataURL=pt,t.toString=wt,Object.defineProperty(t,"__esModule",{value:!0}),t}({}); diff --git a/apps/smp-server/static/media/script.js b/apps/smp-server/static/media/script.js new file mode 100644 index 000000000..aa5d35293 --- /dev/null +++ b/apps/smp-server/static/media/script.js @@ -0,0 +1,39 @@ +const isMobile = { + Android: () => navigator.userAgent.match(/Android/i), + iOS: () => navigator.userAgent.match(/iPhone|iPad|iPod/i) +}; + +window.addEventListener('click', clickHandler) + +if (isMobile.iOS) { + for (const btn of document.getElementsByClassName("close-overlay-btn")) { + btn.addEventListener("touchend", (e) => setTimeout(() => closeOverlay(e), 100)) + } +} + +function clickHandler(e) { + if (e.target.closest('.contact-tab-btn')) { + e.target.closest('.contact-tab').classList.toggle('active') + } +} + +window.addEventListener('load', () => { + const googlePlayBtn = document.querySelector('.google-play-btn'); + const appleStoreBtn = document.querySelector('.apple-store-btn'); + const fDroidBtn = document.querySelector('.f-droid-btn'); + if (!googlePlayBtn || !appleStoreBtn || !fDroidBtn) return; + + + if (isMobile.Android()) { + googlePlayBtn.classList.remove('hidden'); + fDroidBtn.classList.remove('hidden'); + } + else if (isMobile.iOS()) { + appleStoreBtn.classList.remove('hidden'); + } + else { + appleStoreBtn.classList.remove('hidden'); + googlePlayBtn.classList.remove('hidden'); + fDroidBtn.classList.remove('hidden'); + } +}) diff --git a/apps/smp-server/static/media/style.css b/apps/smp-server/static/media/style.css new file mode 100644 index 000000000..e29de80f7 --- /dev/null +++ b/apps/smp-server/static/media/style.css @@ -0,0 +1,414 @@ +@font-face { + font-family: Gilroy; + src: url("GilroyRegular.woff2") format("woff2"); + font-weight: 400; + font-style: normal; +} + +@font-face { + font-family: Gilroy; + src: url("GilroyLight.woff2") format("woff2"); + font-weight: 300; + font-style: normal; +} + +@font-face { + font-family: Gilroy; + src: url("GilroyMedium.woff2") format("woff2"); + font-weight: 500; + font-style: normal; +} + +@font-face { + font-family: Gilroy; + src: url("GilroyBold.woff2") format("woff2"); + font-weight: 700; + font-style: normal; +} + +@font-face { + font-family: Gilroy; + src: url("GilroyRegularItalic.woff2") format("woff2"); + font-weight: 400; + font-style: italic; +} + +html { + scroll-behavior: smooth; + font-family: Gilroy, Helvetica, sans-serif; + ; + letter-spacing: 0.003em; +} + +img { + user-select: none; + -webkit-user-select: none; + /* For Safari and older Chrome versions */ + -moz-user-select: none; + /* For Firefox */ + -ms-user-select: none; + /* For Internet Explorer and Edge */ +} + +a{ + word-wrap: break-word; +} + +/* NEW SITE */ +.container, +.container-fluid, +.container-xxl, +.container-xl, +.container-lg, +.container-md, +.container-sm { + width: 100%; + /* padding: 0 20px; */ + margin-right: auto; + margin-left: auto; +} + +@media (min-width: 576px) { + + .container-sm, + .container { + max-width: 540px; + } +} + +@media (min-width: 768px) { + + .container-md, + .container-sm, + .container { + max-width: 720px; + } +} + +@media (min-width: 992px) { + + .container-lg, + .container-md, + .container-sm, + .container { + max-width: 960px; + } +} + +@media (min-width: 1200px) { + + .container-xl, + .container-lg, + .container-md, + .container-sm, + .container { + max-width: 1140px; + } +} + +@media (min-width: 1400px) { + + .container-xxl, + .container-xl, + .container-lg, + .container-md, + .container-sm, + .container { + max-width: 1320px; + } +} + +.gradient-text { + background: -webkit-linear-gradient(to bottom, #53C1FF -50%, #0053D0 160%); + background: linear-gradient(to bottom, #53C1FF -50%, #0053D0 160%); + -webkit-background-clip: text; + -webkit-text-fill-color: transparent; + background-clip: text; + text-fill-color: transparent; +} + +.dark .border-gradient { + background: + linear-gradient(#11182F, #11182F) padding-box, + linear-gradient(to bottom, transparent, #01F1FF 58%) border-box; + border: 1px solid transparent; +} + +.dark .only-light { + display: none; +} + +.only-dark { + display: none; +} + +.dark .only-dark { + display: inherit; +} + +.menu-link { + font-size: 16px; + line-height: 33.42px; + color: #0D0E12; +} + +.dark .menu-link { + color: #fff; +} + +.nav-link ul li a.active { + color: #0053D0; + +} + +.dark .nav-link ul li a.active { + color: #66D9E2; +} + +@media (min-width:1024px) { + + .nav-link-text, + .menu-link { + display: inline-block; + position: relative; + color: #0D0E12; + } + + .nav-link-text::before, + .active .nav-link-text::before, + .menu-link::before { + content: ""; + position: absolute; + width: 0; + height: 1px; + bottom: 0; + right: 0; + /* background-color: initial; */ + transition: width 0.25s ease-out; + } + + .menu-link::before { + background-color: #0D0E12; + } + + .dark .menu-link::before { + background-color: #fff; + } + + .active .nav-link-text::before { + width: 100%; + } + + .nav-link:hover .nav-link-text::before, + .menu-link:hover::before { + width: 100%; + left: 0; + right: auto; + } +} + + +.sub-menu { + visibility: hidden; + opacity: 0; + color: #505158; +} + +.sub-menu .no-hover { + color: #505158 !important; +} + +.dark .sub-menu, +.dark .sub-menu .no-hover { + color: #fff !important; +} + +.dark .sub-menu li:hover { + color: #66D9E2; +} + +.sub-menu li:hover { + color: #0053D0; +} + +.sub-menu { + transition: all .3s ease !important; +} + +.nav-link span svg, +header nav { + transition: all 0.5s ease; +} + +.nav-link:hover span svg { + transform: rotate(180deg); +} + +@media (min-width:1024px) { + + .nav-link:hover .sub-menu, + .nav-link:focus-within .sub-menu { + visibility: visible; + opacity: 1; + margin-top: 0; + } +} + +@media (max-width: 1024px) { + .sub-menu { + max-height: 0; + transform: translateY(-10px); + transition: all .7s ease !important; + } + + .active .sub-menu { + max-height: 600px; + transform: translateY(0px); + opacity: 1; + visibility: visible; + margin-top: 0; + } + + header nav { + visibility: hidden; + opacity: 0; + transform: translateX(100%); + } + + header nav.open { + visibility: visible; + opacity: 1; + transform: translateX(0); + } +} + +.lock-scroll { + overflow: hidden; +} + +/* hero */ +header { + transition: all .7s ease; +} + +.primary-header { + background: linear-gradient(270deg, #0053D0 35.85%, #0197FF 94.78%); + -webkit-background-clip: text; + -webkit-text-fill-color: transparent; + background-clip: text; + text-shadow: 0px 4px 74px #e9e7e2; +} + +.dark .primary-header { + background: linear-gradient(270deg, #70F0F9 100%, #70F0F9 100%); + -webkit-background-clip: text; + -webkit-text-fill-color: transparent; + background-clip: text; + text-shadow: none; +} + +.secondary-header { + color: #606c71; + text-shadow: 0px 4px 74px #e9e7e2; +} + +.dark .secondary-header { + color: #fff; + text-shadow: none; +} + +.description { + width: 31rem; +} + +p a { + color: #0053D0; + text-decoration: underline; + text-underline-offset: 2px; +} + +.dark p a { + color: #70F0F9; +} + +/* For Contact & Invitation Page */ +.primary-header-contact { + background: linear-gradient(251.16deg, #53c1ff 1.1%, #0053d0 100.82%); + -webkit-background-clip: text; + -webkit-text-fill-color: transparent; + background-clip: text; + text-shadow: 0px 4px 74px #e9e7e2; +} + +.dark .primary-header-contact { + background: linear-gradient(270deg, #70F0F9 100%, #70F0F9 100%); + -webkit-background-clip: text; + -webkit-text-fill-color: transparent; + background-clip: text; + text-shadow: none; +} + +.secondary-header-contact { + text-shadow: 0px 4px 74px #e9e7e2; +} + +.dark .secondary-header-contact { + text-shadow: none; +} + +.content_copy_with_tooltip { + background-color: #f8f8f6; + border-radius: 50px; + padding-bottom: 4px; + padding-top: 8px; + margin-top: 16px; + margin-bottom: 16px; +} + +.content_copy_with_tooltip .tooltip { + vertical-align: -6px; +} + +.content_copy_with_tooltip .content { + font-size: 15px; +} + +.contact-tab>.contact-tab-content, +.job-tab>.job-tab-content { + opacity: 0; + max-height: 0; + transition: all 0.5s ease; + visibility: hidden; + transform: translateY(10px); + overflow: hidden; +} + +.contact-tab svg, +.job-tab svg { + transform: rotate(-180deg); + transition: all .5s ease; +} + +.contact-tab.active>.contact-tab-content, +.job-tab.active>.job-tab-content { + opacity: 1; + max-height: 300px; + visibility: visible; + transform: translateY(0px); +} + +.for-tablet .contact-tab.active>.contact-tab-content, +.for-tablet .job-tab.active>.job-tab-content { + min-height: 450px; +} + +.contact-tab.active svg, +.contact-tab:hover svg, +.job-tab.active svg, +.job-tab:hover svg { + transform: rotate(0deg); +} + +.d-none-if-js-disabled { + display: none !important; +} \ No newline at end of file diff --git a/apps/smp-server/static/media/sun.svg b/apps/smp-server/static/media/sun.svg new file mode 100644 index 000000000..8407b98e5 --- /dev/null +++ b/apps/smp-server/static/media/sun.svg @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/apps/smp-server/static/media/swiper-bundle.min.css b/apps/smp-server/static/media/swiper-bundle.min.css new file mode 100644 index 000000000..916173ac0 --- /dev/null +++ b/apps/smp-server/static/media/swiper-bundle.min.css @@ -0,0 +1,13 @@ +/** + * Swiper 8.4.3 + * Most modern mobile touch slider and framework with hardware accelerated transitions + * https://swiperjs.com + * + * Copyright 2014-2022 Vladimir Kharlampidi + * + * Released under the MIT License + * + * Released on: October 6, 2022 + */ + +@font-face{font-family:swiper-icons;src:url('data:application/font-woff;charset=utf-8;base64, d09GRgABAAAAAAZgABAAAAAADAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABGRlRNAAAGRAAAABoAAAAci6qHkUdERUYAAAWgAAAAIwAAACQAYABXR1BPUwAABhQAAAAuAAAANuAY7+xHU1VCAAAFxAAAAFAAAABm2fPczU9TLzIAAAHcAAAASgAAAGBP9V5RY21hcAAAAkQAAACIAAABYt6F0cBjdnQgAAACzAAAAAQAAAAEABEBRGdhc3AAAAWYAAAACAAAAAj//wADZ2x5ZgAAAywAAADMAAAD2MHtryVoZWFkAAABbAAAADAAAAA2E2+eoWhoZWEAAAGcAAAAHwAAACQC9gDzaG10eAAAAigAAAAZAAAArgJkABFsb2NhAAAC0AAAAFoAAABaFQAUGG1heHAAAAG8AAAAHwAAACAAcABAbmFtZQAAA/gAAAE5AAACXvFdBwlwb3N0AAAFNAAAAGIAAACE5s74hXjaY2BkYGAAYpf5Hu/j+W2+MnAzMYDAzaX6QjD6/4//Bxj5GA8AuRwMYGkAPywL13jaY2BkYGA88P8Agx4j+/8fQDYfA1AEBWgDAIB2BOoAeNpjYGRgYNBh4GdgYgABEMnIABJzYNADCQAACWgAsQB42mNgYfzCOIGBlYGB0YcxjYGBwR1Kf2WQZGhhYGBiYGVmgAFGBiQQkOaawtDAoMBQxXjg/wEGPcYDDA4wNUA2CCgwsAAAO4EL6gAAeNpj2M0gyAACqxgGNWBkZ2D4/wMA+xkDdgAAAHjaY2BgYGaAYBkGRgYQiAHyGMF8FgYHIM3DwMHABGQrMOgyWDLEM1T9/w8UBfEMgLzE////P/5//f/V/xv+r4eaAAeMbAxwIUYmIMHEgKYAYjUcsDAwsLKxc3BycfPw8jEQA/gZBASFhEVExcQlJKWkZWTl5BUUlZRVVNXUNTQZBgMAAMR+E+gAEQFEAAAAKgAqACoANAA+AEgAUgBcAGYAcAB6AIQAjgCYAKIArAC2AMAAygDUAN4A6ADyAPwBBgEQARoBJAEuATgBQgFMAVYBYAFqAXQBfgGIAZIBnAGmAbIBzgHsAAB42u2NMQ6CUAyGW568x9AneYYgm4MJbhKFaExIOAVX8ApewSt4Bic4AfeAid3VOBixDxfPYEza5O+Xfi04YADggiUIULCuEJK8VhO4bSvpdnktHI5QCYtdi2sl8ZnXaHlqUrNKzdKcT8cjlq+rwZSvIVczNiezsfnP/uznmfPFBNODM2K7MTQ45YEAZqGP81AmGGcF3iPqOop0r1SPTaTbVkfUe4HXj97wYE+yNwWYxwWu4v1ugWHgo3S1XdZEVqWM7ET0cfnLGxWfkgR42o2PvWrDMBSFj/IHLaF0zKjRgdiVMwScNRAoWUoH78Y2icB/yIY09An6AH2Bdu/UB+yxopYshQiEvnvu0dURgDt8QeC8PDw7Fpji3fEA4z/PEJ6YOB5hKh4dj3EvXhxPqH/SKUY3rJ7srZ4FZnh1PMAtPhwP6fl2PMJMPDgeQ4rY8YT6Gzao0eAEA409DuggmTnFnOcSCiEiLMgxCiTI6Cq5DZUd3Qmp10vO0LaLTd2cjN4fOumlc7lUYbSQcZFkutRG7g6JKZKy0RmdLY680CDnEJ+UMkpFFe1RN7nxdVpXrC4aTtnaurOnYercZg2YVmLN/d/gczfEimrE/fs/bOuq29Zmn8tloORaXgZgGa78yO9/cnXm2BpaGvq25Dv9S4E9+5SIc9PqupJKhYFSSl47+Qcr1mYNAAAAeNptw0cKwkAAAMDZJA8Q7OUJvkLsPfZ6zFVERPy8qHh2YER+3i/BP83vIBLLySsoKimrqKqpa2hp6+jq6RsYGhmbmJqZSy0sraxtbO3sHRydnEMU4uR6yx7JJXveP7WrDycAAAAAAAH//wACeNpjYGRgYOABYhkgZgJCZgZNBkYGLQZtIJsFLMYAAAw3ALgAeNolizEKgDAQBCchRbC2sFER0YD6qVQiBCv/H9ezGI6Z5XBAw8CBK/m5iQQVauVbXLnOrMZv2oLdKFa8Pjuru2hJzGabmOSLzNMzvutpB3N42mNgZGBg4GKQYzBhYMxJLMlj4GBgAYow/P/PAJJhLM6sSoWKfWCAAwDAjgbRAAB42mNgYGBkAIIbCZo5IPrmUn0hGA0AO8EFTQAA');font-weight:400;font-style:normal}:root{--swiper-theme-color:#007aff}.swiper{margin-left:auto;margin-right:auto;position:relative;overflow:hidden;list-style:none;padding:0;z-index:1}.swiper-vertical>.swiper-wrapper{flex-direction:column}.swiper-wrapper{position:relative;width:100%;height:100%;z-index:1;display:flex;transition-property:transform;box-sizing:content-box}.swiper-android .swiper-slide,.swiper-wrapper{transform:translate3d(0px,0,0)}.swiper-pointer-events{touch-action:pan-y}.swiper-pointer-events.swiper-vertical{touch-action:pan-x}.swiper-slide{flex-shrink:0;width:100%;height:100%;position:relative;transition-property:transform}.swiper-slide-invisible-blank{visibility:hidden}.swiper-autoheight,.swiper-autoheight .swiper-slide{height:auto}.swiper-autoheight .swiper-wrapper{align-items:flex-start;transition-property:transform,height}.swiper-backface-hidden .swiper-slide{transform:translateZ(0);-webkit-backface-visibility:hidden;backface-visibility:hidden}.swiper-3d,.swiper-3d.swiper-css-mode .swiper-wrapper{perspective:1200px}.swiper-3d .swiper-cube-shadow,.swiper-3d .swiper-slide,.swiper-3d .swiper-slide-shadow,.swiper-3d .swiper-slide-shadow-bottom,.swiper-3d .swiper-slide-shadow-left,.swiper-3d .swiper-slide-shadow-right,.swiper-3d .swiper-slide-shadow-top,.swiper-3d .swiper-wrapper{transform-style:preserve-3d}.swiper-3d .swiper-slide-shadow,.swiper-3d .swiper-slide-shadow-bottom,.swiper-3d .swiper-slide-shadow-left,.swiper-3d .swiper-slide-shadow-right,.swiper-3d .swiper-slide-shadow-top{position:absolute;left:0;top:0;width:100%;height:100%;pointer-events:none;z-index:10}.swiper-3d .swiper-slide-shadow{background:rgba(0,0,0,.15)}.swiper-3d .swiper-slide-shadow-left{background-image:linear-gradient(to left,rgba(0,0,0,.5),rgba(0,0,0,0))}.swiper-3d .swiper-slide-shadow-right{background-image:linear-gradient(to right,rgba(0,0,0,.5),rgba(0,0,0,0))}.swiper-3d .swiper-slide-shadow-top{background-image:linear-gradient(to top,rgba(0,0,0,.5),rgba(0,0,0,0))}.swiper-3d .swiper-slide-shadow-bottom{background-image:linear-gradient(to bottom,rgba(0,0,0,.5),rgba(0,0,0,0))}.swiper-css-mode>.swiper-wrapper{overflow:auto;scrollbar-width:none;-ms-overflow-style:none}.swiper-css-mode>.swiper-wrapper::-webkit-scrollbar{display:none}.swiper-css-mode>.swiper-wrapper>.swiper-slide{scroll-snap-align:start start}.swiper-horizontal.swiper-css-mode>.swiper-wrapper{scroll-snap-type:x mandatory}.swiper-vertical.swiper-css-mode>.swiper-wrapper{scroll-snap-type:y mandatory}.swiper-centered>.swiper-wrapper::before{content:'';flex-shrink:0;order:9999}.swiper-centered.swiper-horizontal>.swiper-wrapper>.swiper-slide:first-child{margin-inline-start:var(--swiper-centered-offset-before)}.swiper-centered.swiper-horizontal>.swiper-wrapper::before{height:100%;min-height:1px;width:var(--swiper-centered-offset-after)}.swiper-centered.swiper-vertical>.swiper-wrapper>.swiper-slide:first-child{margin-block-start:var(--swiper-centered-offset-before)}.swiper-centered.swiper-vertical>.swiper-wrapper::before{width:100%;min-width:1px;height:var(--swiper-centered-offset-after)}.swiper-centered>.swiper-wrapper>.swiper-slide{scroll-snap-align:center center}.swiper-virtual .swiper-slide{-webkit-backface-visibility:hidden;transform:translateZ(0)}.swiper-virtual.swiper-css-mode .swiper-wrapper::after{content:'';position:absolute;left:0;top:0;pointer-events:none}.swiper-virtual.swiper-css-mode.swiper-horizontal .swiper-wrapper::after{height:1px;width:var(--swiper-virtual-size)}.swiper-virtual.swiper-css-mode.swiper-vertical .swiper-wrapper::after{width:1px;height:var(--swiper-virtual-size)}:root{--swiper-navigation-size:44px}.swiper-button-next,.swiper-button-prev{position:absolute;top:50%;width:calc(var(--swiper-navigation-size)/ 44 * 27);height:var(--swiper-navigation-size);margin-top:calc(0px - (var(--swiper-navigation-size)/ 2));z-index:10;cursor:pointer;display:flex;align-items:center;justify-content:center;color:var(--swiper-navigation-color,var(--swiper-theme-color))}.swiper-button-next.swiper-button-disabled,.swiper-button-prev.swiper-button-disabled{opacity:.35;cursor:auto;pointer-events:none}.swiper-button-next.swiper-button-hidden,.swiper-button-prev.swiper-button-hidden{opacity:0;cursor:auto;pointer-events:none}.swiper-navigation-disabled .swiper-button-next,.swiper-navigation-disabled .swiper-button-prev{display:none!important}.swiper-button-next:after,.swiper-button-prev:after{font-family:swiper-icons;font-size:var(--swiper-navigation-size);text-transform:none!important;letter-spacing:0;font-variant:initial;line-height:1}.swiper-button-prev,.swiper-rtl .swiper-button-next{left:10px;right:auto}.swiper-button-prev:after,.swiper-rtl .swiper-button-next:after{content:'prev'}.swiper-button-next,.swiper-rtl .swiper-button-prev{right:10px;left:auto}.swiper-button-next:after,.swiper-rtl .swiper-button-prev:after{content:'next'}.swiper-button-lock{display:none}.swiper-pagination{position:absolute;text-align:center;transition:.3s opacity;transform:translate3d(0,0,0);z-index:10}.swiper-pagination.swiper-pagination-hidden{opacity:0}.swiper-pagination-disabled>.swiper-pagination,.swiper-pagination.swiper-pagination-disabled{display:none!important}.swiper-horizontal>.swiper-pagination-bullets,.swiper-pagination-bullets.swiper-pagination-horizontal,.swiper-pagination-custom,.swiper-pagination-fraction{bottom:10px;left:0;width:100%}.swiper-pagination-bullets-dynamic{overflow:hidden;font-size:0}.swiper-pagination-bullets-dynamic .swiper-pagination-bullet{transform:scale(.33);position:relative}.swiper-pagination-bullets-dynamic .swiper-pagination-bullet-active{transform:scale(1)}.swiper-pagination-bullets-dynamic .swiper-pagination-bullet-active-main{transform:scale(1)}.swiper-pagination-bullets-dynamic .swiper-pagination-bullet-active-prev{transform:scale(.66)}.swiper-pagination-bullets-dynamic .swiper-pagination-bullet-active-prev-prev{transform:scale(.33)}.swiper-pagination-bullets-dynamic .swiper-pagination-bullet-active-next{transform:scale(.66)}.swiper-pagination-bullets-dynamic .swiper-pagination-bullet-active-next-next{transform:scale(.33)}.swiper-pagination-bullet{width:var(--swiper-pagination-bullet-width,var(--swiper-pagination-bullet-size,8px));height:var(--swiper-pagination-bullet-height,var(--swiper-pagination-bullet-size,8px));display:inline-block;border-radius:50%;background:var(--swiper-pagination-bullet-inactive-color,#000);opacity:var(--swiper-pagination-bullet-inactive-opacity, .2)}button.swiper-pagination-bullet{border:none;margin:0;padding:0;box-shadow:none;-webkit-appearance:none;appearance:none}.swiper-pagination-clickable .swiper-pagination-bullet{cursor:pointer}.swiper-pagination-bullet:only-child{display:none!important}.swiper-pagination-bullet-active{opacity:var(--swiper-pagination-bullet-opacity, 1);background:var(--swiper-pagination-color,var(--swiper-theme-color))}.swiper-pagination-vertical.swiper-pagination-bullets,.swiper-vertical>.swiper-pagination-bullets{right:10px;top:50%;transform:translate3d(0px,-50%,0)}.swiper-pagination-vertical.swiper-pagination-bullets .swiper-pagination-bullet,.swiper-vertical>.swiper-pagination-bullets .swiper-pagination-bullet{margin:var(--swiper-pagination-bullet-vertical-gap,6px) 0;display:block}.swiper-pagination-vertical.swiper-pagination-bullets.swiper-pagination-bullets-dynamic,.swiper-vertical>.swiper-pagination-bullets.swiper-pagination-bullets-dynamic{top:50%;transform:translateY(-50%);width:8px}.swiper-pagination-vertical.swiper-pagination-bullets.swiper-pagination-bullets-dynamic .swiper-pagination-bullet,.swiper-vertical>.swiper-pagination-bullets.swiper-pagination-bullets-dynamic .swiper-pagination-bullet{display:inline-block;transition:.2s transform,.2s top}.swiper-horizontal>.swiper-pagination-bullets .swiper-pagination-bullet,.swiper-pagination-horizontal.swiper-pagination-bullets .swiper-pagination-bullet{margin:0 var(--swiper-pagination-bullet-horizontal-gap,4px)}.swiper-horizontal>.swiper-pagination-bullets.swiper-pagination-bullets-dynamic,.swiper-pagination-horizontal.swiper-pagination-bullets.swiper-pagination-bullets-dynamic{left:50%;transform:translateX(-50%);white-space:nowrap}.swiper-horizontal>.swiper-pagination-bullets.swiper-pagination-bullets-dynamic .swiper-pagination-bullet,.swiper-pagination-horizontal.swiper-pagination-bullets.swiper-pagination-bullets-dynamic .swiper-pagination-bullet{transition:.2s transform,.2s left}.swiper-horizontal.swiper-rtl>.swiper-pagination-bullets-dynamic .swiper-pagination-bullet{transition:.2s transform,.2s right}.swiper-pagination-progressbar{background:rgba(0,0,0,.25);position:absolute}.swiper-pagination-progressbar .swiper-pagination-progressbar-fill{background:var(--swiper-pagination-color,var(--swiper-theme-color));position:absolute;left:0;top:0;width:100%;height:100%;transform:scale(0);transform-origin:left top}.swiper-rtl .swiper-pagination-progressbar .swiper-pagination-progressbar-fill{transform-origin:right top}.swiper-horizontal>.swiper-pagination-progressbar,.swiper-pagination-progressbar.swiper-pagination-horizontal,.swiper-pagination-progressbar.swiper-pagination-vertical.swiper-pagination-progressbar-opposite,.swiper-vertical>.swiper-pagination-progressbar.swiper-pagination-progressbar-opposite{width:100%;height:4px;left:0;top:0}.swiper-horizontal>.swiper-pagination-progressbar.swiper-pagination-progressbar-opposite,.swiper-pagination-progressbar.swiper-pagination-horizontal.swiper-pagination-progressbar-opposite,.swiper-pagination-progressbar.swiper-pagination-vertical,.swiper-vertical>.swiper-pagination-progressbar{width:4px;height:100%;left:0;top:0}.swiper-pagination-lock{display:none}.swiper-scrollbar{border-radius:10px;position:relative;-ms-touch-action:none;background:rgba(0,0,0,.1)}.swiper-scrollbar-disabled>.swiper-scrollbar,.swiper-scrollbar.swiper-scrollbar-disabled{display:none!important}.swiper-horizontal>.swiper-scrollbar,.swiper-scrollbar.swiper-scrollbar-horizontal{position:absolute;left:1%;bottom:3px;z-index:50;height:5px;width:98%}.swiper-scrollbar.swiper-scrollbar-vertical,.swiper-vertical>.swiper-scrollbar{position:absolute;right:3px;top:1%;z-index:50;width:5px;height:98%}.swiper-scrollbar-drag{height:100%;width:100%;position:relative;background:rgba(0,0,0,.5);border-radius:10px;left:0;top:0}.swiper-scrollbar-cursor-drag{cursor:move}.swiper-scrollbar-lock{display:none}.swiper-zoom-container{width:100%;height:100%;display:flex;justify-content:center;align-items:center;text-align:center}.swiper-zoom-container>canvas,.swiper-zoom-container>img,.swiper-zoom-container>svg{max-width:100%;max-height:100%;object-fit:contain}.swiper-slide-zoomed{cursor:move}.swiper-lazy-preloader{width:42px;height:42px;position:absolute;left:50%;top:50%;margin-left:-21px;margin-top:-21px;z-index:10;transform-origin:50%;box-sizing:border-box;border:4px solid var(--swiper-preloader-color,var(--swiper-theme-color));border-radius:50%;border-top-color:transparent}.swiper-watch-progress .swiper-slide-visible .swiper-lazy-preloader,.swiper:not(.swiper-watch-progress) .swiper-lazy-preloader{animation:swiper-preloader-spin 1s infinite linear}.swiper-lazy-preloader-white{--swiper-preloader-color:#fff}.swiper-lazy-preloader-black{--swiper-preloader-color:#000}@keyframes swiper-preloader-spin{0%{transform:rotate(0deg)}100%{transform:rotate(360deg)}}.swiper .swiper-notification{position:absolute;left:0;top:0;pointer-events:none;opacity:0;z-index:-1000}.swiper-free-mode>.swiper-wrapper{transition-timing-function:ease-out;margin:0 auto}.swiper-grid>.swiper-wrapper{flex-wrap:wrap}.swiper-grid-column>.swiper-wrapper{flex-wrap:wrap;flex-direction:column}.swiper-fade.swiper-free-mode .swiper-slide{transition-timing-function:ease-out}.swiper-fade .swiper-slide{pointer-events:none;transition-property:opacity}.swiper-fade .swiper-slide .swiper-slide{pointer-events:none}.swiper-fade .swiper-slide-active,.swiper-fade .swiper-slide-active .swiper-slide-active{pointer-events:auto}.swiper-cube{overflow:visible}.swiper-cube .swiper-slide{pointer-events:none;-webkit-backface-visibility:hidden;backface-visibility:hidden;z-index:1;visibility:hidden;transform-origin:0 0;width:100%;height:100%}.swiper-cube .swiper-slide .swiper-slide{pointer-events:none}.swiper-cube.swiper-rtl .swiper-slide{transform-origin:100% 0}.swiper-cube .swiper-slide-active,.swiper-cube .swiper-slide-active .swiper-slide-active{pointer-events:auto}.swiper-cube .swiper-slide-active,.swiper-cube .swiper-slide-next,.swiper-cube .swiper-slide-next+.swiper-slide,.swiper-cube .swiper-slide-prev{pointer-events:auto;visibility:visible}.swiper-cube .swiper-slide-shadow-bottom,.swiper-cube .swiper-slide-shadow-left,.swiper-cube .swiper-slide-shadow-right,.swiper-cube .swiper-slide-shadow-top{z-index:0;-webkit-backface-visibility:hidden;backface-visibility:hidden}.swiper-cube .swiper-cube-shadow{position:absolute;left:0;bottom:0px;width:100%;height:100%;opacity:.6;z-index:0}.swiper-cube .swiper-cube-shadow:before{content:'';background:#000;position:absolute;left:0;top:0;bottom:0;right:0;filter:blur(50px)}.swiper-flip{overflow:visible}.swiper-flip .swiper-slide{pointer-events:none;-webkit-backface-visibility:hidden;backface-visibility:hidden;z-index:1}.swiper-flip .swiper-slide .swiper-slide{pointer-events:none}.swiper-flip .swiper-slide-active,.swiper-flip .swiper-slide-active .swiper-slide-active{pointer-events:auto}.swiper-flip .swiper-slide-shadow-bottom,.swiper-flip .swiper-slide-shadow-left,.swiper-flip .swiper-slide-shadow-right,.swiper-flip .swiper-slide-shadow-top{z-index:0;-webkit-backface-visibility:hidden;backface-visibility:hidden}.swiper-creative .swiper-slide{-webkit-backface-visibility:hidden;backface-visibility:hidden;overflow:hidden;transition-property:transform,opacity,height}.swiper-cards{overflow:visible}.swiper-cards .swiper-slide{transform-origin:center bottom;-webkit-backface-visibility:hidden;backface-visibility:hidden;overflow:hidden} \ No newline at end of file diff --git a/apps/smp-server/static/media/swiper-bundle.min.js b/apps/smp-server/static/media/swiper-bundle.min.js new file mode 100644 index 000000000..0c347e3e0 --- /dev/null +++ b/apps/smp-server/static/media/swiper-bundle.min.js @@ -0,0 +1,14 @@ +/** + * Swiper 8.4.3 + * Most modern mobile touch slider and framework with hardware accelerated transitions + * https://swiperjs.com + * + * Copyright 2014-2022 Vladimir Kharlampidi + * + * Released under the MIT License + * + * Released on: October 6, 2022 + */ + +!function(e,t){"object"==typeof exports&&"undefined"!=typeof module?module.exports=t():"function"==typeof define&&define.amd?define(t):(e="undefined"!=typeof globalThis?globalThis:e||self).Swiper=t()}(this,(function(){"use strict";function e(e){return null!==e&&"object"==typeof e&&"constructor"in e&&e.constructor===Object}function t(s,a){void 0===s&&(s={}),void 0===a&&(a={}),Object.keys(a).forEach((i=>{void 0===s[i]?s[i]=a[i]:e(a[i])&&e(s[i])&&Object.keys(a[i]).length>0&&t(s[i],a[i])}))}const s={body:{},addEventListener(){},removeEventListener(){},activeElement:{blur(){},nodeName:""},querySelector:()=>null,querySelectorAll:()=>[],getElementById:()=>null,createEvent:()=>({initEvent(){}}),createElement:()=>({children:[],childNodes:[],style:{},setAttribute(){},getElementsByTagName:()=>[]}),createElementNS:()=>({}),importNode:()=>null,location:{hash:"",host:"",hostname:"",href:"",origin:"",pathname:"",protocol:"",search:""}};function a(){const e="undefined"!=typeof document?document:{};return t(e,s),e}const i={document:s,navigator:{userAgent:""},location:{hash:"",host:"",hostname:"",href:"",origin:"",pathname:"",protocol:"",search:""},history:{replaceState(){},pushState(){},go(){},back(){}},CustomEvent:function(){return this},addEventListener(){},removeEventListener(){},getComputedStyle:()=>({getPropertyValue:()=>""}),Image(){},Date(){},screen:{},setTimeout(){},clearTimeout(){},matchMedia:()=>({}),requestAnimationFrame:e=>"undefined"==typeof setTimeout?(e(),null):setTimeout(e,0),cancelAnimationFrame(e){"undefined"!=typeof setTimeout&&clearTimeout(e)}};function r(){const e="undefined"!=typeof window?window:{};return t(e,i),e}class n extends Array{constructor(e){"number"==typeof e?super(e):(super(...e||[]),function(e){const t=e.__proto__;Object.defineProperty(e,"__proto__",{get:()=>t,set(e){t.__proto__=e}})}(this))}}function l(e){void 0===e&&(e=[]);const t=[];return e.forEach((e=>{Array.isArray(e)?t.push(...l(e)):t.push(e)})),t}function o(e,t){return Array.prototype.filter.call(e,t)}function d(e,t){const s=r(),i=a();let l=[];if(!t&&e instanceof n)return e;if(!e)return new n(l);if("string"==typeof e){const s=e.trim();if(s.indexOf("<")>=0&&s.indexOf(">")>=0){let e="div";0===s.indexOf("e.split(" "))));return this.forEach((e=>{e.classList.add(...a)})),this},removeClass:function(){for(var e=arguments.length,t=new Array(e),s=0;se.split(" "))));return this.forEach((e=>{e.classList.remove(...a)})),this},hasClass:function(){for(var e=arguments.length,t=new Array(e),s=0;se.split(" "))));return o(this,(e=>a.filter((t=>e.classList.contains(t))).length>0)).length>0},toggleClass:function(){for(var e=arguments.length,t=new Array(e),s=0;se.split(" "))));this.forEach((e=>{a.forEach((t=>{e.classList.toggle(t)}))}))},attr:function(e,t){if(1===arguments.length&&"string"==typeof e)return this[0]?this[0].getAttribute(e):void 0;for(let s=0;s=0;e-=1){const i=a[e];r&&i.listener===r||r&&i.listener&&i.listener.dom7proxy&&i.listener.dom7proxy===r?(s.removeEventListener(t,i.proxyListener,n),a.splice(e,1)):r||(s.removeEventListener(t,i.proxyListener,n),a.splice(e,1))}}}return this},trigger:function(){const e=r();for(var t=arguments.length,s=new Array(t),a=0;at>0)),i.dispatchEvent(t),i.dom7EventData=[],delete i.dom7EventData}}}return this},transitionEnd:function(e){const t=this;return e&&t.on("transitionend",(function s(a){a.target===this&&(e.call(this,a),t.off("transitionend",s))})),this},outerWidth:function(e){if(this.length>0){if(e){const e=this.styles();return this[0].offsetWidth+parseFloat(e.getPropertyValue("margin-right"))+parseFloat(e.getPropertyValue("margin-left"))}return this[0].offsetWidth}return null},outerHeight:function(e){if(this.length>0){if(e){const e=this.styles();return this[0].offsetHeight+parseFloat(e.getPropertyValue("margin-top"))+parseFloat(e.getPropertyValue("margin-bottom"))}return this[0].offsetHeight}return null},styles:function(){const e=r();return this[0]?e.getComputedStyle(this[0],null):{}},offset:function(){if(this.length>0){const e=r(),t=a(),s=this[0],i=s.getBoundingClientRect(),n=t.body,l=s.clientTop||n.clientTop||0,o=s.clientLeft||n.clientLeft||0,d=s===e?e.scrollY:s.scrollTop,c=s===e?e.scrollX:s.scrollLeft;return{top:i.top+d-l,left:i.left+c-o}}return null},css:function(e,t){const s=r();let a;if(1===arguments.length){if("string"!=typeof e){for(a=0;a{e.apply(t,[t,s])})),this):this},html:function(e){if(void 0===e)return this[0]?this[0].innerHTML:null;for(let t=0;tt-1)return d([]);if(e<0){const s=t+e;return d(s<0?[]:[this[s]])}return d([this[e]])},append:function(){let e;const t=a();for(let s=0;s=0;i-=1)this[s].insertBefore(a.childNodes[i],this[s].childNodes[0])}else if(e instanceof n)for(i=0;i0?e?this[0].nextElementSibling&&d(this[0].nextElementSibling).is(e)?d([this[0].nextElementSibling]):d([]):this[0].nextElementSibling?d([this[0].nextElementSibling]):d([]):d([])},nextAll:function(e){const t=[];let s=this[0];if(!s)return d([]);for(;s.nextElementSibling;){const a=s.nextElementSibling;e?d(a).is(e)&&t.push(a):t.push(a),s=a}return d(t)},prev:function(e){if(this.length>0){const t=this[0];return e?t.previousElementSibling&&d(t.previousElementSibling).is(e)?d([t.previousElementSibling]):d([]):t.previousElementSibling?d([t.previousElementSibling]):d([])}return d([])},prevAll:function(e){const t=[];let s=this[0];if(!s)return d([]);for(;s.previousElementSibling;){const a=s.previousElementSibling;e?d(a).is(e)&&t.push(a):t.push(a),s=a}return d(t)},parent:function(e){const t=[];for(let s=0;s6&&(i=i.split(", ").map((e=>e.replace(",","."))).join(", ")),n=new s.WebKitCSSMatrix("none"===i?"":i)):(n=l.MozTransform||l.OTransform||l.MsTransform||l.msTransform||l.transform||l.getPropertyValue("transform").replace("translate(","matrix(1, 0, 0, 1,"),a=n.toString().split(",")),"x"===t&&(i=s.WebKitCSSMatrix?n.m41:16===a.length?parseFloat(a[12]):parseFloat(a[4])),"y"===t&&(i=s.WebKitCSSMatrix?n.m42:16===a.length?parseFloat(a[13]):parseFloat(a[5])),i||0}function m(e){return"object"==typeof e&&null!==e&&e.constructor&&"Object"===Object.prototype.toString.call(e).slice(8,-1)}function f(e){return"undefined"!=typeof window&&void 0!==window.HTMLElement?e instanceof HTMLElement:e&&(1===e.nodeType||11===e.nodeType)}function g(){const e=Object(arguments.length<=0?void 0:arguments[0]),t=["__proto__","constructor","prototype"];for(let s=1;st.indexOf(e)<0));for(let t=0,i=s.length;tn?"next":"prev",p=(e,t)=>"next"===c&&e>=t||"prev"===c&&e<=t,u=()=>{l=(new Date).getTime(),null===o&&(o=l);const e=Math.max(Math.min((l-o)/d,1),0),r=.5-Math.cos(e*Math.PI)/2;let c=n+r*(s-n);if(p(c,s)&&(c=s),t.wrapperEl.scrollTo({[a]:c}),p(c,s))return t.wrapperEl.style.overflow="hidden",t.wrapperEl.style.scrollSnapType="",setTimeout((()=>{t.wrapperEl.style.overflow="",t.wrapperEl.scrollTo({[a]:c})})),void i.cancelAnimationFrame(t.cssModeFrameID);t.cssModeFrameID=i.requestAnimationFrame(u)};u()}let b,x,y;function E(){return b||(b=function(){const e=r(),t=a();return{smoothScroll:t.documentElement&&"scrollBehavior"in t.documentElement.style,touch:!!("ontouchstart"in e||e.DocumentTouch&&t instanceof e.DocumentTouch),passiveListener:function(){let t=!1;try{const s=Object.defineProperty({},"passive",{get(){t=!0}});e.addEventListener("testPassiveListener",null,s)}catch(e){}return t}(),gestures:"ongesturestart"in e}}()),b}function C(e){return void 0===e&&(e={}),x||(x=function(e){let{userAgent:t}=void 0===e?{}:e;const s=E(),a=r(),i=a.navigator.platform,n=t||a.navigator.userAgent,l={ios:!1,android:!1},o=a.screen.width,d=a.screen.height,c=n.match(/(Android);?[\s\/]+([\d.]+)?/);let p=n.match(/(iPad).*OS\s([\d_]+)/);const u=n.match(/(iPod)(.*OS\s([\d_]+))?/),h=!p&&n.match(/(iPhone\sOS|iOS)\s([\d_]+)/),m="Win32"===i;let f="MacIntel"===i;return!p&&f&&s.touch&&["1024x1366","1366x1024","834x1194","1194x834","834x1112","1112x834","768x1024","1024x768","820x1180","1180x820","810x1080","1080x810"].indexOf(`${o}x${d}`)>=0&&(p=n.match(/(Version)\/([\d.]+)/),p||(p=[0,1,"13_0_0"]),f=!1),c&&!m&&(l.os="android",l.android=!0),(p||h||u)&&(l.os="ios",l.ios=!0),l}(e)),x}function T(){return y||(y=function(){const e=r();return{isSafari:function(){const t=e.navigator.userAgent.toLowerCase();return t.indexOf("safari")>=0&&t.indexOf("chrome")<0&&t.indexOf("android")<0}(),isWebView:/(iPhone|iPod|iPad).*AppleWebKit(?!.*Safari)/i.test(e.navigator.userAgent)}}()),y}Object.keys(c).forEach((e=>{Object.defineProperty(d.fn,e,{value:c[e],writable:!0})}));var $={on(e,t,s){const a=this;if(!a.eventsListeners||a.destroyed)return a;if("function"!=typeof t)return a;const i=s?"unshift":"push";return e.split(" ").forEach((e=>{a.eventsListeners[e]||(a.eventsListeners[e]=[]),a.eventsListeners[e][i](t)})),a},once(e,t,s){const a=this;if(!a.eventsListeners||a.destroyed)return a;if("function"!=typeof t)return a;function i(){a.off(e,i),i.__emitterProxy&&delete i.__emitterProxy;for(var s=arguments.length,r=new Array(s),n=0;n=0&&t.eventsAnyListeners.splice(s,1),t},off(e,t){const s=this;return!s.eventsListeners||s.destroyed?s:s.eventsListeners?(e.split(" ").forEach((e=>{void 0===t?s.eventsListeners[e]=[]:s.eventsListeners[e]&&s.eventsListeners[e].forEach(((a,i)=>{(a===t||a.__emitterProxy&&a.__emitterProxy===t)&&s.eventsListeners[e].splice(i,1)}))})),s):s},emit(){const e=this;if(!e.eventsListeners||e.destroyed)return e;if(!e.eventsListeners)return e;let t,s,a;for(var i=arguments.length,r=new Array(i),n=0;n{e.eventsAnyListeners&&e.eventsAnyListeners.length&&e.eventsAnyListeners.forEach((e=>{e.apply(a,[t,...s])})),e.eventsListeners&&e.eventsListeners[t]&&e.eventsListeners[t].forEach((e=>{e.apply(a,s)}))})),e}};var S={updateSize:function(){const e=this;let t,s;const a=e.$el;t=void 0!==e.params.width&&null!==e.params.width?e.params.width:a[0].clientWidth,s=void 0!==e.params.height&&null!==e.params.height?e.params.height:a[0].clientHeight,0===t&&e.isHorizontal()||0===s&&e.isVertical()||(t=t-parseInt(a.css("padding-left")||0,10)-parseInt(a.css("padding-right")||0,10),s=s-parseInt(a.css("padding-top")||0,10)-parseInt(a.css("padding-bottom")||0,10),Number.isNaN(t)&&(t=0),Number.isNaN(s)&&(s=0),Object.assign(e,{width:t,height:s,size:e.isHorizontal()?t:s}))},updateSlides:function(){const e=this;function t(t){return e.isHorizontal()?t:{width:"height","margin-top":"margin-left","margin-bottom ":"margin-right","margin-left":"margin-top","margin-right":"margin-bottom","padding-left":"padding-top","padding-right":"padding-bottom",marginRight:"marginBottom"}[t]}function s(e,s){return parseFloat(e.getPropertyValue(t(s))||0)}const a=e.params,{$wrapperEl:i,size:r,rtlTranslate:n,wrongRTL:l}=e,o=e.virtual&&a.virtual.enabled,d=o?e.virtual.slides.length:e.slides.length,c=i.children(`.${e.params.slideClass}`),p=o?e.virtual.slides.length:c.length;let u=[];const h=[],m=[];let f=a.slidesOffsetBefore;"function"==typeof f&&(f=a.slidesOffsetBefore.call(e));let g=a.slidesOffsetAfter;"function"==typeof g&&(g=a.slidesOffsetAfter.call(e));const w=e.snapGrid.length,b=e.slidesGrid.length;let x=a.spaceBetween,y=-f,E=0,C=0;if(void 0===r)return;"string"==typeof x&&x.indexOf("%")>=0&&(x=parseFloat(x.replace("%",""))/100*r),e.virtualSize=-x,n?c.css({marginLeft:"",marginBottom:"",marginTop:""}):c.css({marginRight:"",marginBottom:"",marginTop:""}),a.centeredSlides&&a.cssMode&&(v(e.wrapperEl,"--swiper-centered-offset-before",""),v(e.wrapperEl,"--swiper-centered-offset-after",""));const T=a.grid&&a.grid.rows>1&&e.grid;let $;T&&e.grid.initSlides(p);const S="auto"===a.slidesPerView&&a.breakpoints&&Object.keys(a.breakpoints).filter((e=>void 0!==a.breakpoints[e].slidesPerView)).length>0;for(let i=0;i1&&u.push(e.virtualSize-r)}if(0===u.length&&(u=[0]),0!==a.spaceBetween){const s=e.isHorizontal()&&n?"marginLeft":t("marginRight");c.filter(((e,t)=>!a.cssMode||t!==c.length-1)).css({[s]:`${x}px`})}if(a.centeredSlides&&a.centeredSlidesBounds){let e=0;m.forEach((t=>{e+=t+(a.spaceBetween?a.spaceBetween:0)})),e-=a.spaceBetween;const t=e-r;u=u.map((e=>e<0?-f:e>t?t+g:e))}if(a.centerInsufficientSlides){let e=0;if(m.forEach((t=>{e+=t+(a.spaceBetween?a.spaceBetween:0)})),e-=a.spaceBetween,e{u[s]=e-t})),h.forEach(((e,s)=>{h[s]=e+t}))}}if(Object.assign(e,{slides:c,snapGrid:u,slidesGrid:h,slidesSizesGrid:m}),a.centeredSlides&&a.cssMode&&!a.centeredSlidesBounds){v(e.wrapperEl,"--swiper-centered-offset-before",-u[0]+"px"),v(e.wrapperEl,"--swiper-centered-offset-after",e.size/2-m[m.length-1]/2+"px");const t=-e.snapGrid[0],s=-e.slidesGrid[0];e.snapGrid=e.snapGrid.map((e=>e+t)),e.slidesGrid=e.slidesGrid.map((e=>e+s))}if(p!==d&&e.emit("slidesLengthChange"),u.length!==w&&(e.params.watchOverflow&&e.checkOverflow(),e.emit("snapGridLengthChange")),h.length!==b&&e.emit("slidesGridLengthChange"),a.watchSlidesProgress&&e.updateSlidesOffset(),!(o||a.cssMode||"slide"!==a.effect&&"fade"!==a.effect)){const t=`${a.containerModifierClass}backface-hidden`,s=e.$el.hasClass(t);p<=a.maxBackfaceHiddenSlides?s||e.$el.addClass(t):s&&e.$el.removeClass(t)}},updateAutoHeight:function(e){const t=this,s=[],a=t.virtual&&t.params.virtual.enabled;let i,r=0;"number"==typeof e?t.setTransition(e):!0===e&&t.setTransition(t.params.speed);const n=e=>a?t.slides.filter((t=>parseInt(t.getAttribute("data-swiper-slide-index"),10)===e))[0]:t.slides.eq(e)[0];if("auto"!==t.params.slidesPerView&&t.params.slidesPerView>1)if(t.params.centeredSlides)(t.visibleSlides||d([])).each((e=>{s.push(e)}));else for(i=0;it.slides.length&&!a)break;s.push(n(e))}else s.push(n(t.activeIndex));for(i=0;ir?e:r}(r||0===r)&&t.$wrapperEl.css("height",`${r}px`)},updateSlidesOffset:function(){const e=this,t=e.slides;for(let s=0;s=0&&p1&&u<=t.size||p<=0&&u>=t.size)&&(t.visibleSlides.push(l),t.visibleSlidesIndexes.push(e),a.eq(e).addClass(s.slideVisibleClass)),l.progress=i?-d:d,l.originalProgress=i?-c:c}t.visibleSlides=d(t.visibleSlides)},updateProgress:function(e){const t=this;if(void 0===e){const s=t.rtlTranslate?-1:1;e=t&&t.translate&&t.translate*s||0}const s=t.params,a=t.maxTranslate()-t.minTranslate();let{progress:i,isBeginning:r,isEnd:n}=t;const l=r,o=n;0===a?(i=0,r=!0,n=!0):(i=(e-t.minTranslate())/a,r=i<=0,n=i>=1),Object.assign(t,{progress:i,isBeginning:r,isEnd:n}),(s.watchSlidesProgress||s.centeredSlides&&s.autoHeight)&&t.updateSlidesProgress(e),r&&!l&&t.emit("reachBeginning toEdge"),n&&!o&&t.emit("reachEnd toEdge"),(l&&!r||o&&!n)&&t.emit("fromEdge"),t.emit("progress",i)},updateSlidesClasses:function(){const e=this,{slides:t,params:s,$wrapperEl:a,activeIndex:i,realIndex:r}=e,n=e.virtual&&s.virtual.enabled;let l;t.removeClass(`${s.slideActiveClass} ${s.slideNextClass} ${s.slidePrevClass} ${s.slideDuplicateActiveClass} ${s.slideDuplicateNextClass} ${s.slideDuplicatePrevClass}`),l=n?e.$wrapperEl.find(`.${s.slideClass}[data-swiper-slide-index="${i}"]`):t.eq(i),l.addClass(s.slideActiveClass),s.loop&&(l.hasClass(s.slideDuplicateClass)?a.children(`.${s.slideClass}:not(.${s.slideDuplicateClass})[data-swiper-slide-index="${r}"]`).addClass(s.slideDuplicateActiveClass):a.children(`.${s.slideClass}.${s.slideDuplicateClass}[data-swiper-slide-index="${r}"]`).addClass(s.slideDuplicateActiveClass));let o=l.nextAll(`.${s.slideClass}`).eq(0).addClass(s.slideNextClass);s.loop&&0===o.length&&(o=t.eq(0),o.addClass(s.slideNextClass));let d=l.prevAll(`.${s.slideClass}`).eq(0).addClass(s.slidePrevClass);s.loop&&0===d.length&&(d=t.eq(-1),d.addClass(s.slidePrevClass)),s.loop&&(o.hasClass(s.slideDuplicateClass)?a.children(`.${s.slideClass}:not(.${s.slideDuplicateClass})[data-swiper-slide-index="${o.attr("data-swiper-slide-index")}"]`).addClass(s.slideDuplicateNextClass):a.children(`.${s.slideClass}.${s.slideDuplicateClass}[data-swiper-slide-index="${o.attr("data-swiper-slide-index")}"]`).addClass(s.slideDuplicateNextClass),d.hasClass(s.slideDuplicateClass)?a.children(`.${s.slideClass}:not(.${s.slideDuplicateClass})[data-swiper-slide-index="${d.attr("data-swiper-slide-index")}"]`).addClass(s.slideDuplicatePrevClass):a.children(`.${s.slideClass}.${s.slideDuplicateClass}[data-swiper-slide-index="${d.attr("data-swiper-slide-index")}"]`).addClass(s.slideDuplicatePrevClass)),e.emitSlidesClasses()},updateActiveIndex:function(e){const t=this,s=t.rtlTranslate?t.translate:-t.translate,{slidesGrid:a,snapGrid:i,params:r,activeIndex:n,realIndex:l,snapIndex:o}=t;let d,c=e;if(void 0===c){for(let e=0;e=a[e]&&s=a[e]&&s=a[e]&&(c=e);r.normalizeSlideIndex&&(c<0||void 0===c)&&(c=0)}if(i.indexOf(s)>=0)d=i.indexOf(s);else{const e=Math.min(r.slidesPerGroupSkip,c);d=e+Math.floor((c-e)/r.slidesPerGroup)}if(d>=i.length&&(d=i.length-1),c===n)return void(d!==o&&(t.snapIndex=d,t.emit("snapIndexChange")));const p=parseInt(t.slides.eq(c).attr("data-swiper-slide-index")||c,10);Object.assign(t,{snapIndex:d,realIndex:p,previousIndex:n,activeIndex:c}),t.emit("activeIndexChange"),t.emit("snapIndexChange"),l!==p&&t.emit("realIndexChange"),(t.initialized||t.params.runCallbacksOnInit)&&t.emit("slideChange")},updateClickedSlide:function(e){const t=this,s=t.params,a=d(e).closest(`.${s.slideClass}`)[0];let i,r=!1;if(a)for(let e=0;eo?o:a&&en?"next":r=o.length&&(g=o.length-1);const v=-o[g];if(l.normalizeSlideIndex)for(let e=0;e=s&&t=s&&t=s&&(n=e)}if(r.initialized&&n!==p){if(!r.allowSlideNext&&vr.translate&&v>r.maxTranslate()&&(p||0)!==n)return!1}let b;if(n!==(c||0)&&s&&r.emit("beforeSlideChangeStart"),r.updateProgress(v),b=n>p?"next":n{r.wrapperEl.style.scrollSnapType="",r._swiperImmediateVirtual=!1}))}else{if(!r.support.smoothScroll)return w({swiper:r,targetPosition:s,side:e?"left":"top"}),!0;h.scrollTo({[e?"left":"top"]:s,behavior:"smooth"})}return!0}return r.setTransition(t),r.setTranslate(v),r.updateActiveIndex(n),r.updateSlidesClasses(),r.emit("beforeTransitionStart",t,a),r.transitionStart(s,b),0===t?r.transitionEnd(s,b):r.animating||(r.animating=!0,r.onSlideToWrapperTransitionEnd||(r.onSlideToWrapperTransitionEnd=function(e){r&&!r.destroyed&&e.target===this&&(r.$wrapperEl[0].removeEventListener("transitionend",r.onSlideToWrapperTransitionEnd),r.$wrapperEl[0].removeEventListener("webkitTransitionEnd",r.onSlideToWrapperTransitionEnd),r.onSlideToWrapperTransitionEnd=null,delete r.onSlideToWrapperTransitionEnd,r.transitionEnd(s,b))}),r.$wrapperEl[0].addEventListener("transitionend",r.onSlideToWrapperTransitionEnd),r.$wrapperEl[0].addEventListener("webkitTransitionEnd",r.onSlideToWrapperTransitionEnd)),!0},slideToLoop:function(e,t,s,a){if(void 0===e&&(e=0),void 0===t&&(t=this.params.speed),void 0===s&&(s=!0),"string"==typeof e){const t=parseInt(e,10);if(!isFinite(t))throw new Error(`The passed-in 'index' (string) couldn't be converted to 'number'. [${e}] given.`);e=t}const i=this;let r=e;return i.params.loop&&(r+=i.loopedSlides),i.slideTo(r,t,s,a)},slideNext:function(e,t,s){void 0===e&&(e=this.params.speed),void 0===t&&(t=!0);const a=this,{animating:i,enabled:r,params:n}=a;if(!r)return a;let l=n.slidesPerGroup;"auto"===n.slidesPerView&&1===n.slidesPerGroup&&n.slidesPerGroupAuto&&(l=Math.max(a.slidesPerViewDynamic("current",!0),1));const o=a.activeIndexc(e)));let h=n[u.indexOf(p)-1];if(void 0===h&&i.cssMode){let e;n.forEach(((t,s)=>{p>=t&&(e=s)})),void 0!==e&&(h=n[e>0?e-1:e])}let m=0;if(void 0!==h&&(m=l.indexOf(h),m<0&&(m=a.activeIndex-1),"auto"===i.slidesPerView&&1===i.slidesPerGroup&&i.slidesPerGroupAuto&&(m=m-a.slidesPerViewDynamic("previous",!0)+1,m=Math.max(m,0))),i.rewind&&a.isBeginning){const i=a.params.virtual&&a.params.virtual.enabled&&a.virtual?a.virtual.slides.length-1:a.slides.length-1;return a.slideTo(i,e,t,s)}return a.slideTo(m,e,t,s)},slideReset:function(e,t,s){return void 0===e&&(e=this.params.speed),void 0===t&&(t=!0),this.slideTo(this.activeIndex,e,t,s)},slideToClosest:function(e,t,s,a){void 0===e&&(e=this.params.speed),void 0===t&&(t=!0),void 0===a&&(a=.5);const i=this;let r=i.activeIndex;const n=Math.min(i.params.slidesPerGroupSkip,r),l=n+Math.floor((r-n)/i.params.slidesPerGroup),o=i.rtlTranslate?i.translate:-i.translate;if(o>=i.snapGrid[l]){const e=i.snapGrid[l];o-e>(i.snapGrid[l+1]-e)*a&&(r+=i.params.slidesPerGroup)}else{const e=i.snapGrid[l-1];o-e<=(i.snapGrid[l]-e)*a&&(r-=i.params.slidesPerGroup)}return r=Math.max(r,0),r=Math.min(r,i.slidesGrid.length-1),i.slideTo(r,e,t,s)},slideToClickedSlide:function(){const e=this,{params:t,$wrapperEl:s}=e,a="auto"===t.slidesPerView?e.slidesPerViewDynamic():t.slidesPerView;let i,r=e.clickedIndex;if(t.loop){if(e.animating)return;i=parseInt(d(e.clickedSlide).attr("data-swiper-slide-index"),10),t.centeredSlides?re.slides.length-e.loopedSlides+a/2?(e.loopFix(),r=s.children(`.${t.slideClass}[data-swiper-slide-index="${i}"]:not(.${t.slideDuplicateClass})`).eq(0).index(),p((()=>{e.slideTo(r)}))):e.slideTo(r):r>e.slides.length-a?(e.loopFix(),r=s.children(`.${t.slideClass}[data-swiper-slide-index="${i}"]:not(.${t.slideDuplicateClass})`).eq(0).index(),p((()=>{e.slideTo(r)}))):e.slideTo(r)}else e.slideTo(r)}};var z={loopCreate:function(){const e=this,t=a(),{params:s,$wrapperEl:i}=e,r=i.children().length>0?d(i.children()[0].parentNode):i;r.children(`.${s.slideClass}.${s.slideDuplicateClass}`).remove();let n=r.children(`.${s.slideClass}`);if(s.loopFillGroupWithBlank){const e=s.slidesPerGroup-n.length%s.slidesPerGroup;if(e!==s.slidesPerGroup){for(let a=0;an.length&&e.params.loopedSlidesLimit&&(e.loopedSlides=n.length);const l=[],o=[];n.each(((e,t)=>{d(e).attr("data-swiper-slide-index",t)}));for(let t=0;t=0;e-=1)r.prepend(d(l[e].cloneNode(!0)).addClass(s.slideDuplicateClass))},loopFix:function(){const e=this;e.emit("beforeLoopFix");const{activeIndex:t,slides:s,loopedSlides:a,allowSlidePrev:i,allowSlideNext:r,snapGrid:n,rtlTranslate:l}=e;let o;e.allowSlidePrev=!0,e.allowSlideNext=!0;const d=-n[t]-e.getTranslate();if(t=s.length-a){o=-s.length+t+a,o+=a;e.slideTo(o,0,!1,!0)&&0!==d&&e.setTranslate((l?-e.translate:e.translate)-d)}e.allowSlidePrev=i,e.allowSlideNext=r,e.emit("loopFix")},loopDestroy:function(){const{$wrapperEl:e,params:t,slides:s}=this;e.children(`.${t.slideClass}.${t.slideDuplicateClass},.${t.slideClass}.${t.slideBlankClass}`).remove(),s.removeAttr("data-swiper-slide-index")}};function L(e){const t=this,s=a(),i=r(),n=t.touchEventsData,{params:l,touches:o,enabled:c}=t;if(!c)return;if(t.animating&&l.preventInteractionOnTransition)return;!t.animating&&l.cssMode&&l.loop&&t.loopFix();let p=e;p.originalEvent&&(p=p.originalEvent);let h=d(p.target);if("wrapper"===l.touchEventsTarget&&!h.closest(t.wrapperEl).length)return;if(n.isTouchEvent="touchstart"===p.type,!n.isTouchEvent&&"which"in p&&3===p.which)return;if(!n.isTouchEvent&&"button"in p&&p.button>0)return;if(n.isTouched&&n.isMoved)return;const m=!!l.noSwipingClass&&""!==l.noSwipingClass,f=e.composedPath?e.composedPath():e.path;m&&p.target&&p.target.shadowRoot&&f&&(h=d(f[0]));const g=l.noSwipingSelector?l.noSwipingSelector:`.${l.noSwipingClass}`,v=!(!p.target||!p.target.shadowRoot);if(l.noSwiping&&(v?function(e,t){return void 0===t&&(t=this),function t(s){if(!s||s===a()||s===r())return null;s.assignedSlot&&(s=s.assignedSlot);const i=s.closest(e);return i||s.getRootNode?i||t(s.getRootNode().host):null}(t)}(g,h[0]):h.closest(g)[0]))return void(t.allowClick=!0);if(l.swipeHandler&&!h.closest(l.swipeHandler)[0])return;o.currentX="touchstart"===p.type?p.targetTouches[0].pageX:p.pageX,o.currentY="touchstart"===p.type?p.targetTouches[0].pageY:p.pageY;const w=o.currentX,b=o.currentY,x=l.edgeSwipeDetection||l.iOSEdgeSwipeDetection,y=l.edgeSwipeThreshold||l.iOSEdgeSwipeThreshold;if(x&&(w<=y||w>=i.innerWidth-y)){if("prevent"!==x)return;e.preventDefault()}if(Object.assign(n,{isTouched:!0,isMoved:!1,allowTouchCallbacks:!0,isScrolling:void 0,startMoving:void 0}),o.startX=w,o.startY=b,n.touchStartTime=u(),t.allowClick=!0,t.updateSize(),t.swipeDirection=void 0,l.threshold>0&&(n.allowThresholdMove=!1),"touchstart"!==p.type){let e=!0;h.is(n.focusableElements)&&(e=!1,"SELECT"===h[0].nodeName&&(n.isTouched=!1)),s.activeElement&&d(s.activeElement).is(n.focusableElements)&&s.activeElement!==h[0]&&s.activeElement.blur();const a=e&&t.allowTouchMove&&l.touchStartPreventDefault;!l.touchStartForcePreventDefault&&!a||h[0].isContentEditable||p.preventDefault()}t.params.freeMode&&t.params.freeMode.enabled&&t.freeMode&&t.animating&&!l.cssMode&&t.freeMode.onTouchStart(),t.emit("touchStart",p)}function O(e){const t=a(),s=this,i=s.touchEventsData,{params:r,touches:n,rtlTranslate:l,enabled:o}=s;if(!o)return;let c=e;if(c.originalEvent&&(c=c.originalEvent),!i.isTouched)return void(i.startMoving&&i.isScrolling&&s.emit("touchMoveOpposite",c));if(i.isTouchEvent&&"touchmove"!==c.type)return;const p="touchmove"===c.type&&c.targetTouches&&(c.targetTouches[0]||c.changedTouches[0]),h="touchmove"===c.type?p.pageX:c.pageX,m="touchmove"===c.type?p.pageY:c.pageY;if(c.preventedByNestedSwiper)return n.startX=h,void(n.startY=m);if(!s.allowTouchMove)return d(c.target).is(i.focusableElements)||(s.allowClick=!1),void(i.isTouched&&(Object.assign(n,{startX:h,startY:m,currentX:h,currentY:m}),i.touchStartTime=u()));if(i.isTouchEvent&&r.touchReleaseOnEdges&&!r.loop)if(s.isVertical()){if(mn.startY&&s.translate>=s.minTranslate())return i.isTouched=!1,void(i.isMoved=!1)}else if(hn.startX&&s.translate>=s.minTranslate())return;if(i.isTouchEvent&&t.activeElement&&c.target===t.activeElement&&d(c.target).is(i.focusableElements))return i.isMoved=!0,void(s.allowClick=!1);if(i.allowTouchCallbacks&&s.emit("touchMove",c),c.targetTouches&&c.targetTouches.length>1)return;n.currentX=h,n.currentY=m;const f=n.currentX-n.startX,g=n.currentY-n.startY;if(s.params.threshold&&Math.sqrt(f**2+g**2)=25&&(e=180*Math.atan2(Math.abs(g),Math.abs(f))/Math.PI,i.isScrolling=s.isHorizontal()?e>r.touchAngle:90-e>r.touchAngle)}if(i.isScrolling&&s.emit("touchMoveOpposite",c),void 0===i.startMoving&&(n.currentX===n.startX&&n.currentY===n.startY||(i.startMoving=!0)),i.isScrolling)return void(i.isTouched=!1);if(!i.startMoving)return;s.allowClick=!1,!r.cssMode&&c.cancelable&&c.preventDefault(),r.touchMoveStopPropagation&&!r.nested&&c.stopPropagation(),i.isMoved||(r.loop&&!r.cssMode&&s.loopFix(),i.startTranslate=s.getTranslate(),s.setTransition(0),s.animating&&s.$wrapperEl.trigger("webkitTransitionEnd transitionend"),i.allowMomentumBounce=!1,!r.grabCursor||!0!==s.allowSlideNext&&!0!==s.allowSlidePrev||s.setGrabCursor(!0),s.emit("sliderFirstMove",c)),s.emit("sliderMove",c),i.isMoved=!0;let v=s.isHorizontal()?f:g;n.diff=v,v*=r.touchRatio,l&&(v=-v),s.swipeDirection=v>0?"prev":"next",i.currentTranslate=v+i.startTranslate;let w=!0,b=r.resistanceRatio;if(r.touchReleaseOnEdges&&(b=0),v>0&&i.currentTranslate>s.minTranslate()?(w=!1,r.resistance&&(i.currentTranslate=s.minTranslate()-1+(-s.minTranslate()+i.startTranslate+v)**b)):v<0&&i.currentTranslatei.startTranslate&&(i.currentTranslate=i.startTranslate),s.allowSlidePrev||s.allowSlideNext||(i.currentTranslate=i.startTranslate),r.threshold>0){if(!(Math.abs(v)>r.threshold||i.allowThresholdMove))return void(i.currentTranslate=i.startTranslate);if(!i.allowThresholdMove)return i.allowThresholdMove=!0,n.startX=n.currentX,n.startY=n.currentY,i.currentTranslate=i.startTranslate,void(n.diff=s.isHorizontal()?n.currentX-n.startX:n.currentY-n.startY)}r.followFinger&&!r.cssMode&&((r.freeMode&&r.freeMode.enabled&&s.freeMode||r.watchSlidesProgress)&&(s.updateActiveIndex(),s.updateSlidesClasses()),s.params.freeMode&&r.freeMode.enabled&&s.freeMode&&s.freeMode.onTouchMove(),s.updateProgress(i.currentTranslate),s.setTranslate(i.currentTranslate))}function I(e){const t=this,s=t.touchEventsData,{params:a,touches:i,rtlTranslate:r,slidesGrid:n,enabled:l}=t;if(!l)return;let o=e;if(o.originalEvent&&(o=o.originalEvent),s.allowTouchCallbacks&&t.emit("touchEnd",o),s.allowTouchCallbacks=!1,!s.isTouched)return s.isMoved&&a.grabCursor&&t.setGrabCursor(!1),s.isMoved=!1,void(s.startMoving=!1);a.grabCursor&&s.isMoved&&s.isTouched&&(!0===t.allowSlideNext||!0===t.allowSlidePrev)&&t.setGrabCursor(!1);const d=u(),c=d-s.touchStartTime;if(t.allowClick){const e=o.path||o.composedPath&&o.composedPath();t.updateClickedSlide(e&&e[0]||o.target),t.emit("tap click",o),c<300&&d-s.lastClickTime<300&&t.emit("doubleTap doubleClick",o)}if(s.lastClickTime=u(),p((()=>{t.destroyed||(t.allowClick=!0)})),!s.isTouched||!s.isMoved||!t.swipeDirection||0===i.diff||s.currentTranslate===s.startTranslate)return s.isTouched=!1,s.isMoved=!1,void(s.startMoving=!1);let h;if(s.isTouched=!1,s.isMoved=!1,s.startMoving=!1,h=a.followFinger?r?t.translate:-t.translate:-s.currentTranslate,a.cssMode)return;if(t.params.freeMode&&a.freeMode.enabled)return void t.freeMode.onTouchEnd({currentPos:h});let m=0,f=t.slidesSizesGrid[0];for(let e=0;e=n[e]&&h=n[e]&&(m=e,f=n[n.length-1]-n[n.length-2])}let g=null,v=null;a.rewind&&(t.isBeginning?v=t.params.virtual&&t.params.virtual.enabled&&t.virtual?t.virtual.slides.length-1:t.slides.length-1:t.isEnd&&(g=0));const w=(h-n[m])/f,b=ma.longSwipesMs){if(!a.longSwipes)return void t.slideTo(t.activeIndex);"next"===t.swipeDirection&&(w>=a.longSwipesRatio?t.slideTo(a.rewind&&t.isEnd?g:m+b):t.slideTo(m)),"prev"===t.swipeDirection&&(w>1-a.longSwipesRatio?t.slideTo(m+b):null!==v&&w<0&&Math.abs(w)>a.longSwipesRatio?t.slideTo(v):t.slideTo(m))}else{if(!a.shortSwipes)return void t.slideTo(t.activeIndex);t.navigation&&(o.target===t.navigation.nextEl||o.target===t.navigation.prevEl)?o.target===t.navigation.nextEl?t.slideTo(m+b):t.slideTo(m):("next"===t.swipeDirection&&t.slideTo(null!==g?g:m+b),"prev"===t.swipeDirection&&t.slideTo(null!==v?v:m))}}function A(){const e=this,{params:t,el:s}=e;if(s&&0===s.offsetWidth)return;t.breakpoints&&e.setBreakpoint();const{allowSlideNext:a,allowSlidePrev:i,snapGrid:r}=e;e.allowSlideNext=!0,e.allowSlidePrev=!0,e.updateSize(),e.updateSlides(),e.updateSlidesClasses(),("auto"===t.slidesPerView||t.slidesPerView>1)&&e.isEnd&&!e.isBeginning&&!e.params.centeredSlides?e.slideTo(e.slides.length-1,0,!1,!0):e.slideTo(e.activeIndex,0,!1,!0),e.autoplay&&e.autoplay.running&&e.autoplay.paused&&e.autoplay.run(),e.allowSlidePrev=i,e.allowSlideNext=a,e.params.watchOverflow&&r!==e.snapGrid&&e.checkOverflow()}function D(e){const t=this;t.enabled&&(t.allowClick||(t.params.preventClicks&&e.preventDefault(),t.params.preventClicksPropagation&&t.animating&&(e.stopPropagation(),e.stopImmediatePropagation())))}function G(){const e=this,{wrapperEl:t,rtlTranslate:s,enabled:a}=e;if(!a)return;let i;e.previousTranslate=e.translate,e.isHorizontal()?e.translate=-t.scrollLeft:e.translate=-t.scrollTop,0===e.translate&&(e.translate=0),e.updateActiveIndex(),e.updateSlidesClasses();const r=e.maxTranslate()-e.minTranslate();i=0===r?0:(e.translate-e.minTranslate())/r,i!==e.progress&&e.updateProgress(s?-e.translate:e.translate),e.emit("setTranslate",e.translate,!1)}let N=!1;function B(){}const H=(e,t)=>{const s=a(),{params:i,touchEvents:r,el:n,wrapperEl:l,device:o,support:d}=e,c=!!i.nested,p="on"===t?"addEventListener":"removeEventListener",u=t;if(d.touch){const t=!("touchstart"!==r.start||!d.passiveListener||!i.passiveListeners)&&{passive:!0,capture:!1};n[p](r.start,e.onTouchStart,t),n[p](r.move,e.onTouchMove,d.passiveListener?{passive:!1,capture:c}:c),n[p](r.end,e.onTouchEnd,t),r.cancel&&n[p](r.cancel,e.onTouchEnd,t)}else n[p](r.start,e.onTouchStart,!1),s[p](r.move,e.onTouchMove,c),s[p](r.end,e.onTouchEnd,!1);(i.preventClicks||i.preventClicksPropagation)&&n[p]("click",e.onClick,!0),i.cssMode&&l[p]("scroll",e.onScroll),i.updateOnWindowResize?e[u](o.ios||o.android?"resize orientationchange observerUpdate":"resize observerUpdate",A,!0):e[u]("observerUpdate",A,!0)};var X={attachEvents:function(){const e=this,t=a(),{params:s,support:i}=e;e.onTouchStart=L.bind(e),e.onTouchMove=O.bind(e),e.onTouchEnd=I.bind(e),s.cssMode&&(e.onScroll=G.bind(e)),e.onClick=D.bind(e),i.touch&&!N&&(t.addEventListener("touchstart",B),N=!0),H(e,"on")},detachEvents:function(){H(this,"off")}};const Y=(e,t)=>e.grid&&t.grid&&t.grid.rows>1;var R={addClasses:function(){const e=this,{classNames:t,params:s,rtl:a,$el:i,device:r,support:n}=e,l=function(e,t){const s=[];return e.forEach((e=>{"object"==typeof e?Object.keys(e).forEach((a=>{e[a]&&s.push(t+a)})):"string"==typeof e&&s.push(t+e)})),s}(["initialized",s.direction,{"pointer-events":!n.touch},{"free-mode":e.params.freeMode&&s.freeMode.enabled},{autoheight:s.autoHeight},{rtl:a},{grid:s.grid&&s.grid.rows>1},{"grid-column":s.grid&&s.grid.rows>1&&"column"===s.grid.fill},{android:r.android},{ios:r.ios},{"css-mode":s.cssMode},{centered:s.cssMode&&s.centeredSlides},{"watch-progress":s.watchSlidesProgress}],s.containerModifierClass);t.push(...l),i.addClass([...t].join(" ")),e.emitContainerClasses()},removeClasses:function(){const{$el:e,classNames:t}=this;e.removeClass(t.join(" ")),this.emitContainerClasses()}};var W={init:!0,direction:"horizontal",touchEventsTarget:"wrapper",initialSlide:0,speed:300,cssMode:!1,updateOnWindowResize:!0,resizeObserver:!0,nested:!1,createElements:!1,enabled:!0,focusableElements:"input, select, option, textarea, button, video, label",width:null,height:null,preventInteractionOnTransition:!1,userAgent:null,url:null,edgeSwipeDetection:!1,edgeSwipeThreshold:20,autoHeight:!1,setWrapperSize:!1,virtualTranslate:!1,effect:"slide",breakpoints:void 0,breakpointsBase:"window",spaceBetween:0,slidesPerView:1,slidesPerGroup:1,slidesPerGroupSkip:0,slidesPerGroupAuto:!1,centeredSlides:!1,centeredSlidesBounds:!1,slidesOffsetBefore:0,slidesOffsetAfter:0,normalizeSlideIndex:!0,centerInsufficientSlides:!1,watchOverflow:!0,roundLengths:!1,touchRatio:1,touchAngle:45,simulateTouch:!0,shortSwipes:!0,longSwipes:!0,longSwipesRatio:.5,longSwipesMs:300,followFinger:!0,allowTouchMove:!0,threshold:0,touchMoveStopPropagation:!1,touchStartPreventDefault:!0,touchStartForcePreventDefault:!1,touchReleaseOnEdges:!1,uniqueNavElements:!0,resistance:!0,resistanceRatio:.85,watchSlidesProgress:!1,grabCursor:!1,preventClicks:!0,preventClicksPropagation:!0,slideToClickedSlide:!1,preloadImages:!0,updateOnImagesReady:!0,loop:!1,loopAdditionalSlides:0,loopedSlides:null,loopedSlidesLimit:!0,loopFillGroupWithBlank:!1,loopPreventsSlide:!0,rewind:!1,allowSlidePrev:!0,allowSlideNext:!0,swipeHandler:null,noSwiping:!0,noSwipingClass:"swiper-no-swiping",noSwipingSelector:null,passiveListeners:!0,maxBackfaceHiddenSlides:10,containerModifierClass:"swiper-",slideClass:"swiper-slide",slideBlankClass:"swiper-slide-invisible-blank",slideActiveClass:"swiper-slide-active",slideDuplicateActiveClass:"swiper-slide-duplicate-active",slideVisibleClass:"swiper-slide-visible",slideDuplicateClass:"swiper-slide-duplicate",slideNextClass:"swiper-slide-next",slideDuplicateNextClass:"swiper-slide-duplicate-next",slidePrevClass:"swiper-slide-prev",slideDuplicatePrevClass:"swiper-slide-duplicate-prev",wrapperClass:"swiper-wrapper",runCallbacksOnInit:!0,_emitClasses:!1};function q(e,t){return function(s){void 0===s&&(s={});const a=Object.keys(s)[0],i=s[a];"object"==typeof i&&null!==i?(["navigation","pagination","scrollbar"].indexOf(a)>=0&&!0===e[a]&&(e[a]={auto:!0}),a in e&&"enabled"in i?(!0===e[a]&&(e[a]={enabled:!0}),"object"!=typeof e[a]||"enabled"in e[a]||(e[a].enabled=!0),e[a]||(e[a]={enabled:!1}),g(t,s)):g(t,s)):g(t,s)}}const j={eventsEmitter:$,update:S,translate:M,transition:{setTransition:function(e,t){const s=this;s.params.cssMode||s.$wrapperEl.transition(e),s.emit("setTransition",e,t)},transitionStart:function(e,t){void 0===e&&(e=!0);const s=this,{params:a}=s;a.cssMode||(a.autoHeight&&s.updateAutoHeight(),P({swiper:s,runCallbacks:e,direction:t,step:"Start"}))},transitionEnd:function(e,t){void 0===e&&(e=!0);const s=this,{params:a}=s;s.animating=!1,a.cssMode||(s.setTransition(0),P({swiper:s,runCallbacks:e,direction:t,step:"End"}))}},slide:k,loop:z,grabCursor:{setGrabCursor:function(e){const t=this;if(t.support.touch||!t.params.simulateTouch||t.params.watchOverflow&&t.isLocked||t.params.cssMode)return;const s="container"===t.params.touchEventsTarget?t.el:t.wrapperEl;s.style.cursor="move",s.style.cursor=e?"grabbing":"grab"},unsetGrabCursor:function(){const e=this;e.support.touch||e.params.watchOverflow&&e.isLocked||e.params.cssMode||(e["container"===e.params.touchEventsTarget?"el":"wrapperEl"].style.cursor="")}},events:X,breakpoints:{setBreakpoint:function(){const e=this,{activeIndex:t,initialized:s,loopedSlides:a=0,params:i,$el:r}=e,n=i.breakpoints;if(!n||n&&0===Object.keys(n).length)return;const l=e.getBreakpoint(n,e.params.breakpointsBase,e.el);if(!l||e.currentBreakpoint===l)return;const o=(l in n?n[l]:void 0)||e.originalParams,d=Y(e,i),c=Y(e,o),p=i.enabled;d&&!c?(r.removeClass(`${i.containerModifierClass}grid ${i.containerModifierClass}grid-column`),e.emitContainerClasses()):!d&&c&&(r.addClass(`${i.containerModifierClass}grid`),(o.grid.fill&&"column"===o.grid.fill||!o.grid.fill&&"column"===i.grid.fill)&&r.addClass(`${i.containerModifierClass}grid-column`),e.emitContainerClasses()),["navigation","pagination","scrollbar"].forEach((t=>{const s=i[t]&&i[t].enabled,a=o[t]&&o[t].enabled;s&&!a&&e[t].disable(),!s&&a&&e[t].enable()}));const u=o.direction&&o.direction!==i.direction,h=i.loop&&(o.slidesPerView!==i.slidesPerView||u);u&&s&&e.changeDirection(),g(e.params,o);const m=e.params.enabled;Object.assign(e,{allowTouchMove:e.params.allowTouchMove,allowSlideNext:e.params.allowSlideNext,allowSlidePrev:e.params.allowSlidePrev}),p&&!m?e.disable():!p&&m&&e.enable(),e.currentBreakpoint=l,e.emit("_beforeBreakpoint",o),h&&s&&(e.loopDestroy(),e.loopCreate(),e.updateSlides(),e.slideTo(t-a+e.loopedSlides,0,!1)),e.emit("breakpoint",o)},getBreakpoint:function(e,t,s){if(void 0===t&&(t="window"),!e||"container"===t&&!s)return;let a=!1;const i=r(),n="window"===t?i.innerHeight:s.clientHeight,l=Object.keys(e).map((e=>{if("string"==typeof e&&0===e.indexOf("@")){const t=parseFloat(e.substr(1));return{value:n*t,point:e}}return{value:e,point:e}}));l.sort(((e,t)=>parseInt(e.value,10)-parseInt(t.value,10)));for(let e=0;es}else e.isLocked=1===e.snapGrid.length;!0===s.allowSlideNext&&(e.allowSlideNext=!e.isLocked),!0===s.allowSlidePrev&&(e.allowSlidePrev=!e.isLocked),t&&t!==e.isLocked&&(e.isEnd=!1),t!==e.isLocked&&e.emit(e.isLocked?"lock":"unlock")}},classes:R,images:{loadImage:function(e,t,s,a,i,n){const l=r();let o;function c(){n&&n()}d(e).parent("picture")[0]||e.complete&&i?c():t?(o=new l.Image,o.onload=c,o.onerror=c,a&&(o.sizes=a),s&&(o.srcset=s),t&&(o.src=t)):c()},preloadImages:function(){const e=this;function t(){null!=e&&e&&!e.destroyed&&(void 0!==e.imagesLoaded&&(e.imagesLoaded+=1),e.imagesLoaded===e.imagesToLoad.length&&(e.params.updateOnImagesReady&&e.update(),e.emit("imagesReady")))}e.imagesToLoad=e.$el.find("img");for(let s=0;s1){const e=[];return d(t.el).each((s=>{const a=g({},t,{el:s});e.push(new V(a))})),e}const r=this;r.__swiper__=!0,r.support=E(),r.device=C({userAgent:t.userAgent}),r.browser=T(),r.eventsListeners={},r.eventsAnyListeners=[],r.modules=[...r.__modules__],t.modules&&Array.isArray(t.modules)&&r.modules.push(...t.modules);const n={};r.modules.forEach((e=>{e({swiper:r,extendParams:q(t,n),on:r.on.bind(r),once:r.once.bind(r),off:r.off.bind(r),emit:r.emit.bind(r)})}));const l=g({},W,n);return r.params=g({},l,_,t),r.originalParams=g({},r.params),r.passedParams=g({},t),r.params&&r.params.on&&Object.keys(r.params.on).forEach((e=>{r.on(e,r.params.on[e])})),r.params&&r.params.onAny&&r.onAny(r.params.onAny),r.$=d,Object.assign(r,{enabled:r.params.enabled,el:e,classNames:[],slides:d(),slidesGrid:[],snapGrid:[],slidesSizesGrid:[],isHorizontal:()=>"horizontal"===r.params.direction,isVertical:()=>"vertical"===r.params.direction,activeIndex:0,realIndex:0,isBeginning:!0,isEnd:!1,translate:0,previousTranslate:0,progress:0,velocity:0,animating:!1,allowSlideNext:r.params.allowSlideNext,allowSlidePrev:r.params.allowSlidePrev,touchEvents:function(){const e=["touchstart","touchmove","touchend","touchcancel"],t=["pointerdown","pointermove","pointerup"];return r.touchEventsTouch={start:e[0],move:e[1],end:e[2],cancel:e[3]},r.touchEventsDesktop={start:t[0],move:t[1],end:t[2]},r.support.touch||!r.params.simulateTouch?r.touchEventsTouch:r.touchEventsDesktop}(),touchEventsData:{isTouched:void 0,isMoved:void 0,allowTouchCallbacks:void 0,touchStartTime:void 0,isScrolling:void 0,currentTranslate:void 0,startTranslate:void 0,allowThresholdMove:void 0,focusableElements:r.params.focusableElements,lastClickTime:u(),clickTimeout:void 0,velocities:[],allowMomentumBounce:void 0,isTouchEvent:void 0,startMoving:void 0},allowClick:!0,allowTouchMove:r.params.allowTouchMove,touches:{startX:0,startY:0,currentX:0,currentY:0,diff:0},imagesToLoad:[],imagesLoaded:0}),r.emit("_swiper"),r.params.init&&r.init(),r}enable(){const e=this;e.enabled||(e.enabled=!0,e.params.grabCursor&&e.setGrabCursor(),e.emit("enable"))}disable(){const e=this;e.enabled&&(e.enabled=!1,e.params.grabCursor&&e.unsetGrabCursor(),e.emit("disable"))}setProgress(e,t){const s=this;e=Math.min(Math.max(e,0),1);const a=s.minTranslate(),i=(s.maxTranslate()-a)*e+a;s.translateTo(i,void 0===t?0:t),s.updateActiveIndex(),s.updateSlidesClasses()}emitContainerClasses(){const e=this;if(!e.params._emitClasses||!e.el)return;const t=e.el.className.split(" ").filter((t=>0===t.indexOf("swiper")||0===t.indexOf(e.params.containerModifierClass)));e.emit("_containerClasses",t.join(" "))}getSlideClasses(e){const t=this;return t.destroyed?"":e.className.split(" ").filter((e=>0===e.indexOf("swiper-slide")||0===e.indexOf(t.params.slideClass))).join(" ")}emitSlidesClasses(){const e=this;if(!e.params._emitClasses||!e.el)return;const t=[];e.slides.each((s=>{const a=e.getSlideClasses(s);t.push({slideEl:s,classNames:a}),e.emit("_slideClass",s,a)})),e.emit("_slideClasses",t)}slidesPerViewDynamic(e,t){void 0===e&&(e="current"),void 0===t&&(t=!1);const{params:s,slides:a,slidesGrid:i,slidesSizesGrid:r,size:n,activeIndex:l}=this;let o=1;if(s.centeredSlides){let e,t=a[l].swiperSlideSize;for(let s=l+1;sn&&(e=!0));for(let s=l-1;s>=0;s-=1)a[s]&&!e&&(t+=a[s].swiperSlideSize,o+=1,t>n&&(e=!0))}else if("current"===e)for(let e=l+1;e=0;e-=1){i[l]-i[e]1)&&e.isEnd&&!e.params.centeredSlides?e.slideTo(e.slides.length-1,0,!1,!0):e.slideTo(e.activeIndex,0,!1,!0),i||a()),s.watchOverflow&&t!==e.snapGrid&&e.checkOverflow(),e.emit("update")}changeDirection(e,t){void 0===t&&(t=!0);const s=this,a=s.params.direction;return e||(e="horizontal"===a?"vertical":"horizontal"),e===a||"horizontal"!==e&&"vertical"!==e||(s.$el.removeClass(`${s.params.containerModifierClass}${a}`).addClass(`${s.params.containerModifierClass}${e}`),s.emitContainerClasses(),s.params.direction=e,s.slides.each((t=>{"vertical"===e?t.style.width="":t.style.height=""})),s.emit("changeDirection"),t&&s.update()),s}changeLanguageDirection(e){const t=this;t.rtl&&"rtl"===e||!t.rtl&&"ltr"===e||(t.rtl="rtl"===e,t.rtlTranslate="horizontal"===t.params.direction&&t.rtl,t.rtl?(t.$el.addClass(`${t.params.containerModifierClass}rtl`),t.el.dir="rtl"):(t.$el.removeClass(`${t.params.containerModifierClass}rtl`),t.el.dir="ltr"),t.update())}mount(e){const t=this;if(t.mounted)return!0;const s=d(e||t.params.el);if(!(e=s[0]))return!1;e.swiper=t;const i=()=>`.${(t.params.wrapperClass||"").trim().split(" ").join(".")}`;let r=(()=>{if(e&&e.shadowRoot&&e.shadowRoot.querySelector){const t=d(e.shadowRoot.querySelector(i()));return t.children=e=>s.children(e),t}return s.children?s.children(i()):d(s).children(i())})();if(0===r.length&&t.params.createElements){const e=a().createElement("div");r=d(e),e.className=t.params.wrapperClass,s.append(e),s.children(`.${t.params.slideClass}`).each((e=>{r.append(e)}))}return Object.assign(t,{$el:s,el:e,$wrapperEl:r,wrapperEl:r[0],mounted:!0,rtl:"rtl"===e.dir.toLowerCase()||"rtl"===s.css("direction"),rtlTranslate:"horizontal"===t.params.direction&&("rtl"===e.dir.toLowerCase()||"rtl"===s.css("direction")),wrongRTL:"-webkit-box"===r.css("display")}),!0}init(e){const t=this;if(t.initialized)return t;return!1===t.mount(e)||(t.emit("beforeInit"),t.params.breakpoints&&t.setBreakpoint(),t.addClasses(),t.params.loop&&t.loopCreate(),t.updateSize(),t.updateSlides(),t.params.watchOverflow&&t.checkOverflow(),t.params.grabCursor&&t.enabled&&t.setGrabCursor(),t.params.preloadImages&&t.preloadImages(),t.params.loop?t.slideTo(t.params.initialSlide+t.loopedSlides,0,t.params.runCallbacksOnInit,!1,!0):t.slideTo(t.params.initialSlide,0,t.params.runCallbacksOnInit,!1,!0),t.attachEvents(),t.initialized=!0,t.emit("init"),t.emit("afterInit")),t}destroy(e,t){void 0===e&&(e=!0),void 0===t&&(t=!0);const s=this,{params:a,$el:i,$wrapperEl:r,slides:n}=s;return void 0===s.params||s.destroyed||(s.emit("beforeDestroy"),s.initialized=!1,s.detachEvents(),a.loop&&s.loopDestroy(),t&&(s.removeClasses(),i.removeAttr("style"),r.removeAttr("style"),n&&n.length&&n.removeClass([a.slideVisibleClass,a.slideActiveClass,a.slideNextClass,a.slidePrevClass].join(" ")).removeAttr("style").removeAttr("data-swiper-slide-index")),s.emit("destroy"),Object.keys(s.eventsListeners).forEach((e=>{s.off(e)})),!1!==e&&(s.$el[0].swiper=null,function(e){const t=e;Object.keys(t).forEach((e=>{try{t[e]=null}catch(e){}try{delete t[e]}catch(e){}}))}(s)),s.destroyed=!0),null}static extendDefaults(e){g(_,e)}static get extendedDefaults(){return _}static get defaults(){return W}static installModule(e){V.prototype.__modules__||(V.prototype.__modules__=[]);const t=V.prototype.__modules__;"function"==typeof e&&t.indexOf(e)<0&&t.push(e)}static use(e){return Array.isArray(e)?(e.forEach((e=>V.installModule(e))),V):(V.installModule(e),V)}}function F(e,t,s,i){const r=a();return e.params.createElements&&Object.keys(i).forEach((a=>{if(!s[a]&&!0===s.auto){let n=e.$el.children(`.${i[a]}`)[0];n||(n=r.createElement("div"),n.className=i[a],e.$el.append(n)),s[a]=n,t[a]=n}})),s}function U(e){return void 0===e&&(e=""),`.${e.trim().replace(/([\.:!\/])/g,"\\$1").replace(/ /g,".")}`}function K(e){const t=this,{$wrapperEl:s,params:a}=t;if(a.loop&&t.loopDestroy(),"object"==typeof e&&"length"in e)for(let t=0;t=l)return void s.appendSlide(t);let o=n>e?n+1:n;const d=[];for(let t=l-1;t>=e;t-=1){const e=s.slides.eq(t);e.remove(),d.unshift(e)}if("object"==typeof t&&"length"in t){for(let e=0;ee?n+t.length:n}else a.append(t);for(let e=0;e{if(s.params.effect!==t)return;s.classNames.push(`${s.params.containerModifierClass}${t}`),l&&l()&&s.classNames.push(`${s.params.containerModifierClass}3d`);const e=n?n():{};Object.assign(s.params,e),Object.assign(s.originalParams,e)})),a("setTranslate",(()=>{s.params.effect===t&&i()})),a("setTransition",((e,a)=>{s.params.effect===t&&r(a)})),a("transitionEnd",(()=>{if(s.params.effect===t&&o){if(!d||!d().slideShadows)return;s.slides.each((e=>{s.$(e).find(".swiper-slide-shadow-top, .swiper-slide-shadow-right, .swiper-slide-shadow-bottom, .swiper-slide-shadow-left").remove()})),o()}})),a("virtualUpdate",(()=>{s.params.effect===t&&(s.slides.length||(c=!0),requestAnimationFrame((()=>{c&&s.slides&&s.slides.length&&(i(),c=!1)})))}))}function se(e,t){return e.transformEl?t.find(e.transformEl).css({"backface-visibility":"hidden","-webkit-backface-visibility":"hidden"}):t}function ae(e){let{swiper:t,duration:s,transformEl:a,allSlides:i}=e;const{slides:r,activeIndex:n,$wrapperEl:l}=t;if(t.params.virtualTranslate&&0!==s){let e,s=!1;e=i?a?r.find(a):r:a?r.eq(n).find(a):r.eq(n),e.transitionEnd((()=>{if(s)return;if(!t||t.destroyed)return;s=!0,t.animating=!1;const e=["webkitTransitionEnd","transitionend"];for(let t=0;t`),i.append(r)),r}Object.keys(j).forEach((e=>{Object.keys(j[e]).forEach((t=>{V.prototype[t]=j[e][t]}))})),V.use([function(e){let{swiper:t,on:s,emit:a}=e;const i=r();let n=null,l=null;const o=()=>{t&&!t.destroyed&&t.initialized&&(a("beforeResize"),a("resize"))},d=()=>{t&&!t.destroyed&&t.initialized&&a("orientationchange")};s("init",(()=>{t.params.resizeObserver&&void 0!==i.ResizeObserver?t&&!t.destroyed&&t.initialized&&(n=new ResizeObserver((e=>{l=i.requestAnimationFrame((()=>{const{width:s,height:a}=t;let i=s,r=a;e.forEach((e=>{let{contentBoxSize:s,contentRect:a,target:n}=e;n&&n!==t.el||(i=a?a.width:(s[0]||s).inlineSize,r=a?a.height:(s[0]||s).blockSize)})),i===s&&r===a||o()}))})),n.observe(t.el)):(i.addEventListener("resize",o),i.addEventListener("orientationchange",d))})),s("destroy",(()=>{l&&i.cancelAnimationFrame(l),n&&n.unobserve&&t.el&&(n.unobserve(t.el),n=null),i.removeEventListener("resize",o),i.removeEventListener("orientationchange",d)}))},function(e){let{swiper:t,extendParams:s,on:a,emit:i}=e;const n=[],l=r(),o=function(e,t){void 0===t&&(t={});const s=new(l.MutationObserver||l.WebkitMutationObserver)((e=>{if(1===e.length)return void i("observerUpdate",e[0]);const t=function(){i("observerUpdate",e[0])};l.requestAnimationFrame?l.requestAnimationFrame(t):l.setTimeout(t,0)}));s.observe(e,{attributes:void 0===t.attributes||t.attributes,childList:void 0===t.childList||t.childList,characterData:void 0===t.characterData||t.characterData}),n.push(s)};s({observer:!1,observeParents:!1,observeSlideChildren:!1}),a("init",(()=>{if(t.params.observer){if(t.params.observeParents){const e=t.$el.parents();for(let t=0;t{n.forEach((e=>{e.disconnect()})),n.splice(0,n.length)}))}]);const re=[function(e){let t,{swiper:s,extendParams:a,on:i,emit:r}=e;function n(e,t){const a=s.params.virtual;if(a.cache&&s.virtual.cache[t])return s.virtual.cache[t];const i=a.renderSlide?d(a.renderSlide.call(s,e,t)):d(`
${e}
`);return i.attr("data-swiper-slide-index")||i.attr("data-swiper-slide-index",t),a.cache&&(s.virtual.cache[t]=i),i}function l(e){const{slidesPerView:t,slidesPerGroup:a,centeredSlides:i}=s.params,{addSlidesBefore:l,addSlidesAfter:o}=s.params.virtual,{from:d,to:c,slides:p,slidesGrid:u,offset:h}=s.virtual;s.params.cssMode||s.updateActiveIndex();const m=s.activeIndex||0;let f,g,v;f=s.rtlTranslate?"right":s.isHorizontal()?"left":"top",i?(g=Math.floor(t/2)+a+o,v=Math.floor(t/2)+a+l):(g=t+(a-1)+o,v=a+l);const w=Math.max((m||0)-v,0),b=Math.min((m||0)+g,p.length-1),x=(s.slidesGrid[w]||0)-(s.slidesGrid[0]||0);function y(){s.updateSlides(),s.updateProgress(),s.updateSlidesClasses(),s.lazy&&s.params.lazy.enabled&&s.lazy.load(),r("virtualUpdate")}if(Object.assign(s.virtual,{from:w,to:b,offset:x,slidesGrid:s.slidesGrid}),d===w&&c===b&&!e)return s.slidesGrid!==u&&x!==h&&s.slides.css(f,`${x}px`),s.updateProgress(),void r("virtualUpdate");if(s.params.virtual.renderExternal)return s.params.virtual.renderExternal.call(s,{offset:x,from:w,to:b,slides:function(){const e=[];for(let t=w;t<=b;t+=1)e.push(p[t]);return e}()}),void(s.params.virtual.renderExternalUpdate?y():r("virtualUpdate"));const E=[],C=[];if(e)s.$wrapperEl.find(`.${s.params.slideClass}`).remove();else for(let e=d;e<=c;e+=1)(eb)&&s.$wrapperEl.find(`.${s.params.slideClass}[data-swiper-slide-index="${e}"]`).remove();for(let t=0;t=w&&t<=b&&(void 0===c||e?C.push(t):(t>c&&C.push(t),t{s.$wrapperEl.append(n(p[e],e))})),E.sort(((e,t)=>t-e)).forEach((e=>{s.$wrapperEl.prepend(n(p[e],e))})),s.$wrapperEl.children(".swiper-slide").css(f,`${x}px`),y()}a({virtual:{enabled:!1,slides:[],cache:!0,renderSlide:null,renderExternal:null,renderExternalUpdate:!0,addSlidesBefore:0,addSlidesAfter:0}}),s.virtual={cache:{},from:void 0,to:void 0,slides:[],offset:0,slidesGrid:[]},i("beforeInit",(()=>{s.params.virtual.enabled&&(s.virtual.slides=s.params.virtual.slides,s.classNames.push(`${s.params.containerModifierClass}virtual`),s.params.watchSlidesProgress=!0,s.originalParams.watchSlidesProgress=!0,s.params.initialSlide||l())})),i("setTranslate",(()=>{s.params.virtual.enabled&&(s.params.cssMode&&!s._immediateVirtual?(clearTimeout(t),t=setTimeout((()=>{l()}),100)):l())})),i("init update resize",(()=>{s.params.virtual.enabled&&s.params.cssMode&&v(s.wrapperEl,"--swiper-virtual-size",`${s.virtualSize}px`)})),Object.assign(s.virtual,{appendSlide:function(e){if("object"==typeof e&&"length"in e)for(let t=0;t{const a=e[s],r=a.attr("data-swiper-slide-index");r&&a.attr("data-swiper-slide-index",parseInt(r,10)+i),t[parseInt(s,10)+i]=a})),s.virtual.cache=t}l(!0),s.slideTo(a,0)},removeSlide:function(e){if(null==e)return;let t=s.activeIndex;if(Array.isArray(e))for(let a=e.length-1;a>=0;a-=1)s.virtual.slides.splice(e[a],1),s.params.virtual.cache&&delete s.virtual.cache[e[a]],e[a]0&&0===t.$el.parents(`.${t.params.slideActiveClass}`).length)return;const a=t.$el,i=a[0].clientWidth,r=a[0].clientHeight,n=o.innerWidth,l=o.innerHeight,d=t.$el.offset();s&&(d.left-=t.$el[0].scrollLeft);const c=[[d.left,d.top],[d.left+i,d.top],[d.left,d.top+r],[d.left+i,d.top+r]];for(let t=0;t=0&&s[0]<=n&&s[1]>=0&&s[1]<=l){if(0===s[0]&&0===s[1])continue;e=!0}}if(!e)return}t.isHorizontal()?((d||c||p||u)&&(a.preventDefault?a.preventDefault():a.returnValue=!1),((c||u)&&!s||(d||p)&&s)&&t.slideNext(),((d||p)&&!s||(c||u)&&s)&&t.slidePrev()):((d||c||h||m)&&(a.preventDefault?a.preventDefault():a.returnValue=!1),(c||m)&&t.slideNext(),(d||h)&&t.slidePrev()),n("keyPress",i)}}function p(){t.keyboard.enabled||(d(l).on("keydown",c),t.keyboard.enabled=!0)}function u(){t.keyboard.enabled&&(d(l).off("keydown",c),t.keyboard.enabled=!1)}t.keyboard={enabled:!1},s({keyboard:{enabled:!1,onlyInViewport:!0,pageUpDown:!0}}),i("init",(()=>{t.params.keyboard.enabled&&p()})),i("destroy",(()=>{t.keyboard.enabled&&u()})),Object.assign(t.keyboard,{enable:p,disable:u})},function(e){let{swiper:t,extendParams:s,on:a,emit:i}=e;const n=r();let l;s({mousewheel:{enabled:!1,releaseOnEdges:!1,invert:!1,forceToAxis:!1,sensitivity:1,eventsTarget:"container",thresholdDelta:null,thresholdTime:null}}),t.mousewheel={enabled:!1};let o,c=u();const h=[];function m(){t.enabled&&(t.mouseEntered=!0)}function f(){t.enabled&&(t.mouseEntered=!1)}function g(e){return!(t.params.mousewheel.thresholdDelta&&e.delta=6&&u()-c<60||(e.direction<0?t.isEnd&&!t.params.loop||t.animating||(t.slideNext(),i("scroll",e.raw)):t.isBeginning&&!t.params.loop||t.animating||(t.slidePrev(),i("scroll",e.raw)),c=(new n.Date).getTime(),!1)))}function v(e){let s=e,a=!0;if(!t.enabled)return;const r=t.params.mousewheel;t.params.cssMode&&s.preventDefault();let n=t.$el;if("container"!==t.params.mousewheel.eventsTarget&&(n=d(t.params.mousewheel.eventsTarget)),!t.mouseEntered&&!n[0].contains(s.target)&&!r.releaseOnEdges)return!0;s.originalEvent&&(s=s.originalEvent);let c=0;const m=t.rtlTranslate?-1:1,f=function(e){let t=0,s=0,a=0,i=0;return"detail"in e&&(s=e.detail),"wheelDelta"in e&&(s=-e.wheelDelta/120),"wheelDeltaY"in e&&(s=-e.wheelDeltaY/120),"wheelDeltaX"in e&&(t=-e.wheelDeltaX/120),"axis"in e&&e.axis===e.HORIZONTAL_AXIS&&(t=s,s=0),a=10*t,i=10*s,"deltaY"in e&&(i=e.deltaY),"deltaX"in e&&(a=e.deltaX),e.shiftKey&&!a&&(a=i,i=0),(a||i)&&e.deltaMode&&(1===e.deltaMode?(a*=40,i*=40):(a*=800,i*=800)),a&&!t&&(t=a<1?-1:1),i&&!s&&(s=i<1?-1:1),{spinX:t,spinY:s,pixelX:a,pixelY:i}}(s);if(r.forceToAxis)if(t.isHorizontal()){if(!(Math.abs(f.pixelX)>Math.abs(f.pixelY)))return!0;c=-f.pixelX*m}else{if(!(Math.abs(f.pixelY)>Math.abs(f.pixelX)))return!0;c=-f.pixelY}else c=Math.abs(f.pixelX)>Math.abs(f.pixelY)?-f.pixelX*m:-f.pixelY;if(0===c)return!0;r.invert&&(c=-c);let v=t.getTranslate()+c*r.sensitivity;if(v>=t.minTranslate()&&(v=t.minTranslate()),v<=t.maxTranslate()&&(v=t.maxTranslate()),a=!!t.params.loop||!(v===t.minTranslate()||v===t.maxTranslate()),a&&t.params.nested&&s.stopPropagation(),t.params.freeMode&&t.params.freeMode.enabled){const e={time:u(),delta:Math.abs(c),direction:Math.sign(c)},a=o&&e.time=t.minTranslate()&&(n=t.minTranslate()),n<=t.maxTranslate()&&(n=t.maxTranslate()),t.setTransition(0),t.setTranslate(n),t.updateProgress(),t.updateActiveIndex(),t.updateSlidesClasses(),(!d&&t.isBeginning||!u&&t.isEnd)&&t.updateSlidesClasses(),t.params.freeMode.sticky){clearTimeout(l),l=void 0,h.length>=15&&h.shift();const s=h.length?h[h.length-1]:void 0,a=h[0];if(h.push(e),s&&(e.delta>s.delta||e.direction!==s.direction))h.splice(0);else if(h.length>=15&&e.time-a.time<500&&a.delta-e.delta>=1&&e.delta<=6){const s=c>0?.8:.2;o=e,h.splice(0),l=p((()=>{t.slideToClosest(t.params.speed,!0,void 0,s)}),0)}l||(l=p((()=>{o=e,h.splice(0),t.slideToClosest(t.params.speed,!0,void 0,.5)}),500))}if(a||i("scroll",s),t.params.autoplay&&t.params.autoplayDisableOnInteraction&&t.autoplay.stop(),n===t.minTranslate()||n===t.maxTranslate())return!0}}else{const s={time:u(),delta:Math.abs(c),direction:Math.sign(c),raw:e};h.length>=2&&h.shift();const a=h.length?h[h.length-1]:void 0;if(h.push(s),a?(s.direction!==a.direction||s.delta>a.delta||s.time>a.time+150)&&g(s):g(s),function(e){const s=t.params.mousewheel;if(e.direction<0){if(t.isEnd&&!t.params.loop&&s.releaseOnEdges)return!0}else if(t.isBeginning&&!t.params.loop&&s.releaseOnEdges)return!0;return!1}(s))return!0}return s.preventDefault?s.preventDefault():s.returnValue=!1,!1}function w(e){let s=t.$el;"container"!==t.params.mousewheel.eventsTarget&&(s=d(t.params.mousewheel.eventsTarget)),s[e]("mouseenter",m),s[e]("mouseleave",f),s[e]("wheel",v)}function b(){return t.params.cssMode?(t.wrapperEl.removeEventListener("wheel",v),!0):!t.mousewheel.enabled&&(w("on"),t.mousewheel.enabled=!0,!0)}function x(){return t.params.cssMode?(t.wrapperEl.addEventListener(event,v),!0):!!t.mousewheel.enabled&&(w("off"),t.mousewheel.enabled=!1,!0)}a("init",(()=>{!t.params.mousewheel.enabled&&t.params.cssMode&&x(),t.params.mousewheel.enabled&&b()})),a("destroy",(()=>{t.params.cssMode&&b(),t.mousewheel.enabled&&x()})),Object.assign(t.mousewheel,{enable:b,disable:x})},function(e){let{swiper:t,extendParams:s,on:a,emit:i}=e;function r(e){let s;return e&&(s=d(e),t.params.uniqueNavElements&&"string"==typeof e&&s.length>1&&1===t.$el.find(e).length&&(s=t.$el.find(e))),s}function n(e,s){const a=t.params.navigation;e&&e.length>0&&(e[s?"addClass":"removeClass"](a.disabledClass),e[0]&&"BUTTON"===e[0].tagName&&(e[0].disabled=s),t.params.watchOverflow&&t.enabled&&e[t.isLocked?"addClass":"removeClass"](a.lockClass))}function l(){if(t.params.loop)return;const{$nextEl:e,$prevEl:s}=t.navigation;n(s,t.isBeginning&&!t.params.rewind),n(e,t.isEnd&&!t.params.rewind)}function o(e){e.preventDefault(),(!t.isBeginning||t.params.loop||t.params.rewind)&&(t.slidePrev(),i("navigationPrev"))}function c(e){e.preventDefault(),(!t.isEnd||t.params.loop||t.params.rewind)&&(t.slideNext(),i("navigationNext"))}function p(){const e=t.params.navigation;if(t.params.navigation=F(t,t.originalParams.navigation,t.params.navigation,{nextEl:"swiper-button-next",prevEl:"swiper-button-prev"}),!e.nextEl&&!e.prevEl)return;const s=r(e.nextEl),a=r(e.prevEl);s&&s.length>0&&s.on("click",c),a&&a.length>0&&a.on("click",o),Object.assign(t.navigation,{$nextEl:s,nextEl:s&&s[0],$prevEl:a,prevEl:a&&a[0]}),t.enabled||(s&&s.addClass(e.lockClass),a&&a.addClass(e.lockClass))}function u(){const{$nextEl:e,$prevEl:s}=t.navigation;e&&e.length&&(e.off("click",c),e.removeClass(t.params.navigation.disabledClass)),s&&s.length&&(s.off("click",o),s.removeClass(t.params.navigation.disabledClass))}s({navigation:{nextEl:null,prevEl:null,hideOnClick:!1,disabledClass:"swiper-button-disabled",hiddenClass:"swiper-button-hidden",lockClass:"swiper-button-lock",navigationDisabledClass:"swiper-navigation-disabled"}}),t.navigation={nextEl:null,$nextEl:null,prevEl:null,$prevEl:null},a("init",(()=>{!1===t.params.navigation.enabled?h():(p(),l())})),a("toEdge fromEdge lock unlock",(()=>{l()})),a("destroy",(()=>{u()})),a("enable disable",(()=>{const{$nextEl:e,$prevEl:s}=t.navigation;e&&e[t.enabled?"removeClass":"addClass"](t.params.navigation.lockClass),s&&s[t.enabled?"removeClass":"addClass"](t.params.navigation.lockClass)})),a("click",((e,s)=>{const{$nextEl:a,$prevEl:r}=t.navigation,n=s.target;if(t.params.navigation.hideOnClick&&!d(n).is(r)&&!d(n).is(a)){if(t.pagination&&t.params.pagination&&t.params.pagination.clickable&&(t.pagination.el===n||t.pagination.el.contains(n)))return;let e;a?e=a.hasClass(t.params.navigation.hiddenClass):r&&(e=r.hasClass(t.params.navigation.hiddenClass)),i(!0===e?"navigationShow":"navigationHide"),a&&a.toggleClass(t.params.navigation.hiddenClass),r&&r.toggleClass(t.params.navigation.hiddenClass)}}));const h=()=>{t.$el.addClass(t.params.navigation.navigationDisabledClass),u()};Object.assign(t.navigation,{enable:()=>{t.$el.removeClass(t.params.navigation.navigationDisabledClass),p(),l()},disable:h,update:l,init:p,destroy:u})},function(e){let{swiper:t,extendParams:s,on:a,emit:i}=e;const r="swiper-pagination";let n;s({pagination:{el:null,bulletElement:"span",clickable:!1,hideOnClick:!1,renderBullet:null,renderProgressbar:null,renderFraction:null,renderCustom:null,progressbarOpposite:!1,type:"bullets",dynamicBullets:!1,dynamicMainBullets:1,formatFractionCurrent:e=>e,formatFractionTotal:e=>e,bulletClass:`${r}-bullet`,bulletActiveClass:`${r}-bullet-active`,modifierClass:`${r}-`,currentClass:`${r}-current`,totalClass:`${r}-total`,hiddenClass:`${r}-hidden`,progressbarFillClass:`${r}-progressbar-fill`,progressbarOppositeClass:`${r}-progressbar-opposite`,clickableClass:`${r}-clickable`,lockClass:`${r}-lock`,horizontalClass:`${r}-horizontal`,verticalClass:`${r}-vertical`,paginationDisabledClass:`${r}-disabled`}}),t.pagination={el:null,$el:null,bullets:[]};let l=0;function o(){return!t.params.pagination.el||!t.pagination.el||!t.pagination.$el||0===t.pagination.$el.length}function c(e,s){const{bulletActiveClass:a}=t.params.pagination;e[s]().addClass(`${a}-${s}`)[s]().addClass(`${a}-${s}-${s}`)}function p(){const e=t.rtl,s=t.params.pagination;if(o())return;const a=t.virtual&&t.params.virtual.enabled?t.virtual.slides.length:t.slides.length,r=t.pagination.$el;let p;const u=t.params.loop?Math.ceil((a-2*t.loopedSlides)/t.params.slidesPerGroup):t.snapGrid.length;if(t.params.loop?(p=Math.ceil((t.activeIndex-t.loopedSlides)/t.params.slidesPerGroup),p>a-1-2*t.loopedSlides&&(p-=a-2*t.loopedSlides),p>u-1&&(p-=u),p<0&&"bullets"!==t.params.paginationType&&(p=u+p)):p=void 0!==t.snapIndex?t.snapIndex:t.activeIndex||0,"bullets"===s.type&&t.pagination.bullets&&t.pagination.bullets.length>0){const a=t.pagination.bullets;let i,o,u;if(s.dynamicBullets&&(n=a.eq(0)[t.isHorizontal()?"outerWidth":"outerHeight"](!0),r.css(t.isHorizontal()?"width":"height",n*(s.dynamicMainBullets+4)+"px"),s.dynamicMainBullets>1&&void 0!==t.previousIndex&&(l+=p-(t.previousIndex-t.loopedSlides||0),l>s.dynamicMainBullets-1?l=s.dynamicMainBullets-1:l<0&&(l=0)),i=Math.max(p-l,0),o=i+(Math.min(a.length,s.dynamicMainBullets)-1),u=(o+i)/2),a.removeClass(["","-next","-next-next","-prev","-prev-prev","-main"].map((e=>`${s.bulletActiveClass}${e}`)).join(" ")),r.length>1)a.each((e=>{const t=d(e),a=t.index();a===p&&t.addClass(s.bulletActiveClass),s.dynamicBullets&&(a>=i&&a<=o&&t.addClass(`${s.bulletActiveClass}-main`),a===i&&c(t,"prev"),a===o&&c(t,"next"))}));else{const e=a.eq(p),r=e.index();if(e.addClass(s.bulletActiveClass),s.dynamicBullets){const e=a.eq(i),n=a.eq(o);for(let e=i;e<=o;e+=1)a.eq(e).addClass(`${s.bulletActiveClass}-main`);if(t.params.loop)if(r>=a.length){for(let e=s.dynamicMainBullets;e>=0;e-=1)a.eq(a.length-e).addClass(`${s.bulletActiveClass}-main`);a.eq(a.length-s.dynamicMainBullets-1).addClass(`${s.bulletActiveClass}-prev`)}else c(e,"prev"),c(n,"next");else c(e,"prev"),c(n,"next")}}if(s.dynamicBullets){const i=Math.min(a.length,s.dynamicMainBullets+4),r=(n*i-n)/2-u*n,l=e?"right":"left";a.css(t.isHorizontal()?l:"top",`${r}px`)}}if("fraction"===s.type&&(r.find(U(s.currentClass)).text(s.formatFractionCurrent(p+1)),r.find(U(s.totalClass)).text(s.formatFractionTotal(u))),"progressbar"===s.type){let e;e=s.progressbarOpposite?t.isHorizontal()?"vertical":"horizontal":t.isHorizontal()?"horizontal":"vertical";const a=(p+1)/u;let i=1,n=1;"horizontal"===e?i=a:n=a,r.find(U(s.progressbarFillClass)).transform(`translate3d(0,0,0) scaleX(${i}) scaleY(${n})`).transition(t.params.speed)}"custom"===s.type&&s.renderCustom?(r.html(s.renderCustom(t,p+1,u)),i("paginationRender",r[0])):i("paginationUpdate",r[0]),t.params.watchOverflow&&t.enabled&&r[t.isLocked?"addClass":"removeClass"](s.lockClass)}function u(){const e=t.params.pagination;if(o())return;const s=t.virtual&&t.params.virtual.enabled?t.virtual.slides.length:t.slides.length,a=t.pagination.$el;let r="";if("bullets"===e.type){let i=t.params.loop?Math.ceil((s-2*t.loopedSlides)/t.params.slidesPerGroup):t.snapGrid.length;t.params.freeMode&&t.params.freeMode.enabled&&!t.params.loop&&i>s&&(i=s);for(let s=0;s`;a.html(r),t.pagination.bullets=a.find(U(e.bulletClass))}"fraction"===e.type&&(r=e.renderFraction?e.renderFraction.call(t,e.currentClass,e.totalClass):` / `,a.html(r)),"progressbar"===e.type&&(r=e.renderProgressbar?e.renderProgressbar.call(t,e.progressbarFillClass):``,a.html(r)),"custom"!==e.type&&i("paginationRender",t.pagination.$el[0])}function h(){t.params.pagination=F(t,t.originalParams.pagination,t.params.pagination,{el:"swiper-pagination"});const e=t.params.pagination;if(!e.el)return;let s=d(e.el);0!==s.length&&(t.params.uniqueNavElements&&"string"==typeof e.el&&s.length>1&&(s=t.$el.find(e.el),s.length>1&&(s=s.filter((e=>d(e).parents(".swiper")[0]===t.el)))),"bullets"===e.type&&e.clickable&&s.addClass(e.clickableClass),s.addClass(e.modifierClass+e.type),s.addClass(t.isHorizontal()?e.horizontalClass:e.verticalClass),"bullets"===e.type&&e.dynamicBullets&&(s.addClass(`${e.modifierClass}${e.type}-dynamic`),l=0,e.dynamicMainBullets<1&&(e.dynamicMainBullets=1)),"progressbar"===e.type&&e.progressbarOpposite&&s.addClass(e.progressbarOppositeClass),e.clickable&&s.on("click",U(e.bulletClass),(function(e){e.preventDefault();let s=d(this).index()*t.params.slidesPerGroup;t.params.loop&&(s+=t.loopedSlides),t.slideTo(s)})),Object.assign(t.pagination,{$el:s,el:s[0]}),t.enabled||s.addClass(e.lockClass))}function m(){const e=t.params.pagination;if(o())return;const s=t.pagination.$el;s.removeClass(e.hiddenClass),s.removeClass(e.modifierClass+e.type),s.removeClass(t.isHorizontal()?e.horizontalClass:e.verticalClass),t.pagination.bullets&&t.pagination.bullets.removeClass&&t.pagination.bullets.removeClass(e.bulletActiveClass),e.clickable&&s.off("click",U(e.bulletClass))}a("init",(()=>{!1===t.params.pagination.enabled?f():(h(),u(),p())})),a("activeIndexChange",(()=>{(t.params.loop||void 0===t.snapIndex)&&p()})),a("snapIndexChange",(()=>{t.params.loop||p()})),a("slidesLengthChange",(()=>{t.params.loop&&(u(),p())})),a("snapGridLengthChange",(()=>{t.params.loop||(u(),p())})),a("destroy",(()=>{m()})),a("enable disable",(()=>{const{$el:e}=t.pagination;e&&e[t.enabled?"removeClass":"addClass"](t.params.pagination.lockClass)})),a("lock unlock",(()=>{p()})),a("click",((e,s)=>{const a=s.target,{$el:r}=t.pagination;if(t.params.pagination.el&&t.params.pagination.hideOnClick&&r&&r.length>0&&!d(a).hasClass(t.params.pagination.bulletClass)){if(t.navigation&&(t.navigation.nextEl&&a===t.navigation.nextEl||t.navigation.prevEl&&a===t.navigation.prevEl))return;const e=r.hasClass(t.params.pagination.hiddenClass);i(!0===e?"paginationShow":"paginationHide"),r.toggleClass(t.params.pagination.hiddenClass)}}));const f=()=>{t.$el.addClass(t.params.pagination.paginationDisabledClass),t.pagination.$el&&t.pagination.$el.addClass(t.params.pagination.paginationDisabledClass),m()};Object.assign(t.pagination,{enable:()=>{t.$el.removeClass(t.params.pagination.paginationDisabledClass),t.pagination.$el&&t.pagination.$el.removeClass(t.params.pagination.paginationDisabledClass),h(),u(),p()},disable:f,render:u,update:p,init:h,destroy:m})},function(e){let{swiper:t,extendParams:s,on:i,emit:r}=e;const n=a();let l,o,c,u,h=!1,m=null,f=null;function g(){if(!t.params.scrollbar.el||!t.scrollbar.el)return;const{scrollbar:e,rtlTranslate:s,progress:a}=t,{$dragEl:i,$el:r}=e,n=t.params.scrollbar;let l=o,d=(c-o)*a;s?(d=-d,d>0?(l=o-d,d=0):-d+o>c&&(l=c+d)):d<0?(l=o+d,d=0):d+o>c&&(l=c-d),t.isHorizontal()?(i.transform(`translate3d(${d}px, 0, 0)`),i[0].style.width=`${l}px`):(i.transform(`translate3d(0px, ${d}px, 0)`),i[0].style.height=`${l}px`),n.hide&&(clearTimeout(m),r[0].style.opacity=1,m=setTimeout((()=>{r[0].style.opacity=0,r.transition(400)}),1e3))}function v(){if(!t.params.scrollbar.el||!t.scrollbar.el)return;const{scrollbar:e}=t,{$dragEl:s,$el:a}=e;s[0].style.width="",s[0].style.height="",c=t.isHorizontal()?a[0].offsetWidth:a[0].offsetHeight,u=t.size/(t.virtualSize+t.params.slidesOffsetBefore-(t.params.centeredSlides?t.snapGrid[0]:0)),o="auto"===t.params.scrollbar.dragSize?c*u:parseInt(t.params.scrollbar.dragSize,10),t.isHorizontal()?s[0].style.width=`${o}px`:s[0].style.height=`${o}px`,a[0].style.display=u>=1?"none":"",t.params.scrollbar.hide&&(a[0].style.opacity=0),t.params.watchOverflow&&t.enabled&&e.$el[t.isLocked?"addClass":"removeClass"](t.params.scrollbar.lockClass)}function w(e){return t.isHorizontal()?"touchstart"===e.type||"touchmove"===e.type?e.targetTouches[0].clientX:e.clientX:"touchstart"===e.type||"touchmove"===e.type?e.targetTouches[0].clientY:e.clientY}function b(e){const{scrollbar:s,rtlTranslate:a}=t,{$el:i}=s;let r;r=(w(e)-i.offset()[t.isHorizontal()?"left":"top"]-(null!==l?l:o/2))/(c-o),r=Math.max(Math.min(r,1),0),a&&(r=1-r);const n=t.minTranslate()+(t.maxTranslate()-t.minTranslate())*r;t.updateProgress(n),t.setTranslate(n),t.updateActiveIndex(),t.updateSlidesClasses()}function x(e){const s=t.params.scrollbar,{scrollbar:a,$wrapperEl:i}=t,{$el:n,$dragEl:o}=a;h=!0,l=e.target===o[0]||e.target===o?w(e)-e.target.getBoundingClientRect()[t.isHorizontal()?"left":"top"]:null,e.preventDefault(),e.stopPropagation(),i.transition(100),o.transition(100),b(e),clearTimeout(f),n.transition(0),s.hide&&n.css("opacity",1),t.params.cssMode&&t.$wrapperEl.css("scroll-snap-type","none"),r("scrollbarDragStart",e)}function y(e){const{scrollbar:s,$wrapperEl:a}=t,{$el:i,$dragEl:n}=s;h&&(e.preventDefault?e.preventDefault():e.returnValue=!1,b(e),a.transition(0),i.transition(0),n.transition(0),r("scrollbarDragMove",e))}function E(e){const s=t.params.scrollbar,{scrollbar:a,$wrapperEl:i}=t,{$el:n}=a;h&&(h=!1,t.params.cssMode&&(t.$wrapperEl.css("scroll-snap-type",""),i.transition("")),s.hide&&(clearTimeout(f),f=p((()=>{n.css("opacity",0),n.transition(400)}),1e3)),r("scrollbarDragEnd",e),s.snapOnRelease&&t.slideToClosest())}function C(e){const{scrollbar:s,touchEventsTouch:a,touchEventsDesktop:i,params:r,support:l}=t,o=s.$el;if(!o)return;const d=o[0],c=!(!l.passiveListener||!r.passiveListeners)&&{passive:!1,capture:!1},p=!(!l.passiveListener||!r.passiveListeners)&&{passive:!0,capture:!1};if(!d)return;const u="on"===e?"addEventListener":"removeEventListener";l.touch?(d[u](a.start,x,c),d[u](a.move,y,c),d[u](a.end,E,p)):(d[u](i.start,x,c),n[u](i.move,y,c),n[u](i.end,E,p))}function T(){const{scrollbar:e,$el:s}=t;t.params.scrollbar=F(t,t.originalParams.scrollbar,t.params.scrollbar,{el:"swiper-scrollbar"});const a=t.params.scrollbar;if(!a.el)return;let i=d(a.el);t.params.uniqueNavElements&&"string"==typeof a.el&&i.length>1&&1===s.find(a.el).length&&(i=s.find(a.el)),i.addClass(t.isHorizontal()?a.horizontalClass:a.verticalClass);let r=i.find(`.${t.params.scrollbar.dragClass}`);0===r.length&&(r=d(`
`),i.append(r)),Object.assign(e,{$el:i,el:i[0],$dragEl:r,dragEl:r[0]}),a.draggable&&t.params.scrollbar.el&&t.scrollbar.el&&C("on"),i&&i[t.enabled?"removeClass":"addClass"](t.params.scrollbar.lockClass)}function $(){const e=t.params.scrollbar,s=t.scrollbar.$el;s&&s.removeClass(t.isHorizontal()?e.horizontalClass:e.verticalClass),t.params.scrollbar.el&&t.scrollbar.el&&C("off")}s({scrollbar:{el:null,dragSize:"auto",hide:!1,draggable:!1,snapOnRelease:!0,lockClass:"swiper-scrollbar-lock",dragClass:"swiper-scrollbar-drag",scrollbarDisabledClass:"swiper-scrollbar-disabled",horizontalClass:"swiper-scrollbar-horizontal",verticalClass:"swiper-scrollbar-vertical"}}),t.scrollbar={el:null,dragEl:null,$el:null,$dragEl:null},i("init",(()=>{!1===t.params.scrollbar.enabled?S():(T(),v(),g())})),i("update resize observerUpdate lock unlock",(()=>{v()})),i("setTranslate",(()=>{g()})),i("setTransition",((e,s)=>{!function(e){t.params.scrollbar.el&&t.scrollbar.el&&t.scrollbar.$dragEl.transition(e)}(s)})),i("enable disable",(()=>{const{$el:e}=t.scrollbar;e&&e[t.enabled?"removeClass":"addClass"](t.params.scrollbar.lockClass)})),i("destroy",(()=>{$()}));const S=()=>{t.$el.addClass(t.params.scrollbar.scrollbarDisabledClass),t.scrollbar.$el&&t.scrollbar.$el.addClass(t.params.scrollbar.scrollbarDisabledClass),$()};Object.assign(t.scrollbar,{enable:()=>{t.$el.removeClass(t.params.scrollbar.scrollbarDisabledClass),t.scrollbar.$el&&t.scrollbar.$el.removeClass(t.params.scrollbar.scrollbarDisabledClass),T(),v(),g()},disable:S,updateSize:v,setTranslate:g,init:T,destroy:$})},function(e){let{swiper:t,extendParams:s,on:a}=e;s({parallax:{enabled:!1}});const i=(e,s)=>{const{rtl:a}=t,i=d(e),r=a?-1:1,n=i.attr("data-swiper-parallax")||"0";let l=i.attr("data-swiper-parallax-x"),o=i.attr("data-swiper-parallax-y");const c=i.attr("data-swiper-parallax-scale"),p=i.attr("data-swiper-parallax-opacity");if(l||o?(l=l||"0",o=o||"0"):t.isHorizontal()?(l=n,o="0"):(o=n,l="0"),l=l.indexOf("%")>=0?parseInt(l,10)*s*r+"%":l*s*r+"px",o=o.indexOf("%")>=0?parseInt(o,10)*s+"%":o*s+"px",null!=p){const e=p-(p-1)*(1-Math.abs(s));i[0].style.opacity=e}if(null==c)i.transform(`translate3d(${l}, ${o}, 0px)`);else{const e=c-(c-1)*(1-Math.abs(s));i.transform(`translate3d(${l}, ${o}, 0px) scale(${e})`)}},r=()=>{const{$el:e,slides:s,progress:a,snapGrid:r}=t;e.children("[data-swiper-parallax], [data-swiper-parallax-x], [data-swiper-parallax-y], [data-swiper-parallax-opacity], [data-swiper-parallax-scale]").each((e=>{i(e,a)})),s.each(((e,s)=>{let n=e.progress;t.params.slidesPerGroup>1&&"auto"!==t.params.slidesPerView&&(n+=Math.ceil(s/2)-a*(r.length-1)),n=Math.min(Math.max(n,-1),1),d(e).find("[data-swiper-parallax], [data-swiper-parallax-x], [data-swiper-parallax-y], [data-swiper-parallax-opacity], [data-swiper-parallax-scale]").each((e=>{i(e,n)}))}))};a("beforeInit",(()=>{t.params.parallax.enabled&&(t.params.watchSlidesProgress=!0,t.originalParams.watchSlidesProgress=!0)})),a("init",(()=>{t.params.parallax.enabled&&r()})),a("setTranslate",(()=>{t.params.parallax.enabled&&r()})),a("setTransition",((e,s)=>{t.params.parallax.enabled&&function(e){void 0===e&&(e=t.params.speed);const{$el:s}=t;s.find("[data-swiper-parallax], [data-swiper-parallax-x], [data-swiper-parallax-y], [data-swiper-parallax-opacity], [data-swiper-parallax-scale]").each((t=>{const s=d(t);let a=parseInt(s.attr("data-swiper-parallax-duration"),10)||e;0===e&&(a=0),s.transition(a)}))}(s)}))},function(e){let{swiper:t,extendParams:s,on:a,emit:i}=e;const n=r();s({zoom:{enabled:!1,maxRatio:3,minRatio:1,toggle:!0,containerClass:"swiper-zoom-container",zoomedSlideClass:"swiper-slide-zoomed"}}),t.zoom={enabled:!1};let l,o,c,p=1,u=!1;const m={$slideEl:void 0,slideWidth:void 0,slideHeight:void 0,$imageEl:void 0,$imageWrapEl:void 0,maxRatio:3},f={isTouched:void 0,isMoved:void 0,currentX:void 0,currentY:void 0,minX:void 0,minY:void 0,maxX:void 0,maxY:void 0,width:void 0,height:void 0,startX:void 0,startY:void 0,touchesStart:{},touchesCurrent:{}},g={x:void 0,y:void 0,prevPositionX:void 0,prevPositionY:void 0,prevTime:void 0};let v=1;function w(e){if(e.targetTouches.length<2)return 1;const t=e.targetTouches[0].pageX,s=e.targetTouches[0].pageY,a=e.targetTouches[1].pageX,i=e.targetTouches[1].pageY;return Math.sqrt((a-t)**2+(i-s)**2)}function b(e){const s=t.support,a=t.params.zoom;if(o=!1,c=!1,!s.gestures){if("touchstart"!==e.type||"touchstart"===e.type&&e.targetTouches.length<2)return;o=!0,m.scaleStart=w(e)}m.$slideEl&&m.$slideEl.length||(m.$slideEl=d(e.target).closest(`.${t.params.slideClass}`),0===m.$slideEl.length&&(m.$slideEl=t.slides.eq(t.activeIndex)),m.$imageEl=m.$slideEl.find(`.${a.containerClass}`).eq(0).find("picture, img, svg, canvas, .swiper-zoom-target").eq(0),m.$imageWrapEl=m.$imageEl.parent(`.${a.containerClass}`),m.maxRatio=m.$imageWrapEl.attr("data-swiper-zoom")||a.maxRatio,0!==m.$imageWrapEl.length)?(m.$imageEl&&m.$imageEl.transition(0),u=!0):m.$imageEl=void 0}function x(e){const s=t.support,a=t.params.zoom,i=t.zoom;if(!s.gestures){if("touchmove"!==e.type||"touchmove"===e.type&&e.targetTouches.length<2)return;c=!0,m.scaleMove=w(e)}m.$imageEl&&0!==m.$imageEl.length?(s.gestures?i.scale=e.scale*p:i.scale=m.scaleMove/m.scaleStart*p,i.scale>m.maxRatio&&(i.scale=m.maxRatio-1+(i.scale-m.maxRatio+1)**.5),i.scalef.touchesStart.x))return void(f.isTouched=!1);if(!t.isHorizontal()&&(Math.floor(f.minY)===Math.floor(f.startY)&&f.touchesCurrent.yf.touchesStart.y))return void(f.isTouched=!1)}e.cancelable&&e.preventDefault(),e.stopPropagation(),f.isMoved=!0,f.currentX=f.touchesCurrent.x-f.touchesStart.x+f.startX,f.currentY=f.touchesCurrent.y-f.touchesStart.y+f.startY,f.currentXf.maxX&&(f.currentX=f.maxX-1+(f.currentX-f.maxX+1)**.8),f.currentYf.maxY&&(f.currentY=f.maxY-1+(f.currentY-f.maxY+1)**.8),g.prevPositionX||(g.prevPositionX=f.touchesCurrent.x),g.prevPositionY||(g.prevPositionY=f.touchesCurrent.y),g.prevTime||(g.prevTime=Date.now()),g.x=(f.touchesCurrent.x-g.prevPositionX)/(Date.now()-g.prevTime)/2,g.y=(f.touchesCurrent.y-g.prevPositionY)/(Date.now()-g.prevTime)/2,Math.abs(f.touchesCurrent.x-g.prevPositionX)<2&&(g.x=0),Math.abs(f.touchesCurrent.y-g.prevPositionY)<2&&(g.y=0),g.prevPositionX=f.touchesCurrent.x,g.prevPositionY=f.touchesCurrent.y,g.prevTime=Date.now(),m.$imageWrapEl.transform(`translate3d(${f.currentX}px, ${f.currentY}px,0)`)}}function C(){const e=t.zoom;m.$slideEl&&t.previousIndex!==t.activeIndex&&(m.$imageEl&&m.$imageEl.transform("translate3d(0,0,0) scale(1)"),m.$imageWrapEl&&m.$imageWrapEl.transform("translate3d(0,0,0)"),e.scale=1,p=1,m.$slideEl=void 0,m.$imageEl=void 0,m.$imageWrapEl=void 0)}function T(e){const s=t.zoom,a=t.params.zoom;if(m.$slideEl||(e&&e.target&&(m.$slideEl=d(e.target).closest(`.${t.params.slideClass}`)),m.$slideEl||(t.params.virtual&&t.params.virtual.enabled&&t.virtual?m.$slideEl=t.$wrapperEl.children(`.${t.params.slideActiveClass}`):m.$slideEl=t.slides.eq(t.activeIndex)),m.$imageEl=m.$slideEl.find(`.${a.containerClass}`).eq(0).find("picture, img, svg, canvas, .swiper-zoom-target").eq(0),m.$imageWrapEl=m.$imageEl.parent(`.${a.containerClass}`)),!m.$imageEl||0===m.$imageEl.length||!m.$imageWrapEl||0===m.$imageWrapEl.length)return;let i,r,l,o,c,u,h,g,v,w,b,x,y,E,C,T,$,S;t.params.cssMode&&(t.wrapperEl.style.overflow="hidden",t.wrapperEl.style.touchAction="none"),m.$slideEl.addClass(`${a.zoomedSlideClass}`),void 0===f.touchesStart.x&&e?(i="touchend"===e.type?e.changedTouches[0].pageX:e.pageX,r="touchend"===e.type?e.changedTouches[0].pageY:e.pageY):(i=f.touchesStart.x,r=f.touchesStart.y),s.scale=m.$imageWrapEl.attr("data-swiper-zoom")||a.maxRatio,p=m.$imageWrapEl.attr("data-swiper-zoom")||a.maxRatio,e?($=m.$slideEl[0].offsetWidth,S=m.$slideEl[0].offsetHeight,l=m.$slideEl.offset().left+n.scrollX,o=m.$slideEl.offset().top+n.scrollY,c=l+$/2-i,u=o+S/2-r,v=m.$imageEl[0].offsetWidth,w=m.$imageEl[0].offsetHeight,b=v*s.scale,x=w*s.scale,y=Math.min($/2-b/2,0),E=Math.min(S/2-x/2,0),C=-y,T=-E,h=c*s.scale,g=u*s.scale,hC&&(h=C),gT&&(g=T)):(h=0,g=0),m.$imageWrapEl.transition(300).transform(`translate3d(${h}px, ${g}px,0)`),m.$imageEl.transition(300).transform(`translate3d(0,0,0) scale(${s.scale})`)}function $(){const e=t.zoom,s=t.params.zoom;m.$slideEl||(t.params.virtual&&t.params.virtual.enabled&&t.virtual?m.$slideEl=t.$wrapperEl.children(`.${t.params.slideActiveClass}`):m.$slideEl=t.slides.eq(t.activeIndex),m.$imageEl=m.$slideEl.find(`.${s.containerClass}`).eq(0).find("picture, img, svg, canvas, .swiper-zoom-target").eq(0),m.$imageWrapEl=m.$imageEl.parent(`.${s.containerClass}`)),m.$imageEl&&0!==m.$imageEl.length&&m.$imageWrapEl&&0!==m.$imageWrapEl.length&&(t.params.cssMode&&(t.wrapperEl.style.overflow="",t.wrapperEl.style.touchAction=""),e.scale=1,p=1,m.$imageWrapEl.transition(300).transform("translate3d(0,0,0)"),m.$imageEl.transition(300).transform("translate3d(0,0,0) scale(1)"),m.$slideEl.removeClass(`${s.zoomedSlideClass}`),m.$slideEl=void 0)}function S(e){const s=t.zoom;s.scale&&1!==s.scale?$():T(e)}function M(){const e=t.support;return{passiveListener:!("touchstart"!==t.touchEvents.start||!e.passiveListener||!t.params.passiveListeners)&&{passive:!0,capture:!1},activeListenerWithCapture:!e.passiveListener||{passive:!1,capture:!0}}}function P(){return`.${t.params.slideClass}`}function k(e){const{passiveListener:s}=M(),a=P();t.$wrapperEl[e]("gesturestart",a,b,s),t.$wrapperEl[e]("gesturechange",a,x,s),t.$wrapperEl[e]("gestureend",a,y,s)}function z(){l||(l=!0,k("on"))}function L(){l&&(l=!1,k("off"))}function O(){const e=t.zoom;if(e.enabled)return;e.enabled=!0;const s=t.support,{passiveListener:a,activeListenerWithCapture:i}=M(),r=P();s.gestures?(t.$wrapperEl.on(t.touchEvents.start,z,a),t.$wrapperEl.on(t.touchEvents.end,L,a)):"touchstart"===t.touchEvents.start&&(t.$wrapperEl.on(t.touchEvents.start,r,b,a),t.$wrapperEl.on(t.touchEvents.move,r,x,i),t.$wrapperEl.on(t.touchEvents.end,r,y,a),t.touchEvents.cancel&&t.$wrapperEl.on(t.touchEvents.cancel,r,y,a)),t.$wrapperEl.on(t.touchEvents.move,`.${t.params.zoom.containerClass}`,E,i)}function I(){const e=t.zoom;if(!e.enabled)return;const s=t.support;e.enabled=!1;const{passiveListener:a,activeListenerWithCapture:i}=M(),r=P();s.gestures?(t.$wrapperEl.off(t.touchEvents.start,z,a),t.$wrapperEl.off(t.touchEvents.end,L,a)):"touchstart"===t.touchEvents.start&&(t.$wrapperEl.off(t.touchEvents.start,r,b,a),t.$wrapperEl.off(t.touchEvents.move,r,x,i),t.$wrapperEl.off(t.touchEvents.end,r,y,a),t.touchEvents.cancel&&t.$wrapperEl.off(t.touchEvents.cancel,r,y,a)),t.$wrapperEl.off(t.touchEvents.move,`.${t.params.zoom.containerClass}`,E,i)}Object.defineProperty(t.zoom,"scale",{get:()=>v,set(e){if(v!==e){const t=m.$imageEl?m.$imageEl[0]:void 0,s=m.$slideEl?m.$slideEl[0]:void 0;i("zoomChange",e,t,s)}v=e}}),a("init",(()=>{t.params.zoom.enabled&&O()})),a("destroy",(()=>{I()})),a("touchStart",((e,s)=>{t.zoom.enabled&&function(e){const s=t.device;m.$imageEl&&0!==m.$imageEl.length&&(f.isTouched||(s.android&&e.cancelable&&e.preventDefault(),f.isTouched=!0,f.touchesStart.x="touchstart"===e.type?e.targetTouches[0].pageX:e.pageX,f.touchesStart.y="touchstart"===e.type?e.targetTouches[0].pageY:e.pageY))}(s)})),a("touchEnd",((e,s)=>{t.zoom.enabled&&function(){const e=t.zoom;if(!m.$imageEl||0===m.$imageEl.length)return;if(!f.isTouched||!f.isMoved)return f.isTouched=!1,void(f.isMoved=!1);f.isTouched=!1,f.isMoved=!1;let s=300,a=300;const i=g.x*s,r=f.currentX+i,n=g.y*a,l=f.currentY+n;0!==g.x&&(s=Math.abs((r-f.currentX)/g.x)),0!==g.y&&(a=Math.abs((l-f.currentY)/g.y));const o=Math.max(s,a);f.currentX=r,f.currentY=l;const d=f.width*e.scale,c=f.height*e.scale;f.minX=Math.min(m.slideWidth/2-d/2,0),f.maxX=-f.minX,f.minY=Math.min(m.slideHeight/2-c/2,0),f.maxY=-f.minY,f.currentX=Math.max(Math.min(f.currentX,f.maxX),f.minX),f.currentY=Math.max(Math.min(f.currentY,f.maxY),f.minY),m.$imageWrapEl.transition(o).transform(`translate3d(${f.currentX}px, ${f.currentY}px,0)`)}()})),a("doubleTap",((e,s)=>{!t.animating&&t.params.zoom.enabled&&t.zoom.enabled&&t.params.zoom.toggle&&S(s)})),a("transitionEnd",(()=>{t.zoom.enabled&&t.params.zoom.enabled&&C()})),a("slideChange",(()=>{t.zoom.enabled&&t.params.zoom.enabled&&t.params.cssMode&&C()})),Object.assign(t.zoom,{enable:O,disable:I,in:T,out:$,toggle:S})},function(e){let{swiper:t,extendParams:s,on:a,emit:i}=e;s({lazy:{checkInView:!1,enabled:!1,loadPrevNext:!1,loadPrevNextAmount:1,loadOnTransitionStart:!1,scrollingElement:"",elementClass:"swiper-lazy",loadingClass:"swiper-lazy-loading",loadedClass:"swiper-lazy-loaded",preloaderClass:"swiper-lazy-preloader"}}),t.lazy={};let n=!1,l=!1;function o(e,s){void 0===s&&(s=!0);const a=t.params.lazy;if(void 0===e)return;if(0===t.slides.length)return;const r=t.virtual&&t.params.virtual.enabled?t.$wrapperEl.children(`.${t.params.slideClass}[data-swiper-slide-index="${e}"]`):t.slides.eq(e),n=r.find(`.${a.elementClass}:not(.${a.loadedClass}):not(.${a.loadingClass})`);!r.hasClass(a.elementClass)||r.hasClass(a.loadedClass)||r.hasClass(a.loadingClass)||n.push(r[0]),0!==n.length&&n.each((e=>{const n=d(e);n.addClass(a.loadingClass);const l=n.attr("data-background"),c=n.attr("data-src"),p=n.attr("data-srcset"),u=n.attr("data-sizes"),h=n.parent("picture");t.loadImage(n[0],c||l,p,u,!1,(()=>{if(null!=t&&t&&(!t||t.params)&&!t.destroyed){if(l?(n.css("background-image",`url("${l}")`),n.removeAttr("data-background")):(p&&(n.attr("srcset",p),n.removeAttr("data-srcset")),u&&(n.attr("sizes",u),n.removeAttr("data-sizes")),h.length&&h.children("source").each((e=>{const t=d(e);t.attr("data-srcset")&&(t.attr("srcset",t.attr("data-srcset")),t.removeAttr("data-srcset"))})),c&&(n.attr("src",c),n.removeAttr("data-src"))),n.addClass(a.loadedClass).removeClass(a.loadingClass),r.find(`.${a.preloaderClass}`).remove(),t.params.loop&&s){const e=r.attr("data-swiper-slide-index");if(r.hasClass(t.params.slideDuplicateClass)){o(t.$wrapperEl.children(`[data-swiper-slide-index="${e}"]:not(.${t.params.slideDuplicateClass})`).index(),!1)}else{o(t.$wrapperEl.children(`.${t.params.slideDuplicateClass}[data-swiper-slide-index="${e}"]`).index(),!1)}}i("lazyImageReady",r[0],n[0]),t.params.autoHeight&&t.updateAutoHeight()}})),i("lazyImageLoad",r[0],n[0])}))}function c(){const{$wrapperEl:e,params:s,slides:a,activeIndex:i}=t,r=t.virtual&&s.virtual.enabled,n=s.lazy;let c=s.slidesPerView;function p(t){if(r){if(e.children(`.${s.slideClass}[data-swiper-slide-index="${t}"]`).length)return!0}else if(a[t])return!0;return!1}function u(e){return r?d(e).attr("data-swiper-slide-index"):d(e).index()}if("auto"===c&&(c=0),l||(l=!0),t.params.watchSlidesProgress)e.children(`.${s.slideVisibleClass}`).each((e=>{o(r?d(e).attr("data-swiper-slide-index"):d(e).index())}));else if(c>1)for(let e=i;e1||n.loadPrevNextAmount&&n.loadPrevNextAmount>1){const e=n.loadPrevNextAmount,t=Math.ceil(c),s=Math.min(i+t+Math.max(e,t),a.length),r=Math.max(i-Math.max(t,e),0);for(let e=i+t;e0&&o(u(t));const a=e.children(`.${s.slidePrevClass}`);a.length>0&&o(u(a))}}function p(){const e=r();if(!t||t.destroyed)return;const s=t.params.lazy.scrollingElement?d(t.params.lazy.scrollingElement):d(e),a=s[0]===e,i=a?e.innerWidth:s[0].offsetWidth,l=a?e.innerHeight:s[0].offsetHeight,o=t.$el.offset(),{rtlTranslate:u}=t;let h=!1;u&&(o.left-=t.$el[0].scrollLeft);const m=[[o.left,o.top],[o.left+t.width,o.top],[o.left,o.top+t.height],[o.left+t.width,o.top+t.height]];for(let e=0;e=0&&t[0]<=i&&t[1]>=0&&t[1]<=l){if(0===t[0]&&0===t[1])continue;h=!0}}const f=!("touchstart"!==t.touchEvents.start||!t.support.passiveListener||!t.params.passiveListeners)&&{passive:!0,capture:!1};h?(c(),s.off("scroll",p,f)):n||(n=!0,s.on("scroll",p,f))}a("beforeInit",(()=>{t.params.lazy.enabled&&t.params.preloadImages&&(t.params.preloadImages=!1)})),a("init",(()=>{t.params.lazy.enabled&&(t.params.lazy.checkInView?p():c())})),a("scroll",(()=>{t.params.freeMode&&t.params.freeMode.enabled&&!t.params.freeMode.sticky&&c()})),a("scrollbarDragMove resize _freeModeNoMomentumRelease",(()=>{t.params.lazy.enabled&&(t.params.lazy.checkInView?p():c())})),a("transitionStart",(()=>{t.params.lazy.enabled&&(t.params.lazy.loadOnTransitionStart||!t.params.lazy.loadOnTransitionStart&&!l)&&(t.params.lazy.checkInView?p():c())})),a("transitionEnd",(()=>{t.params.lazy.enabled&&!t.params.lazy.loadOnTransitionStart&&(t.params.lazy.checkInView?p():c())})),a("slideChange",(()=>{const{lazy:e,cssMode:s,watchSlidesProgress:a,touchReleaseOnEdges:i,resistanceRatio:r}=t.params;e.enabled&&(s||a&&(i||0===r))&&c()})),a("destroy",(()=>{t.$el&&t.$el.find(`.${t.params.lazy.loadingClass}`).removeClass(t.params.lazy.loadingClass)})),Object.assign(t.lazy,{load:c,loadInSlide:o})},function(e){let{swiper:t,extendParams:s,on:a}=e;function i(e,t){const s=function(){let e,t,s;return(a,i)=>{for(t=-1,e=a.length;e-t>1;)s=e+t>>1,a[s]<=i?t=s:e=s;return e}}();let a,i;return this.x=e,this.y=t,this.lastIndex=e.length-1,this.interpolate=function(e){return e?(i=s(this.x,e),a=i-1,(e-this.x[a])*(this.y[i]-this.y[a])/(this.x[i]-this.x[a])+this.y[a]):0},this}function r(){t.controller.control&&t.controller.spline&&(t.controller.spline=void 0,delete t.controller.spline)}s({controller:{control:void 0,inverse:!1,by:"slide"}}),t.controller={control:void 0},a("beforeInit",(()=>{t.controller.control=t.params.controller.control})),a("update",(()=>{r()})),a("resize",(()=>{r()})),a("observerUpdate",(()=>{r()})),a("setTranslate",((e,s,a)=>{t.controller.control&&t.controller.setTranslate(s,a)})),a("setTransition",((e,s,a)=>{t.controller.control&&t.controller.setTransition(s,a)})),Object.assign(t.controller,{setTranslate:function(e,s){const a=t.controller.control;let r,n;const l=t.constructor;function o(e){const s=t.rtlTranslate?-t.translate:t.translate;"slide"===t.params.controller.by&&(!function(e){t.controller.spline||(t.controller.spline=t.params.loop?new i(t.slidesGrid,e.slidesGrid):new i(t.snapGrid,e.snapGrid))}(e),n=-t.controller.spline.interpolate(-s)),n&&"container"!==t.params.controller.by||(r=(e.maxTranslate()-e.minTranslate())/(t.maxTranslate()-t.minTranslate()),n=(s-t.minTranslate())*r+e.minTranslate()),t.params.controller.inverse&&(n=e.maxTranslate()-n),e.updateProgress(n),e.setTranslate(n,t),e.updateActiveIndex(),e.updateSlidesClasses()}if(Array.isArray(a))for(let e=0;e{s.updateAutoHeight()})),s.$wrapperEl.transitionEnd((()=>{i&&(s.params.loop&&"slide"===t.params.controller.by&&s.loopFix(),s.transitionEnd())})))}if(Array.isArray(i))for(r=0;r{n(e),"BUTTON"!==e[0].tagName&&(o(e,"button"),e.on("keydown",m)),p(e,s),function(e,t){e.attr("aria-controls",t)}(e,t)},w=()=>{t.a11y.clicked=!0},b=()=>{requestAnimationFrame((()=>{requestAnimationFrame((()=>{t.a11y.clicked=!1}))}))},x=e=>{if(t.a11y.clicked)return;const s=e.target.closest(`.${t.params.slideClass}`);if(!s||!t.slides.includes(s))return;const a=t.slides.indexOf(s)===t.activeIndex,i=t.params.watchSlidesProgress&&t.visibleSlides&&t.visibleSlides.includes(s);a||i||(t.isHorizontal()?t.el.scrollLeft=0:t.el.scrollTop=0,t.slideTo(t.slides.indexOf(s),0))},y=()=>{const e=t.params.a11y;e.itemRoleDescriptionMessage&&c(d(t.slides),e.itemRoleDescriptionMessage),e.slideRole&&o(d(t.slides),e.slideRole);const s=t.params.loop?t.slides.filter((e=>!e.classList.contains(t.params.slideDuplicateClass))).length:t.slides.length;e.slideLabelMessage&&t.slides.each(((a,i)=>{const r=d(a),n=t.params.loop?parseInt(r.attr("data-swiper-slide-index"),10):i;p(r,e.slideLabelMessage.replace(/\{\{index\}\}/,n+1).replace(/\{\{slidesLength\}\}/,s))}))},E=()=>{const e=t.params.a11y;t.$el.append(i);const s=t.$el;e.containerRoleDescriptionMessage&&c(s,e.containerRoleDescriptionMessage),e.containerMessage&&p(s,e.containerMessage);const a=t.$wrapperEl,r=e.id||a.attr("id")||`swiper-wrapper-${n=16,void 0===n&&(n=16),"x".repeat(n).replace(/x/g,(()=>Math.round(16*Math.random()).toString(16)))}`;var n;const l=t.params.autoplay&&t.params.autoplay.enabled?"off":"polite";var o;let d,u;o=r,a.attr("id",o),function(e,t){e.attr("aria-live",t)}(a,l),y(),t.navigation&&t.navigation.$nextEl&&(d=t.navigation.$nextEl),t.navigation&&t.navigation.$prevEl&&(u=t.navigation.$prevEl),d&&d.length&&v(d,r,e.nextSlideMessage),u&&u.length&&v(u,r,e.prevSlideMessage),g()&&t.pagination.$el.on("keydown",U(t.params.pagination.bulletClass),m),t.$el.on("focus",x,!0),t.$el.on("pointerdown",w,!0),t.$el.on("pointerup",b,!0)};a("beforeInit",(()=>{i=d(``)})),a("afterInit",(()=>{t.params.a11y.enabled&&E()})),a("slidesLengthChange snapGridLengthChange slidesGridLengthChange",(()=>{t.params.a11y.enabled&&y()})),a("fromEdge toEdge afterInit lock unlock",(()=>{t.params.a11y.enabled&&function(){if(t.params.loop||t.params.rewind||!t.navigation)return;const{$nextEl:e,$prevEl:s}=t.navigation;s&&s.length>0&&(t.isBeginning?(u(s),l(s)):(h(s),n(s))),e&&e.length>0&&(t.isEnd?(u(e),l(e)):(h(e),n(e)))}()})),a("paginationUpdate",(()=>{t.params.a11y.enabled&&function(){const e=t.params.a11y;f()&&t.pagination.bullets.each((s=>{const a=d(s);t.params.pagination.clickable&&(n(a),t.params.pagination.renderBullet||(o(a,"button"),p(a,e.paginationBulletMessage.replace(/\{\{index\}\}/,a.index()+1)))),a.is(`.${t.params.pagination.bulletActiveClass}`)?a.attr("aria-current","true"):a.removeAttr("aria-current")}))}()})),a("destroy",(()=>{t.params.a11y.enabled&&function(){let e,s;i&&i.length>0&&i.remove(),t.navigation&&t.navigation.$nextEl&&(e=t.navigation.$nextEl),t.navigation&&t.navigation.$prevEl&&(s=t.navigation.$prevEl),e&&e.off("keydown",m),s&&s.off("keydown",m),g()&&t.pagination.$el.off("keydown",U(t.params.pagination.bulletClass),m),t.$el.off("focus",x,!0),t.$el.off("pointerdown",w,!0),t.$el.off("pointerup",b,!0)}()}))},function(e){let{swiper:t,extendParams:s,on:a}=e;s({history:{enabled:!1,root:"",replaceState:!1,key:"slides",keepQuery:!1}});let i=!1,n={};const l=e=>e.toString().replace(/\s+/g,"-").replace(/[^\w-]+/g,"").replace(/--+/g,"-").replace(/^-+/,"").replace(/-+$/,""),o=e=>{const t=r();let s;s=e?new URL(e):t.location;const a=s.pathname.slice(1).split("/").filter((e=>""!==e)),i=a.length;return{key:a[i-2],value:a[i-1]}},d=(e,s)=>{const a=r();if(!i||!t.params.history.enabled)return;let n;n=t.params.url?new URL(t.params.url):a.location;const o=t.slides.eq(s);let d=l(o.attr("data-history"));if(t.params.history.root.length>0){let s=t.params.history.root;"/"===s[s.length-1]&&(s=s.slice(0,s.length-1)),d=`${s}/${e}/${d}`}else n.pathname.includes(e)||(d=`${e}/${d}`);t.params.history.keepQuery&&(d+=n.search);const c=a.history.state;c&&c.value===d||(t.params.history.replaceState?a.history.replaceState({value:d},null,d):a.history.pushState({value:d},null,d))},c=(e,s,a)=>{if(s)for(let i=0,r=t.slides.length;i{n=o(t.params.url),c(t.params.speed,n.value,!1)};a("init",(()=>{t.params.history.enabled&&(()=>{const e=r();if(t.params.history){if(!e.history||!e.history.pushState)return t.params.history.enabled=!1,void(t.params.hashNavigation.enabled=!0);i=!0,n=o(t.params.url),(n.key||n.value)&&(c(0,n.value,t.params.runCallbacksOnInit),t.params.history.replaceState||e.addEventListener("popstate",p))}})()})),a("destroy",(()=>{t.params.history.enabled&&(()=>{const e=r();t.params.history.replaceState||e.removeEventListener("popstate",p)})()})),a("transitionEnd _freeModeNoMomentumRelease",(()=>{i&&d(t.params.history.key,t.activeIndex)})),a("slideChange",(()=>{i&&t.params.cssMode&&d(t.params.history.key,t.activeIndex)}))},function(e){let{swiper:t,extendParams:s,emit:i,on:n}=e,l=!1;const o=a(),c=r();s({hashNavigation:{enabled:!1,replaceState:!1,watchState:!1}});const p=()=>{i("hashChange");const e=o.location.hash.replace("#","");if(e!==t.slides.eq(t.activeIndex).attr("data-hash")){const s=t.$wrapperEl.children(`.${t.params.slideClass}[data-hash="${e}"]`).index();if(void 0===s)return;t.slideTo(s)}},u=()=>{if(l&&t.params.hashNavigation.enabled)if(t.params.hashNavigation.replaceState&&c.history&&c.history.replaceState)c.history.replaceState(null,null,`#${t.slides.eq(t.activeIndex).attr("data-hash")}`||""),i("hashSet");else{const e=t.slides.eq(t.activeIndex),s=e.attr("data-hash")||e.attr("data-history");o.location.hash=s||"",i("hashSet")}};n("init",(()=>{t.params.hashNavigation.enabled&&(()=>{if(!t.params.hashNavigation.enabled||t.params.history&&t.params.history.enabled)return;l=!0;const e=o.location.hash.replace("#","");if(e){const s=0;for(let a=0,i=t.slides.length;a{t.params.hashNavigation.enabled&&t.params.hashNavigation.watchState&&d(c).off("hashchange",p)})),n("transitionEnd _freeModeNoMomentumRelease",(()=>{l&&u()})),n("slideChange",(()=>{l&&t.params.cssMode&&u()}))},function(e){let t,{swiper:s,extendParams:i,on:r,emit:n}=e;function l(){if(!s.size)return s.autoplay.running=!1,void(s.autoplay.paused=!1);const e=s.slides.eq(s.activeIndex);let a=s.params.autoplay.delay;e.attr("data-swiper-autoplay")&&(a=e.attr("data-swiper-autoplay")||s.params.autoplay.delay),clearTimeout(t),t=p((()=>{let e;s.params.autoplay.reverseDirection?s.params.loop?(s.loopFix(),e=s.slidePrev(s.params.speed,!0,!0),n("autoplay")):s.isBeginning?s.params.autoplay.stopOnLastSlide?d():(e=s.slideTo(s.slides.length-1,s.params.speed,!0,!0),n("autoplay")):(e=s.slidePrev(s.params.speed,!0,!0),n("autoplay")):s.params.loop?(s.loopFix(),e=s.slideNext(s.params.speed,!0,!0),n("autoplay")):s.isEnd?s.params.autoplay.stopOnLastSlide?d():(e=s.slideTo(0,s.params.speed,!0,!0),n("autoplay")):(e=s.slideNext(s.params.speed,!0,!0),n("autoplay")),(s.params.cssMode&&s.autoplay.running||!1===e)&&l()}),a)}function o(){return void 0===t&&(!s.autoplay.running&&(s.autoplay.running=!0,n("autoplayStart"),l(),!0))}function d(){return!!s.autoplay.running&&(void 0!==t&&(t&&(clearTimeout(t),t=void 0),s.autoplay.running=!1,n("autoplayStop"),!0))}function c(e){s.autoplay.running&&(s.autoplay.paused||(t&&clearTimeout(t),s.autoplay.paused=!0,0!==e&&s.params.autoplay.waitForTransition?["transitionend","webkitTransitionEnd"].forEach((e=>{s.$wrapperEl[0].addEventListener(e,h)})):(s.autoplay.paused=!1,l())))}function u(){const e=a();"hidden"===e.visibilityState&&s.autoplay.running&&c(),"visible"===e.visibilityState&&s.autoplay.paused&&(l(),s.autoplay.paused=!1)}function h(e){s&&!s.destroyed&&s.$wrapperEl&&e.target===s.$wrapperEl[0]&&(["transitionend","webkitTransitionEnd"].forEach((e=>{s.$wrapperEl[0].removeEventListener(e,h)})),s.autoplay.paused=!1,s.autoplay.running?l():d())}function m(){s.params.autoplay.disableOnInteraction?d():(n("autoplayPause"),c()),["transitionend","webkitTransitionEnd"].forEach((e=>{s.$wrapperEl[0].removeEventListener(e,h)}))}function f(){s.params.autoplay.disableOnInteraction||(s.autoplay.paused=!1,n("autoplayResume"),l())}s.autoplay={running:!1,paused:!1},i({autoplay:{enabled:!1,delay:3e3,waitForTransition:!0,disableOnInteraction:!0,stopOnLastSlide:!1,reverseDirection:!1,pauseOnMouseEnter:!1}}),r("init",(()=>{if(s.params.autoplay.enabled){o();a().addEventListener("visibilitychange",u),s.params.autoplay.pauseOnMouseEnter&&(s.$el.on("mouseenter",m),s.$el.on("mouseleave",f))}})),r("beforeTransitionStart",((e,t,a)=>{s.autoplay.running&&(a||!s.params.autoplay.disableOnInteraction?s.autoplay.pause(t):d())})),r("sliderFirstMove",(()=>{s.autoplay.running&&(s.params.autoplay.disableOnInteraction?d():c())})),r("touchEnd",(()=>{s.params.cssMode&&s.autoplay.paused&&!s.params.autoplay.disableOnInteraction&&l()})),r("destroy",(()=>{s.$el.off("mouseenter",m),s.$el.off("mouseleave",f),s.autoplay.running&&d();a().removeEventListener("visibilitychange",u)})),Object.assign(s.autoplay,{pause:c,run:l,start:o,stop:d})},function(e){let{swiper:t,extendParams:s,on:a}=e;s({thumbs:{swiper:null,multipleActiveThumbs:!0,autoScrollOffset:0,slideThumbActiveClass:"swiper-slide-thumb-active",thumbsContainerClass:"swiper-thumbs"}});let i=!1,r=!1;function n(){const e=t.thumbs.swiper;if(!e||e.destroyed)return;const s=e.clickedIndex,a=e.clickedSlide;if(a&&d(a).hasClass(t.params.thumbs.slideThumbActiveClass))return;if(null==s)return;let i;if(i=e.params.loop?parseInt(d(e.clickedSlide).attr("data-swiper-slide-index"),10):s,t.params.loop){let e=t.activeIndex;t.slides.eq(e).hasClass(t.params.slideDuplicateClass)&&(t.loopFix(),t._clientLeft=t.$wrapperEl[0].clientLeft,e=t.activeIndex);const s=t.slides.eq(e).prevAll(`[data-swiper-slide-index="${i}"]`).eq(0).index(),a=t.slides.eq(e).nextAll(`[data-swiper-slide-index="${i}"]`).eq(0).index();i=void 0===s?a:void 0===a?s:a-e1&&!t.params.centeredSlides&&(i=t.params.slidesPerView),t.params.thumbs.multipleActiveThumbs||(i=1),i=Math.floor(i),s.slides.removeClass(r),s.params.loop||s.params.virtual&&s.params.virtual.enabled)for(let e=0;e1?a:o:a-ot.previousIndex?"next":"prev"}else i=t.realIndex,r=i>t.previousIndex?"next":"prev";l&&(i+="next"===r?n:-1*n),s.visibleSlidesIndexes&&s.visibleSlidesIndexes.indexOf(i)<0&&(s.params.centeredSlides?i=i>o?i-Math.floor(a/2)+1:i+Math.floor(a/2)-1:i>o&&s.params.slidesPerGroup,s.slideTo(i,e?0:void 0))}}t.thumbs={swiper:null},a("beforeInit",(()=>{const{thumbs:e}=t.params;e&&e.swiper&&(l(),o(!0))})),a("slideChange update resize observerUpdate",(()=>{o()})),a("setTransition",((e,s)=>{const a=t.thumbs.swiper;a&&!a.destroyed&&a.setTransition(s)})),a("beforeDestroy",(()=>{const e=t.thumbs.swiper;e&&!e.destroyed&&r&&e.destroy()})),Object.assign(t.thumbs,{init:l,update:o})},function(e){let{swiper:t,extendParams:s,emit:a,once:i}=e;s({freeMode:{enabled:!1,momentum:!0,momentumRatio:1,momentumBounce:!0,momentumBounceRatio:1,momentumVelocityRatio:1,sticky:!1,minimumVelocity:.02}}),Object.assign(t,{freeMode:{onTouchStart:function(){const e=t.getTranslate();t.setTranslate(e),t.setTransition(0),t.touchEventsData.velocities.length=0,t.freeMode.onTouchEnd({currentPos:t.rtl?t.translate:-t.translate})},onTouchMove:function(){const{touchEventsData:e,touches:s}=t;0===e.velocities.length&&e.velocities.push({position:s[t.isHorizontal()?"startX":"startY"],time:e.touchStartTime}),e.velocities.push({position:s[t.isHorizontal()?"currentX":"currentY"],time:u()})},onTouchEnd:function(e){let{currentPos:s}=e;const{params:r,$wrapperEl:n,rtlTranslate:l,snapGrid:o,touchEventsData:d}=t,c=u()-d.touchStartTime;if(s<-t.minTranslate())t.slideTo(t.activeIndex);else if(s>-t.maxTranslate())t.slides.length1){const e=d.velocities.pop(),s=d.velocities.pop(),a=e.position-s.position,i=e.time-s.time;t.velocity=a/i,t.velocity/=2,Math.abs(t.velocity)150||u()-e.time>300)&&(t.velocity=0)}else t.velocity=0;t.velocity*=r.freeMode.momentumVelocityRatio,d.velocities.length=0;let e=1e3*r.freeMode.momentumRatio;const s=t.velocity*e;let c=t.translate+s;l&&(c=-c);let p,h=!1;const m=20*Math.abs(t.velocity)*r.freeMode.momentumBounceRatio;let f;if(ct.minTranslate())r.freeMode.momentumBounce?(c-t.minTranslate()>m&&(c=t.minTranslate()+m),p=t.minTranslate(),h=!0,d.allowMomentumBounce=!0):c=t.minTranslate(),r.loop&&r.centeredSlides&&(f=!0);else if(r.freeMode.sticky){let e;for(let t=0;t-c){e=t;break}c=Math.abs(o[e]-c){t.loopFix()})),0!==t.velocity){if(e=l?Math.abs((-c-t.translate)/t.velocity):Math.abs((c-t.translate)/t.velocity),r.freeMode.sticky){const s=Math.abs((l?-c:c)-t.translate),a=t.slidesSizesGrid[t.activeIndex];e=s{t&&!t.destroyed&&d.allowMomentumBounce&&(a("momentumBounce"),t.setTransition(r.speed),setTimeout((()=>{t.setTranslate(p),n.transitionEnd((()=>{t&&!t.destroyed&&t.transitionEnd()}))}),0))}))):t.velocity?(a("_freeModeNoMomentumRelease"),t.updateProgress(c),t.setTransition(e),t.setTranslate(c),t.transitionStart(!0,t.swipeDirection),t.animating||(t.animating=!0,n.transitionEnd((()=>{t&&!t.destroyed&&t.transitionEnd()})))):t.updateProgress(c),t.updateActiveIndex(),t.updateSlidesClasses()}else{if(r.freeMode.sticky)return void t.slideToClosest();r.freeMode&&a("_freeModeNoMomentumRelease")}(!r.freeMode.momentum||c>=r.longSwipesMs)&&(t.updateProgress(),t.updateActiveIndex(),t.updateSlidesClasses())}}}})},function(e){let t,s,a,{swiper:i,extendParams:r}=e;r({grid:{rows:1,fill:"column"}}),i.grid={initSlides:e=>{const{slidesPerView:r}=i.params,{rows:n,fill:l}=i.params.grid;s=t/n,a=Math.floor(e/n),t=Math.floor(e/n)===e/n?e:Math.ceil(e/n)*n,"auto"!==r&&"row"===l&&(t=Math.max(t,r*n))},updateSlide:(e,r,n,l)=>{const{slidesPerGroup:o,spaceBetween:d}=i.params,{rows:c,fill:p}=i.params.grid;let u,h,m;if("row"===p&&o>1){const s=Math.floor(e/(o*c)),a=e-c*o*s,i=0===s?o:Math.min(Math.ceil((n-s*c*o)/c),o);m=Math.floor(a/i),h=a-m*i+s*o,u=h+m*t/c,r.css({"-webkit-order":u,order:u})}else"column"===p?(h=Math.floor(e/c),m=e-h*c,(h>a||h===a&&m===c-1)&&(m+=1,m>=c&&(m=0,h+=1))):(m=Math.floor(e/s),h=e-m*s);r.css(l("margin-top"),0!==m?d&&`${d}px`:"")},updateWrapperSize:(e,s,a)=>{const{spaceBetween:r,centeredSlides:n,roundLengths:l}=i.params,{rows:o}=i.params.grid;if(i.virtualSize=(e+r)*t,i.virtualSize=Math.ceil(i.virtualSize/o)-r,i.$wrapperEl.css({[a("width")]:`${i.virtualSize+r}px`}),n){s.splice(0,s.length);const e=[];for(let t=0;t{const{slides:e}=t,s=t.params.fadeEffect;for(let a=0;a{const{transformEl:s}=t.params.fadeEffect;(s?t.slides.find(s):t.slides).transition(e),ae({swiper:t,duration:e,transformEl:s,allSlides:!0})},overwriteParams:()=>({slidesPerView:1,slidesPerGroup:1,watchSlidesProgress:!0,spaceBetween:0,virtualTranslate:!t.params.cssMode})})},function(e){let{swiper:t,extendParams:s,on:a}=e;s({cubeEffect:{slideShadows:!0,shadow:!0,shadowOffset:20,shadowScale:.94}});const i=(e,t,s)=>{let a=s?e.find(".swiper-slide-shadow-left"):e.find(".swiper-slide-shadow-top"),i=s?e.find(".swiper-slide-shadow-right"):e.find(".swiper-slide-shadow-bottom");0===a.length&&(a=d(`
`),e.append(a)),0===i.length&&(i=d(`
`),e.append(i)),a.length&&(a[0].style.opacity=Math.max(-t,0)),i.length&&(i[0].style.opacity=Math.max(t,0))};te({effect:"cube",swiper:t,on:a,setTranslate:()=>{const{$el:e,$wrapperEl:s,slides:a,width:r,height:n,rtlTranslate:l,size:o,browser:c}=t,p=t.params.cubeEffect,u=t.isHorizontal(),h=t.virtual&&t.params.virtual.enabled;let m,f=0;p.shadow&&(u?(m=s.find(".swiper-cube-shadow"),0===m.length&&(m=d('
'),s.append(m)),m.css({height:`${r}px`})):(m=e.find(".swiper-cube-shadow"),0===m.length&&(m=d('
'),e.append(m))));for(let e=0;e-1&&(f=90*s+90*d,l&&(f=90*-s-90*d)),t.transform(v),p.slideShadows&&i(t,d,u)}if(s.css({"-webkit-transform-origin":`50% 50% -${o/2}px`,"transform-origin":`50% 50% -${o/2}px`}),p.shadow)if(u)m.transform(`translate3d(0px, ${r/2+p.shadowOffset}px, ${-r/2}px) rotateX(90deg) rotateZ(0deg) scale(${p.shadowScale})`);else{const e=Math.abs(f)-90*Math.floor(Math.abs(f)/90),t=1.5-(Math.sin(2*e*Math.PI/360)/2+Math.cos(2*e*Math.PI/360)/2),s=p.shadowScale,a=p.shadowScale/t,i=p.shadowOffset;m.transform(`scale3d(${s}, 1, ${a}) translate3d(0px, ${n/2+i}px, ${-n/2/a}px) rotateX(-90deg)`)}const g=c.isSafari||c.isWebView?-o/2:0;s.transform(`translate3d(0px,0,${g}px) rotateX(${t.isHorizontal()?0:f}deg) rotateY(${t.isHorizontal()?-f:0}deg)`),s[0].style.setProperty("--swiper-cube-translate-z",`${g}px`)},setTransition:e=>{const{$el:s,slides:a}=t;a.transition(e).find(".swiper-slide-shadow-top, .swiper-slide-shadow-right, .swiper-slide-shadow-bottom, .swiper-slide-shadow-left").transition(e),t.params.cubeEffect.shadow&&!t.isHorizontal()&&s.find(".swiper-cube-shadow").transition(e)},recreateShadows:()=>{const e=t.isHorizontal();t.slides.each((t=>{const s=Math.max(Math.min(t.progress,1),-1);i(d(t),s,e)}))},getEffectParams:()=>t.params.cubeEffect,perspective:()=>!0,overwriteParams:()=>({slidesPerView:1,slidesPerGroup:1,watchSlidesProgress:!0,resistanceRatio:0,spaceBetween:0,centeredSlides:!1,virtualTranslate:!0})})},function(e){let{swiper:t,extendParams:s,on:a}=e;s({flipEffect:{slideShadows:!0,limitRotation:!0,transformEl:null}});const i=(e,s,a)=>{let i=t.isHorizontal()?e.find(".swiper-slide-shadow-left"):e.find(".swiper-slide-shadow-top"),r=t.isHorizontal()?e.find(".swiper-slide-shadow-right"):e.find(".swiper-slide-shadow-bottom");0===i.length&&(i=ie(a,e,t.isHorizontal()?"left":"top")),0===r.length&&(r=ie(a,e,t.isHorizontal()?"right":"bottom")),i.length&&(i[0].style.opacity=Math.max(-s,0)),r.length&&(r[0].style.opacity=Math.max(s,0))};te({effect:"flip",swiper:t,on:a,setTranslate:()=>{const{slides:e,rtlTranslate:s}=t,a=t.params.flipEffect;for(let r=0;r{const{transformEl:s}=t.params.flipEffect;(s?t.slides.find(s):t.slides).transition(e).find(".swiper-slide-shadow-top, .swiper-slide-shadow-right, .swiper-slide-shadow-bottom, .swiper-slide-shadow-left").transition(e),ae({swiper:t,duration:e,transformEl:s})},recreateShadows:()=>{const e=t.params.flipEffect;t.slides.each((s=>{const a=d(s);let r=a[0].progress;t.params.flipEffect.limitRotation&&(r=Math.max(Math.min(s.progress,1),-1)),i(a,r,e)}))},getEffectParams:()=>t.params.flipEffect,perspective:()=>!0,overwriteParams:()=>({slidesPerView:1,slidesPerGroup:1,watchSlidesProgress:!0,spaceBetween:0,virtualTranslate:!t.params.cssMode})})},function(e){let{swiper:t,extendParams:s,on:a}=e;s({coverflowEffect:{rotate:50,stretch:0,depth:100,scale:1,modifier:1,slideShadows:!0,transformEl:null}}),te({effect:"coverflow",swiper:t,on:a,setTranslate:()=>{const{width:e,height:s,slides:a,slidesSizesGrid:i}=t,r=t.params.coverflowEffect,n=t.isHorizontal(),l=t.translate,o=n?e/2-l:s/2-l,d=n?r.rotate:-r.rotate,c=r.depth;for(let e=0,t=a.length;e0?p:0),s.length&&(s[0].style.opacity=-p>0?-p:0)}}},setTransition:e=>{const{transformEl:s}=t.params.coverflowEffect;(s?t.slides.find(s):t.slides).transition(e).find(".swiper-slide-shadow-top, .swiper-slide-shadow-right, .swiper-slide-shadow-bottom, .swiper-slide-shadow-left").transition(e)},perspective:()=>!0,overwriteParams:()=>({watchSlidesProgress:!0})})},function(e){let{swiper:t,extendParams:s,on:a}=e;s({creativeEffect:{transformEl:null,limitProgress:1,shadowPerProgress:!1,progressMultiplier:1,perspective:!0,prev:{translate:[0,0,0],rotate:[0,0,0],opacity:1,scale:1},next:{translate:[0,0,0],rotate:[0,0,0],opacity:1,scale:1}}});const i=e=>"string"==typeof e?e:`${e}px`;te({effect:"creative",swiper:t,on:a,setTranslate:()=>{const{slides:e,$wrapperEl:s,slidesSizesGrid:a}=t,r=t.params.creativeEffect,{progressMultiplier:n}=r,l=t.params.centeredSlides;if(l){const e=a[0]/2-t.params.slidesOffsetBefore||0;s.transform(`translateX(calc(50% - ${e}px))`)}for(let s=0;s0&&(f=r.prev,m=!0),u.forEach(((e,t)=>{u[t]=`calc(${e}px + (${i(f.translate[t])} * ${Math.abs(d*n)}))`})),h.forEach(((e,t)=>{h[t]=f.rotate[t]*Math.abs(d*n)})),a[0].style.zIndex=-Math.abs(Math.round(o))+e.length;const g=u.join(", "),v=`rotateX(${h[0]}deg) rotateY(${h[1]}deg) rotateZ(${h[2]}deg)`,w=c<0?`scale(${1+(1-f.scale)*c*n})`:`scale(${1-(1-f.scale)*c*n})`,b=c<0?1+(1-f.opacity)*c*n:1-(1-f.opacity)*c*n,x=`translate3d(${g}) ${v} ${w}`;if(m&&f.shadow||!m){let e=a.children(".swiper-slide-shadow");if(0===e.length&&f.shadow&&(e=ie(r,a)),e.length){const t=r.shadowPerProgress?d*(1/r.limitProgress):d;e[0].style.opacity=Math.min(Math.max(Math.abs(t),0),1)}}const y=se(r,a);y.transform(x).css({opacity:b}),f.origin&&y.css("transform-origin",f.origin)}},setTransition:e=>{const{transformEl:s}=t.params.creativeEffect;(s?t.slides.find(s):t.slides).transition(e).find(".swiper-slide-shadow").transition(e),ae({swiper:t,duration:e,transformEl:s,allSlides:!0})},perspective:()=>t.params.creativeEffect.perspective,overwriteParams:()=>({watchSlidesProgress:!0,virtualTranslate:!t.params.cssMode})})},function(e){let{swiper:t,extendParams:s,on:a}=e;s({cardsEffect:{slideShadows:!0,transformEl:null,rotate:!0,perSlideRotate:2,perSlideOffset:8}}),te({effect:"cards",swiper:t,on:a,setTranslate:()=>{const{slides:e,activeIndex:s}=t,a=t.params.cardsEffect,{startTranslate:i,isTouched:r}=t.touchEventsData,n=t.translate;for(let l=0;l0&&c<1&&(r||t.params.cssMode)&&n-1&&(r||t.params.cssMode)&&n>i;if(b||x){const e=(1-Math.abs((Math.abs(c)-.5)/.5))**.5;g+=-28*c*e,f+=-.5*e,v+=96*e,h=-25*e*Math.abs(c)+"%"}if(u=c<0?`calc(${u}px + (${v*Math.abs(c)}%))`:c>0?`calc(${u}px + (-${v*Math.abs(c)}%))`:`${u}px`,!t.isHorizontal()){const e=h;h=u,u=e}const y=c<0?""+(1+(1-f)*c):""+(1-(1-f)*c),E=`\n translate3d(${u}, ${h}, ${m}px)\n rotateZ(${a.rotate?g:0}deg)\n scale(${y})\n `;if(a.slideShadows){let e=o.find(".swiper-slide-shadow");0===e.length&&(e=ie(a,o)),e.length&&(e[0].style.opacity=Math.min(Math.max((Math.abs(c)-.5)/.5,0),1))}o[0].style.zIndex=-Math.abs(Math.round(d))+e.length;se(a,o).transform(E)}},setTransition:e=>{const{transformEl:s}=t.params.cardsEffect;(s?t.slides.find(s):t.slides).transition(e).find(".swiper-slide-shadow").transition(e),ae({swiper:t,duration:e,transformEl:s})},perspective:()=>!0,overwriteParams:()=>({watchSlidesProgress:!0,virtualTranslate:!t.params.cssMode})})}];return V.use(re),V})); +//# sourceMappingURL=swiper-bundle.min.js.map \ No newline at end of file diff --git a/apps/smp-server/static/media/tailwind.css b/apps/smp-server/static/media/tailwind.css new file mode 100644 index 000000000..04ea69992 --- /dev/null +++ b/apps/smp-server/static/media/tailwind.css @@ -0,0 +1,3058 @@ +/* +! tailwindcss v3.3.1 | MIT License | https://tailwindcss.com +*/ + +/* +1. Prevent padding and border from affecting element width. (https://github.com/mozdevs/cssremedy/issues/4) +2. Allow adding a border to an element by just adding a border-width. (https://github.com/tailwindcss/tailwindcss/pull/116) +*/ + +*, +::before, +::after { + box-sizing: border-box; + /* 1 */ + border-width: 0; + /* 2 */ + border-style: solid; + /* 2 */ + border-color: #e5e7eb; + /* 2 */ +} + +::before, +::after { + --tw-content: ''; +} + +/* +1. Use a consistent sensible line-height in all browsers. +2. Prevent adjustments of font size after orientation changes in iOS. +3. Use a more readable tab size. +4. Use the user's configured `sans` font-family by default. +5. Use the user's configured `sans` font-feature-settings by default. +6. Use the user's configured `sans` font-variation-settings by default. +*/ + +html { + line-height: 1.5; + /* 1 */ + -webkit-text-size-adjust: 100%; + /* 2 */ + -moz-tab-size: 4; + /* 3 */ + -o-tab-size: 4; + tab-size: 4; + /* 3 */ + font-family: ui-sans-serif, system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, "Helvetica Neue", Arial, "Noto Sans", sans-serif, "Apple Color Emoji", "Segoe UI Emoji", "Segoe UI Symbol", "Noto Color Emoji"; + /* 4 */ + font-feature-settings: normal; + /* 5 */ + font-variation-settings: normal; + /* 6 */ +} + +/* +1. Remove the margin in all browsers. +2. Inherit line-height from `html` so users can set them as a class directly on the `html` element. +*/ + +body { + margin: 0; + /* 1 */ + line-height: inherit; + /* 2 */ +} + +/* +1. Add the correct height in Firefox. +2. Correct the inheritance of border color in Firefox. (https://bugzilla.mozilla.org/show_bug.cgi?id=190655) +3. Ensure horizontal rules are visible by default. +*/ + +hr { + height: 0; + /* 1 */ + color: inherit; + /* 2 */ + border-top-width: 1px; + /* 3 */ +} + +/* +Add the correct text decoration in Chrome, Edge, and Safari. +*/ + +abbr:where([title]) { + -webkit-text-decoration: underline dotted; + text-decoration: underline dotted; +} + +/* +Remove the default font size and weight for headings. +*/ + +h1, +h2, +h3, +h4, +h5, +h6 { + font-size: inherit; + font-weight: inherit; +} + +/* +Reset links to optimize for opt-in styling instead of opt-out. +*/ + +a { + color: inherit; + text-decoration: inherit; +} + +/* +Add the correct font weight in Edge and Safari. +*/ + +b, +strong { + font-weight: bolder; +} + +/* +1. Use the user's configured `mono` font family by default. +2. Correct the odd `em` font sizing in all browsers. +*/ + +code, +kbd, +samp, +pre { + font-family: ui-monospace, SFMono-Regular, Menlo, Monaco, Consolas, "Liberation Mono", "Courier New", monospace; + /* 1 */ + font-size: 1em; + /* 2 */ +} + +/* +Add the correct font size in all browsers. +*/ + +small { + font-size: 80%; +} + +/* +Prevent `sub` and `sup` elements from affecting the line height in all browsers. +*/ + +sub, +sup { + font-size: 75%; + line-height: 0; + position: relative; + vertical-align: baseline; +} + +sub { + bottom: -0.25em; +} + +sup { + top: -0.5em; +} + +/* +1. Remove text indentation from table contents in Chrome and Safari. (https://bugs.chromium.org/p/chromium/issues/detail?id=999088, https://bugs.webkit.org/show_bug.cgi?id=201297) +2. Correct table border color inheritance in all Chrome and Safari. (https://bugs.chromium.org/p/chromium/issues/detail?id=935729, https://bugs.webkit.org/show_bug.cgi?id=195016) +3. Remove gaps between table borders by default. +*/ + +table { + text-indent: 0; + /* 1 */ + border-color: inherit; + /* 2 */ + border-collapse: collapse; + /* 3 */ +} + +/* +1. Change the font styles in all browsers. +2. Remove the margin in Firefox and Safari. +3. Remove default padding in all browsers. +*/ + +button, +input, +optgroup, +select, +textarea { + font-family: inherit; + /* 1 */ + font-size: 100%; + /* 1 */ + font-weight: inherit; + /* 1 */ + line-height: inherit; + /* 1 */ + color: inherit; + /* 1 */ + margin: 0; + /* 2 */ + padding: 0; + /* 3 */ +} + +/* +Remove the inheritance of text transform in Edge and Firefox. +*/ + +button, +select { + text-transform: none; +} + +/* +1. Correct the inability to style clickable types in iOS and Safari. +2. Remove default button styles. +*/ + +button, +[type='button'], +[type='reset'], +[type='submit'] { + -webkit-appearance: button; + /* 1 */ + background-color: transparent; + /* 2 */ + background-image: none; + /* 2 */ +} + +/* +Use the modern Firefox focus style for all focusable elements. +*/ + +:-moz-focusring { + outline: auto; +} + +/* +Remove the additional `:invalid` styles in Firefox. (https://github.com/mozilla/gecko-dev/blob/2f9eacd9d3d995c937b4251a5557d95d494c9be1/layout/style/res/forms.css#L728-L737) +*/ + +:-moz-ui-invalid { + box-shadow: none; +} + +/* +Add the correct vertical alignment in Chrome and Firefox. +*/ + +progress { + vertical-align: baseline; +} + +/* +Correct the cursor style of increment and decrement buttons in Safari. +*/ + +::-webkit-inner-spin-button, +::-webkit-outer-spin-button { + height: auto; +} + +/* +1. Correct the odd appearance in Chrome and Safari. +2. Correct the outline style in Safari. +*/ + +[type='search'] { + -webkit-appearance: textfield; + /* 1 */ + outline-offset: -2px; + /* 2 */ +} + +/* +Remove the inner padding in Chrome and Safari on macOS. +*/ + +::-webkit-search-decoration { + -webkit-appearance: none; +} + +/* +1. Correct the inability to style clickable types in iOS and Safari. +2. Change font properties to `inherit` in Safari. +*/ + +::-webkit-file-upload-button { + -webkit-appearance: button; + /* 1 */ + font: inherit; + /* 2 */ +} + +/* +Add the correct display in Chrome and Safari. +*/ + +summary { + display: list-item; +} + +/* +Removes the default spacing and border for appropriate elements. +*/ + +blockquote, +dl, +dd, +h1, +h2, +h3, +h4, +h5, +h6, +hr, +figure, +p, +pre { + margin: 0; +} + +fieldset { + margin: 0; + padding: 0; +} + +legend { + padding: 0; +} + +ol, +ul, +menu { + list-style: none; + margin: 0; + padding: 0; +} + +/* +Prevent resizing textareas horizontally by default. +*/ + +textarea { + resize: vertical; +} + +/* +1. Reset the default placeholder opacity in Firefox. (https://github.com/tailwindlabs/tailwindcss/issues/3300) +2. Set the default placeholder color to the user's configured gray 400 color. +*/ + +input::-moz-placeholder, textarea::-moz-placeholder { + opacity: 1; + /* 1 */ + color: #9ca3af; + /* 2 */ +} + +input::placeholder, +textarea::placeholder { + opacity: 1; + /* 1 */ + color: #9ca3af; + /* 2 */ +} + +/* +Set the default cursor for buttons. +*/ + +button, +[role="button"] { + cursor: pointer; +} + +/* +Make sure disabled buttons don't get the pointer cursor. +*/ + +:disabled { + cursor: default; +} + +/* +1. Make replaced elements `display: block` by default. (https://github.com/mozdevs/cssremedy/issues/14) +2. Add `vertical-align: middle` to align replaced elements more sensibly by default. (https://github.com/jensimmons/cssremedy/issues/14#issuecomment-634934210) + This can trigger a poorly considered lint error in some tools but is included by design. +*/ + +img, +svg, +video, +canvas, +audio, +iframe, +embed, +object { + display: block; + /* 1 */ + vertical-align: middle; + /* 2 */ +} + +/* +Constrain images and videos to the parent width and preserve their intrinsic aspect ratio. (https://github.com/mozdevs/cssremedy/issues/14) +*/ + +img, +video { + max-width: 100%; + height: auto; +} + +/* Make elements with the HTML hidden attribute stay hidden by default */ + +[hidden] { + display: none; +} + +*, ::before, ::after { + --tw-border-spacing-x: 0; + --tw-border-spacing-y: 0; + --tw-translate-x: 0; + --tw-translate-y: 0; + --tw-rotate: 0; + --tw-skew-x: 0; + --tw-skew-y: 0; + --tw-scale-x: 1; + --tw-scale-y: 1; + --tw-pan-x: ; + --tw-pan-y: ; + --tw-pinch-zoom: ; + --tw-scroll-snap-strictness: proximity; + --tw-ordinal: ; + --tw-slashed-zero: ; + --tw-numeric-figure: ; + --tw-numeric-spacing: ; + --tw-numeric-fraction: ; + --tw-ring-inset: ; + --tw-ring-offset-width: 0px; + --tw-ring-offset-color: #fff; + --tw-ring-color: rgb(59 130 246 / 0.5); + --tw-ring-offset-shadow: 0 0 #0000; + --tw-ring-shadow: 0 0 #0000; + --tw-shadow: 0 0 #0000; + --tw-shadow-colored: 0 0 #0000; + --tw-blur: ; + --tw-brightness: ; + --tw-contrast: ; + --tw-grayscale: ; + --tw-hue-rotate: ; + --tw-invert: ; + --tw-saturate: ; + --tw-sepia: ; + --tw-drop-shadow: ; + --tw-backdrop-blur: ; + --tw-backdrop-brightness: ; + --tw-backdrop-contrast: ; + --tw-backdrop-grayscale: ; + --tw-backdrop-hue-rotate: ; + --tw-backdrop-invert: ; + --tw-backdrop-opacity: ; + --tw-backdrop-saturate: ; + --tw-backdrop-sepia: ; +} + +::backdrop { + --tw-border-spacing-x: 0; + --tw-border-spacing-y: 0; + --tw-translate-x: 0; + --tw-translate-y: 0; + --tw-rotate: 0; + --tw-skew-x: 0; + --tw-skew-y: 0; + --tw-scale-x: 1; + --tw-scale-y: 1; + --tw-pan-x: ; + --tw-pan-y: ; + --tw-pinch-zoom: ; + --tw-scroll-snap-strictness: proximity; + --tw-ordinal: ; + --tw-slashed-zero: ; + --tw-numeric-figure: ; + --tw-numeric-spacing: ; + --tw-numeric-fraction: ; + --tw-ring-inset: ; + --tw-ring-offset-width: 0px; + --tw-ring-offset-color: #fff; + --tw-ring-color: rgb(59 130 246 / 0.5); + --tw-ring-offset-shadow: 0 0 #0000; + --tw-ring-shadow: 0 0 #0000; + --tw-shadow: 0 0 #0000; + --tw-shadow-colored: 0 0 #0000; + --tw-blur: ; + --tw-brightness: ; + --tw-contrast: ; + --tw-grayscale: ; + --tw-hue-rotate: ; + --tw-invert: ; + --tw-saturate: ; + --tw-sepia: ; + --tw-drop-shadow: ; + --tw-backdrop-blur: ; + --tw-backdrop-brightness: ; + --tw-backdrop-contrast: ; + --tw-backdrop-grayscale: ; + --tw-backdrop-hue-rotate: ; + --tw-backdrop-invert: ; + --tw-backdrop-opacity: ; + --tw-backdrop-saturate: ; + --tw-backdrop-sepia: ; +} + +.container { + width: 100%; +} + +@media (min-width: 640px) { + .container { + max-width: 640px; + } +} + +@media (min-width: 768px) { + .container { + max-width: 768px; + } +} + +@media (min-width: 1024px) { + .container { + max-width: 1024px; + } +} + +@media (min-width: 1280px) { + .container { + max-width: 1280px; + } +} + +@media (min-width: 1536px) { + .container { + max-width: 1536px; + } +} + +.visible { + visibility: visible; +} + +.static { + position: static; +} + +.fixed { + position: fixed; +} + +.absolute { + position: absolute; +} + +.relative { + position: relative; +} + +.sticky { + position: sticky; +} + +.-left-10 { + left: -2.5rem; +} + +.bottom-0 { + bottom: 0px; +} + +.bottom-\[80px\] { + bottom: 80px; +} + +.left-0 { + left: 0px; +} + +.left-1 { + left: 0.25rem; +} + +.left-\[-3px\] { + left: -3px; +} + +.right-0 { + right: 0px; +} + +.right-1 { + right: 0.25rem; +} + +.right-\[-6px\] { + right: -6px; +} + +.top-0 { + top: 0px; +} + +.top-10 { + top: 2.5rem; +} + +.top-11 { + top: 2.75rem; +} + +.top-\[52\%\] { + top: 52%; +} + +.top-\[66px\] { + top: 66px; +} + +.top-full { + top: 100%; +} + +.z-10 { + z-index: 10; +} + +.z-50 { + z-index: 50; +} + +.z-\[10000\] { + z-index: 10000; +} + +.z-\[10001\] { + z-index: 10001; +} + +.z-\[49\] { + z-index: 49; +} + +.float-right { + float: right; +} + +.m-1 { + margin: 0.25rem; +} + +.m-auto { + margin: auto; +} + +.\!my-4 { + margin-top: 1rem !important; + margin-bottom: 1rem !important; +} + +.mx-5 { + margin-left: 1.25rem; + margin-right: 1.25rem; +} + +.my-10 { + margin-top: 2.5rem; + margin-bottom: 2.5rem; +} + +.my-4 { + margin-top: 1rem; + margin-bottom: 1rem; +} + +.my-5 { + margin-top: 1.25rem; + margin-bottom: 1.25rem; +} + +.my-\[40px\] { + margin-top: 40px; + margin-bottom: 40px; +} + +.mb-10 { + margin-bottom: 2.5rem; +} + +.mb-12 { + margin-bottom: 3rem; +} + +.mb-14 { + margin-bottom: 3.5rem; +} + +.mb-16 { + margin-bottom: 4rem; +} + +.mb-2 { + margin-bottom: 0.5rem; +} + +.mb-20 { + margin-bottom: 5rem; +} + +.mb-24 { + margin-bottom: 6rem; +} + +.mb-3 { + margin-bottom: 0.75rem; +} + +.mb-32 { + margin-bottom: 8rem; +} + +.mb-4 { + margin-bottom: 1rem; +} + +.mb-5 { + margin-bottom: 1.25rem; +} + +.mb-6 { + margin-bottom: 1.5rem; +} + +.mb-7 { + margin-bottom: 1.75rem; +} + +.mb-8 { + margin-bottom: 2rem; +} + +.mb-9 { + margin-bottom: 2.25rem; +} + +.mb-\[11px\] { + margin-bottom: 11px; +} + +.mb-\[12px\] { + margin-bottom: 12px; +} + +.mb-\[16px\] { + margin-bottom: 16px; +} + +.mb-\[20px\] { + margin-bottom: 20px; +} + +.mb-\[24px\] { + margin-bottom: 24px; +} + +.mb-\[28px\] { + margin-bottom: 28px; +} + +.mb-\[30px\] { + margin-bottom: 30px; +} + +.mb-\[32px\] { + margin-bottom: 32px; +} + +.mb-\[36px\] { + margin-bottom: 36px; +} + +.mb-\[40px\] { + margin-bottom: 40px; +} + +.mb-\[46px\] { + margin-bottom: 46px; +} + +.mb-\[50px\] { + margin-bottom: 50px; +} + +.mb-\[54px\] { + margin-bottom: 54px; +} + +.mb-\[62px\] { + margin-bottom: 62px; +} + +.mb-\[74px\] { + margin-bottom: 74px; +} + +.mb-\[75px\] { + margin-bottom: 75px; +} + +.mb-\[76px\] { + margin-bottom: 76px; +} + +.mb-\[80px\] { + margin-bottom: 80px; +} + +.ml-\[-15px\] { + margin-left: -15px; +} + +.ml-\[-6px\] { + margin-left: -6px; +} + +.mr-\[-4px\] { + margin-right: -4px; +} + +.mt-1 { + margin-top: 0.25rem; +} + +.mt-10 { + margin-top: 2.5rem; +} + +.mt-2 { + margin-top: 0.5rem; +} + +.mt-6 { + margin-top: 1.5rem; +} + +.mt-\[-100px\] { + margin-top: -100px; +} + +.mt-\[10px\] { + margin-top: 10px; +} + +.mt-\[14px\] { + margin-top: 14px; +} + +.mt-\[30px\] { + margin-top: 30px; +} + +.mt-\[60px\] { + margin-top: 60px; +} + +.mt-\[66px\] { + margin-top: 66px; +} + +.mt-\[74px\] { + margin-top: 74px; +} + +.mt-\[8px\] { + margin-top: 8px; +} + +.mt-auto { + margin-top: auto; +} + +.block { + display: block; +} + +.inline-block { + display: inline-block; +} + +.inline { + display: inline; +} + +.flex { + display: flex; +} + +.table { + display: table; +} + +.grid { + display: grid; +} + +.hidden { + display: none; +} + +.h-1 { + height: 0.25rem; +} + +.h-11 { + height: 2.75rem; +} + +.h-4 { + height: 1rem; +} + +.h-6 { + height: 1.5rem; +} + +.h-\[110px\] { + height: 110px; +} + +.h-\[131px\] { + height: 131px; +} + +.h-\[138px\] { + height: 138px; +} + +.h-\[180px\] { + height: 180px; +} + +.h-\[1px\] { + height: 1px; +} + +.h-\[215px\] { + height: 215px; +} + +.h-\[322px\] { + height: 322px; +} + +.h-\[32px\] { + height: 32px; +} + +.h-\[340px\] { + height: 340px; +} + +.h-\[34px\] { + height: 34px; +} + +.h-\[36px\] { + height: 36px; +} + +.h-\[40px\] { + height: 40px; +} + +.h-\[44px\] { + height: 44px; +} + +.h-\[46px\] { + height: 46px; +} + +.h-\[480px\] { + height: 480px; +} + +.h-\[52px\] { + height: 52px; +} + +.h-\[55\%\] { + height: 55%; +} + +.h-\[66px\] { + height: 66px; +} + +.h-\[80px\] { + height: 80px; +} + +.h-\[calc\(100\%-81\.42px\)\] { + height: calc(100% - 81.42px); +} + +.h-\[inherit\] { + height: inherit; +} + +.h-auto { + height: auto; +} + +.h-fit { + height: -moz-fit-content; + height: fit-content; +} + +.h-full { + height: 100%; +} + +.h-screen { + height: 100vh; +} + +.max-h-\[226px\] { + max-height: 226px; +} + +.max-h-\[50px\] { + max-height: 50px; +} + +.min-h-\[131px\] { + min-height: 131px; +} + +.min-h-\[200px\] { + min-height: 200px; +} + +.min-h-\[620px\] { + min-height: 620px; +} + +.min-h-\[inherit\] { + min-height: inherit; +} + +.w-4 { + width: 1rem; +} + +.w-8 { + width: 2rem; +} + +.w-\[175px\] { + width: 175px; +} + +.w-\[235px\] { + width: 235px; +} + +.w-\[238px\] { + width: 238px; +} + +.w-\[36px\] { + width: 36px; +} + +.w-\[44px\] { + width: 44px; +} + +.w-\[630px\] { + width: 630px; +} + +.w-\[inherit\] { + width: inherit; +} + +.w-auto { + width: auto; +} + +.w-full { + width: 100%; +} + +.min-w-\[152px\] { + min-width: 152px; +} + +.min-w-\[170px\] { + min-width: 170px; +} + +.min-w-\[180px\] { + min-width: 180px; +} + +.min-w-\[210px\] { + min-width: 210px; +} + +.min-w-\[300px\] { + min-width: 300px; +} + +.max-w-\[223px\] { + max-width: 223px; +} + +.max-w-\[230px\] { + max-width: 230px; +} + +.max-w-\[234px\] { + max-width: 234px; +} + +.max-w-\[240px\] { + max-width: 240px; +} + +.max-w-\[265px\] { + max-width: 265px; +} + +.max-w-\[280px\] { + max-width: 280px; +} + +.max-w-\[294px\] { + max-width: 294px; +} + +.max-w-\[400px\] { + max-width: 400px; +} + +.max-w-\[448px\] { + max-width: 448px; +} + +.max-w-\[468px\] { + max-width: 468px; +} + +.max-w-\[475px\] { + max-width: 475px; +} + +.max-w-\[500px\] { + max-width: 500px; +} + +.max-w-\[540px\] { + max-width: 540px; +} + +.max-w-\[541px\] { + max-width: 541px; +} + +.max-w-\[602px\] { + max-width: 602px; +} + +.max-w-\[617px\] { + max-width: 617px; +} + +.max-w-\[900px\] { + max-width: 900px; +} + +.flex-1 { + flex: 1 1 0%; +} + +.flex-\[1\] { + flex: 1; +} + +.flex-\[2\.5\] { + flex: 2.5; +} + +.border-separate { + border-collapse: separate; +} + +.border-spacing-x-5 { + --tw-border-spacing-x: 1.25rem; + border-spacing: var(--tw-border-spacing-x) var(--tw-border-spacing-y); +} + +.border-spacing-y-2 { + --tw-border-spacing-y: 0.5rem; + border-spacing: var(--tw-border-spacing-x) var(--tw-border-spacing-y); +} + +.translate-x-\[-30\%\] { + --tw-translate-x: -30%; + transform: translate(var(--tw-translate-x), var(--tw-translate-y)) rotate(var(--tw-rotate)) skewX(var(--tw-skew-x)) skewY(var(--tw-skew-y)) scaleX(var(--tw-scale-x)) scaleY(var(--tw-scale-y)); +} + +.translate-y-\[-30\%\] { + --tw-translate-y: -30%; + transform: translate(var(--tw-translate-x), var(--tw-translate-y)) rotate(var(--tw-rotate)) skewX(var(--tw-skew-x)) skewY(var(--tw-skew-y)) scaleX(var(--tw-scale-x)) scaleY(var(--tw-scale-y)); +} + +.scale-100 { + --tw-scale-x: 1; + --tw-scale-y: 1; + transform: translate(var(--tw-translate-x), var(--tw-translate-y)) rotate(var(--tw-rotate)) skewX(var(--tw-skew-x)) skewY(var(--tw-skew-y)) scaleX(var(--tw-scale-x)) scaleY(var(--tw-scale-y)); +} + +.transform { + transform: translate(var(--tw-translate-x), var(--tw-translate-y)) rotate(var(--tw-rotate)) skewX(var(--tw-skew-x)) skewY(var(--tw-skew-y)) scaleX(var(--tw-scale-x)) scaleY(var(--tw-scale-y)); +} + +.cursor-pointer { + cursor: pointer; +} + +.resize { + resize: both; +} + +.list-inside { + list-style-position: inside; +} + +.list-decimal { + list-style-type: decimal; +} + +.grid-cols-1 { + grid-template-columns: repeat(1, minmax(0, 1fr)); +} + +.flex-row { + flex-direction: row; +} + +.flex-col { + flex-direction: column; +} + +.flex-col-reverse { + flex-direction: column-reverse; +} + +.flex-wrap { + flex-wrap: wrap; +} + +.items-start { + align-items: flex-start; +} + +.items-end { + align-items: flex-end; +} + +.items-center { + align-items: center; +} + +.justify-end { + justify-content: flex-end; +} + +.justify-center { + justify-content: center; +} + +.justify-between { + justify-content: space-between; +} + +.justify-around { + justify-content: space-around; +} + +.gap-1 { + gap: 0.25rem; +} + +.gap-10 { + gap: 2.5rem; +} + +.gap-12 { + gap: 3rem; +} + +.gap-16 { + gap: 4rem; +} + +.gap-2 { + gap: 0.5rem; +} + +.gap-3 { + gap: 0.75rem; +} + +.gap-4 { + gap: 1rem; +} + +.gap-5 { + gap: 1.25rem; +} + +.gap-6 { + gap: 1.5rem; +} + +.gap-\[150px\] { + gap: 150px; +} + +.gap-\[20px\] { + gap: 20px; +} + +.gap-\[50px\] { + gap: 50px; +} + +.gap-x-10 { + -moz-column-gap: 2.5rem; + column-gap: 2.5rem; +} + +.gap-y-32 { + row-gap: 8rem; +} + +.self-center { + align-self: center; +} + +.self-stretch { + align-self: stretch; +} + +.overflow-auto { + overflow: auto; +} + +.overflow-hidden { + overflow: hidden; +} + +.truncate { + overflow: hidden; + text-overflow: ellipsis; + white-space: nowrap; +} + +.whitespace-nowrap { + white-space: nowrap; +} + +.break-words { + overflow-wrap: break-word; +} + +.rounded { + border-radius: 0.25rem; +} + +.rounded-\[12px\] { + border-radius: 12px; +} + +.rounded-\[20px\] { + border-radius: 20px; +} + +.rounded-\[30px\] { + border-radius: 30px; +} + +.rounded-\[34px\] { + border-radius: 34px; +} + +.rounded-\[4px\] { + border-radius: 4px; +} + +.rounded-full { + border-radius: 9999px; +} + +.rounded-lg { + border-radius: 0.5rem; +} + +.rounded-md { + border-radius: 0.375rem; +} + +.rounded-b-\[20px\] { + border-bottom-right-radius: 20px; + border-bottom-left-radius: 20px; +} + +.border { + border-width: 1px; +} + +.border-\[1px\] { + border-width: 1px; +} + +.border-solid { + border-style: solid; +} + +.border-\[\#0053D0\] { + --tw-border-opacity: 1; + border-color: rgb(0 83 208 / var(--tw-border-opacity)); +} + +.border-\[\#859096\] { + --tw-border-opacity: 1; + border-color: rgb(133 144 150 / var(--tw-border-opacity)); +} + +.border-\[\#A8B0B4\] { + --tw-border-opacity: 1; + border-color: rgb(168 176 180 / var(--tw-border-opacity)); +} + +.border-primary-light { + --tw-border-opacity: 1; + border-color: rgb(0 83 208 / var(--tw-border-opacity)); +} + +.border-opacity-60 { + --tw-border-opacity: 0.6; +} + +.bg-\[\#0053D0\] { + --tw-bg-opacity: 1; + background-color: rgb(0 83 208 / var(--tw-bg-opacity)); +} + +.bg-\[\#0197FF\] { + --tw-bg-opacity: 1; + background-color: rgb(1 151 255 / var(--tw-bg-opacity)); +} + +.bg-\[\#17203D\] { + --tw-bg-opacity: 1; + background-color: rgb(23 32 61 / var(--tw-bg-opacity)); +} + +.bg-\[\#48F6C2\] { + --tw-bg-opacity: 1; + background-color: rgb(72 246 194 / var(--tw-bg-opacity)); +} + +.bg-\[\#D9E7ED\] { + --tw-bg-opacity: 1; + background-color: rgb(217 231 237 / var(--tw-bg-opacity)); +} + +.bg-\[\#D9ECFF\] { + --tw-bg-opacity: 1; + background-color: rgb(217 236 255 / var(--tw-bg-opacity)); +} + +.bg-\[\#F0F1F2\] { + --tw-bg-opacity: 1; + background-color: rgb(240 241 242 / var(--tw-bg-opacity)); +} + +.bg-\[\#F3F6F7\] { + --tw-bg-opacity: 1; + background-color: rgb(243 246 247 / var(--tw-bg-opacity)); +} + +.bg-\[\#fff\] { + --tw-bg-opacity: 1; + background-color: rgb(255 255 255 / var(--tw-bg-opacity)); +} + +.bg-black { + --tw-bg-opacity: 1; + background-color: rgb(13 14 18 / var(--tw-bg-opacity)); +} + +.bg-card-bg-light { + --tw-bg-opacity: 1; + background-color: rgb(255 255 255 / var(--tw-bg-opacity)); +} + +.bg-card-desc-bg-light { + --tw-bg-opacity: 1; + background-color: rgb(217 231 237 / var(--tw-bg-opacity)); +} + +.bg-primary-bg-light { + --tw-bg-opacity: 1; + background-color: rgb(255 255 255 / var(--tw-bg-opacity)); +} + +.bg-primary-light { + --tw-bg-opacity: 1; + background-color: rgb(0 83 208 / var(--tw-bg-opacity)); +} + +.bg-secondary-bg-light { + --tw-bg-opacity: 1; + background-color: rgb(243 246 247 / var(--tw-bg-opacity)); +} + +.bg-transparent { + background-color: transparent; +} + +.bg-white { + --tw-bg-opacity: 1; + background-color: rgb(255 255 255 / var(--tw-bg-opacity)); +} + +.bg-yellow-200 { + --tw-bg-opacity: 1; + background-color: rgb(254 240 138 / var(--tw-bg-opacity)); +} + +.fill-\[rgb\(60\2c 60\2c 60\)\] { + fill: rgb(60,60,60); +} + +.fill-black { + fill: #0D0E12; +} + +.fill-grey-black { + fill: #3F484B; +} + +.fill-primary-light { + fill: #0053D0; +} + +.p-1 { + padding: 0.25rem; +} + +.p-2 { + padding: 0.5rem; +} + +.p-3 { + padding: 0.75rem; +} + +.p-4 { + padding: 1rem; +} + +.p-6 { + padding: 1.5rem; +} + +.\!py-2 { + padding-top: 0.5rem !important; + padding-bottom: 0.5rem !important; +} + +.px-0 { + padding-left: 0px; + padding-right: 0px; +} + +.px-20 { + padding-left: 5rem; + padding-right: 5rem; +} + +.px-4 { + padding-left: 1rem; + padding-right: 1rem; +} + +.px-5 { + padding-left: 1.25rem; + padding-right: 1.25rem; +} + +.px-6 { + padding-left: 1.5rem; + padding-right: 1.5rem; +} + +.px-8 { + padding-left: 2rem; + padding-right: 2rem; +} + +.px-\[20px\] { + padding-left: 20px; + padding-right: 20px; +} + +.px-\[34px\] { + padding-left: 34px; + padding-right: 34px; +} + +.py-10 { + padding-top: 2.5rem; + padding-bottom: 2.5rem; +} + +.py-12 { + padding-top: 3rem; + padding-bottom: 3rem; +} + +.py-2 { + padding-top: 0.5rem; + padding-bottom: 0.5rem; +} + +.py-3 { + padding-top: 0.75rem; + padding-bottom: 0.75rem; +} + +.py-4 { + padding-top: 1rem; + padding-bottom: 1rem; +} + +.py-5 { + padding-top: 1.25rem; + padding-bottom: 1.25rem; +} + +.py-6 { + padding-top: 1.5rem; + padding-bottom: 1.5rem; +} + +.py-8 { + padding-top: 2rem; + padding-bottom: 2rem; +} + +.py-\[20px\] { + padding-top: 20px; + padding-bottom: 20px; +} + +.py-\[24px\] { + padding-top: 24px; + padding-bottom: 24px; +} + +.py-\[50px\] { + padding-top: 50px; + padding-bottom: 50px; +} + +.py-\[70px\] { + padding-top: 70px; + padding-bottom: 70px; +} + +.py-\[75px\] { + padding-top: 75px; + padding-bottom: 75px; +} + +.py-\[90px\] { + padding-top: 90px; + padding-bottom: 90px; +} + +.py-\[95px\] { + padding-top: 95px; + padding-bottom: 95px; +} + +.pb-4 { + padding-bottom: 1rem; +} + +.pb-8 { + padding-bottom: 2rem; +} + +.pb-\[90px\] { + padding-bottom: 90px; +} + +.pr-10 { + padding-right: 2.5rem; +} + +.pt-2 { + padding-top: 0.5rem; +} + +.pt-4 { + padding-top: 1rem; +} + +.pt-5 { + padding-top: 1.25rem; +} + +.pt-\[106px\] { + padding-top: 106px; +} + +.pt-\[30px\] { + padding-top: 30px; +} + +.pt-\[40px\] { + padding-top: 40px; +} + +.pt-\[66px\] { + padding-top: 66px; +} + +.text-left { + text-align: left; +} + +.text-center { + text-align: center; +} + +.text-2xl { + font-size: 1.5rem; + line-height: 2rem; +} + +.text-3xl { + font-size: 1.875rem; + line-height: 2.25rem; +} + +.text-\[12px\] { + font-size: 12px; +} + +.text-\[14px\] { + font-size: 14px; +} + +.text-\[16px\] { + font-size: 16px; +} + +.text-\[18px\] { + font-size: 18px; +} + +.text-\[20px\] { + font-size: 20px; +} + +.text-\[24px\] { + font-size: 24px; +} + +.text-\[25px\] { + font-size: 25px; +} + +.text-\[28px\] { + font-size: 28px; +} + +.text-\[30px\] { + font-size: 30px; +} + +.text-\[35px\] { + font-size: 35px; +} + +.text-\[38px\] { + font-size: 38px; +} + +.text-\[42px\] { + font-size: 42px; +} + +.text-base { + font-size: 1rem; + line-height: 1.5rem; +} + +.text-lg { + font-size: 1.125rem; + line-height: 1.75rem; +} + +.text-sm { + font-size: 0.875rem; + line-height: 1.25rem; +} + +.text-xl { + font-size: 1.25rem; + line-height: 1.75rem; +} + +.font-bold { + font-weight: 700; +} + +.font-light { + font-weight: 300; +} + +.font-medium { + font-weight: 500; +} + +.font-normal { + font-weight: 400; +} + +.capitalize { + text-transform: capitalize; +} + +.italic { + font-style: italic; +} + +.leading-6 { + line-height: 1.5rem; +} + +.leading-\[19px\] { + line-height: 19px; +} + +.leading-\[24px\] { + line-height: 24px; +} + +.leading-\[26px\] { + line-height: 26px; +} + +.leading-\[28px\] { + line-height: 28px; +} + +.leading-\[33px\] { + line-height: 33px; +} + +.leading-\[34px\] { + line-height: 34px; +} + +.leading-\[36px\] { + line-height: 36px; +} + +.leading-\[43px\] { + line-height: 43px; +} + +.leading-\[45px\] { + line-height: 45px; +} + +.leading-\[46px\] { + line-height: 46px; +} + +.tracking-\[0\.01em\] { + letter-spacing: 0.01em; +} + +.tracking-\[0\.02em\] { + letter-spacing: 0.02em; +} + +.tracking-\[0\.03em\] { + letter-spacing: 0.03em; +} + +.tracking-\[0\.04em\] { + letter-spacing: 0.04em; +} + +.tracking-\[0\.06em\] { + letter-spacing: 0.06em; +} + +.\!text-\[rgb\(60\2c 60\2c 60\)\] { + --tw-text-opacity: 1 !important; + color: rgb(60 60 60 / var(--tw-text-opacity)) !important; +} + +.\!text-primary-pressed-light { + --tw-text-opacity: 1 !important; + color: rgb(64 122 210 / var(--tw-text-opacity)) !important; +} + +.text-\[\#606C71\] { + --tw-text-opacity: 1; + color: rgb(96 108 113 / var(--tw-text-opacity)); +} + +.text-\[\#A8B0B4\] { + --tw-text-opacity: 1; + color: rgb(168 176 180 / var(--tw-text-opacity)); +} + +.text-\[\#DD0000\] { + --tw-text-opacity: 1; + color: rgb(221 0 0 / var(--tw-text-opacity)); +} + +.text-active-blue { + --tw-text-opacity: 1; + color: rgb(1 151 255 / var(--tw-text-opacity)); +} + +.text-black { + --tw-text-opacity: 1; + color: rgb(13 14 18 / var(--tw-text-opacity)); +} + +.text-grey-black { + --tw-text-opacity: 1; + color: rgb(63 72 75 / var(--tw-text-opacity)); +} + +.text-primary-light { + --tw-text-opacity: 1; + color: rgb(0 83 208 / var(--tw-text-opacity)); +} + +.text-white { + --tw-text-opacity: 1; + color: rgb(255 255 255 / var(--tw-text-opacity)); +} + +.underline { + text-decoration-line: underline; +} + +.\!no-underline { + text-decoration-line: none !important; +} + +.no-underline { + text-decoration-line: none; +} + +.underline-offset-2 { + text-underline-offset: 2px; +} + +.underline-offset-4 { + text-underline-offset: 4px; +} + +.opacity-100 { + opacity: 1; +} + +.shadow { + --tw-shadow: 0 1px 3px 0 rgb(0 0 0 / 0.1), 0 1px 2px -1px rgb(0 0 0 / 0.1); + --tw-shadow-colored: 0 1px 3px 0 var(--tw-shadow-color), 0 1px 2px -1px var(--tw-shadow-color); + box-shadow: var(--tw-ring-offset-shadow, 0 0 #0000), var(--tw-ring-shadow, 0 0 #0000), var(--tw-shadow); +} + +.shadow-\[0_0_3px_rgb\(60_72_88_\/_15\%\)\] { + --tw-shadow: 0 0 3px rgb(60 72 88 / 15%); + --tw-shadow-colored: 0 0 3px var(--tw-shadow-color); + box-shadow: var(--tw-ring-offset-shadow, 0 0 #0000), var(--tw-ring-shadow, 0 0 #0000), var(--tw-shadow); +} + +.shadow-\[0px_20px_30px_rgba\(0\2c 0\2c 0\2c 0\.12\)\] { + --tw-shadow: 0px 20px 30px rgba(0,0,0,0.12); + --tw-shadow-colored: 0px 20px 30px var(--tw-shadow-color); + box-shadow: var(--tw-ring-offset-shadow, 0 0 #0000), var(--tw-ring-shadow, 0 0 #0000), var(--tw-shadow); +} + +.shadow-\[0px_3px_12px_rgba\(0\2c 0\2c 0\2c 0\.2\)\] { + --tw-shadow: 0px 3px 12px rgba(0,0,0,0.2); + --tw-shadow-colored: 0px 3px 12px var(--tw-shadow-color); + box-shadow: var(--tw-ring-offset-shadow, 0 0 #0000), var(--tw-ring-shadow, 0 0 #0000), var(--tw-shadow); +} + +.shadow-\[0px_50px_61px_rgba\(0\2c 0\2c 0\2c 0\.12\)\] { + --tw-shadow: 0px 50px 61px rgba(0,0,0,0.12); + --tw-shadow-colored: 0px 50px 61px var(--tw-shadow-color); + box-shadow: var(--tw-ring-offset-shadow, 0 0 #0000), var(--tw-ring-shadow, 0 0 #0000), var(--tw-shadow); +} + +.shadow-\[2px_2px_0px_\#859096\] { + --tw-shadow: 2px 2px 0px #859096; + --tw-shadow-colored: 2px 2px 0px var(--tw-shadow-color); + box-shadow: var(--tw-ring-offset-shadow, 0 0 #0000), var(--tw-ring-shadow, 0 0 #0000), var(--tw-shadow); +} + +.shadow-\[inset_0px_2px_2px_rgba\(0\2c 0\2c 0\2c 0\.15\)\] { + --tw-shadow: inset 0px 2px 2px rgba(0,0,0,0.15); + --tw-shadow-colored: inset 0px 2px 2px var(--tw-shadow-color); + box-shadow: var(--tw-ring-offset-shadow, 0 0 #0000), var(--tw-ring-shadow, 0 0 #0000), var(--tw-shadow); +} + +.blur { + --tw-blur: blur(8px); + filter: var(--tw-blur) var(--tw-brightness) var(--tw-contrast) var(--tw-grayscale) var(--tw-hue-rotate) var(--tw-invert) var(--tw-saturate) var(--tw-sepia) var(--tw-drop-shadow); +} + +.invert { + --tw-invert: invert(100%); + filter: var(--tw-blur) var(--tw-brightness) var(--tw-contrast) var(--tw-grayscale) var(--tw-hue-rotate) var(--tw-invert) var(--tw-saturate) var(--tw-sepia) var(--tw-drop-shadow); +} + +.filter { + filter: var(--tw-blur) var(--tw-brightness) var(--tw-contrast) var(--tw-grayscale) var(--tw-hue-rotate) var(--tw-invert) var(--tw-saturate) var(--tw-sepia) var(--tw-drop-shadow); +} + +.transition { + transition-property: color, background-color, border-color, text-decoration-color, fill, stroke, opacity, box-shadow, transform, filter, -webkit-backdrop-filter; + transition-property: color, background-color, border-color, text-decoration-color, fill, stroke, opacity, box-shadow, transform, filter, backdrop-filter; + transition-property: color, background-color, border-color, text-decoration-color, fill, stroke, opacity, box-shadow, transform, filter, backdrop-filter, -webkit-backdrop-filter; + transition-timing-function: cubic-bezier(0.4, 0, 0.2, 1); + transition-duration: 150ms; +} + +.placeholder\:text-base::-moz-placeholder { + font-size: 1rem; + line-height: 1.5rem; +} + +.placeholder\:text-base::placeholder { + font-size: 1rem; + line-height: 1.5rem; +} + +.placeholder\:font-normal::-moz-placeholder { + font-weight: 400; +} + +.placeholder\:font-normal::placeholder { + font-weight: 400; +} + +.placeholder\:tracking-\[0\.01em\]::-moz-placeholder { + letter-spacing: 0.01em; +} + +.placeholder\:tracking-\[0\.01em\]::placeholder { + letter-spacing: 0.01em; +} + +.placeholder\:text-grey-black::-moz-placeholder { + --tw-text-opacity: 1; + color: rgb(63 72 75 / var(--tw-text-opacity)); +} + +.placeholder\:text-grey-black::placeholder { + --tw-text-opacity: 1; + color: rgb(63 72 75 / var(--tw-text-opacity)); +} + +.before\:absolute::before { + content: var(--tw-content); + position: absolute; +} + +.before\:h-full::before { + content: var(--tw-content); + height: 100%; +} + +.before\:w-full::before { + content: var(--tw-content); + width: 100%; +} + +.before\:bg-black::before { + content: var(--tw-content); + --tw-bg-opacity: 1; + background-color: rgb(13 14 18 / var(--tw-bg-opacity)); +} + +.before\:bg-secondary-bg-light::before { + content: var(--tw-content); + --tw-bg-opacity: 1; + background-color: rgb(243 246 247 / var(--tw-bg-opacity)); +} + +.before\:opacity-90::before { + content: var(--tw-content); + opacity: 0.9; +} + +.focus\:outline-none:focus { + outline: 2px solid transparent; + outline-offset: 2px; +} + +:is([dir="ltr"] .ltr\:ml-8) { + margin-left: 2rem; +} + +:is([dir="ltr"] .ltr\:mr-auto) { + margin-right: auto; +} + +:is([dir="ltr"] .ltr\:\!hidden) { + display: none !important; +} + +:is([dir="ltr"] .ltr\:rounded-l-\[34px\]) { + border-top-left-radius: 34px; + border-bottom-left-radius: 34px; +} + +:is([dir="ltr"] .ltr\:rounded-r-\[34px\]) { + border-top-right-radius: 34px; + border-bottom-right-radius: 34px; +} + +:is([dir="rtl"] .rtl\:ml-auto) { + margin-left: auto; +} + +:is([dir="rtl"] .rtl\:mr-8) { + margin-right: 2rem; +} + +:is([dir="rtl"] .rtl\:\!hidden) { + display: none !important; +} + +:is([dir="rtl"] .rtl\:rounded-l-\[34px\]) { + border-top-left-radius: 34px; + border-bottom-left-radius: 34px; +} + +:is([dir="rtl"] .rtl\:rounded-r-\[34px\]) { + border-top-right-radius: 34px; + border-bottom-right-radius: 34px; +} + +:is([dir="rtl"] .rtl\:text-right) { + text-align: right; +} + +:is(.dark .dark\:block) { + display: block; +} + +:is(.dark .dark\:inline-block) { + display: inline-block; +} + +:is(.dark .dark\:flex) { + display: flex; +} + +:is(.dark .dark\:\!hidden) { + display: none !important; +} + +:is(.dark .dark\:hidden) { + display: none; +} + +:is(.dark .dark\:rounded-\[6px\]) { + border-radius: 6px; +} + +:is(.dark .dark\:border) { + border-width: 1px; +} + +:is(.dark .dark\:border-none) { + border-style: none; +} + +:is(.dark .dark\:border-primary-dark) { + --tw-border-opacity: 1; + border-color: rgb(112 240 249 / var(--tw-border-opacity)); +} + +:is(.dark .dark\:border-white) { + --tw-border-opacity: 1; + border-color: rgb(255 255 255 / var(--tw-border-opacity)); +} + +:is(.dark .dark\:bg-\[\#0C0B13\]) { + --tw-bg-opacity: 1; + background-color: rgb(12 11 19 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-\[\#0E2B57\]) { + --tw-bg-opacity: 1; + background-color: rgb(14 43 87 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-\[\#11182F\]) { + --tw-bg-opacity: 1; + background-color: rgb(17 24 47 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-\[\#171F3A\]) { + --tw-bg-opacity: 1; + background-color: rgb(23 31 58 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-\[\#17203D\]) { + --tw-bg-opacity: 1; + background-color: rgb(23 32 61 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-\[rgba\(112\2c 240\2c 249\2c 0\.2\)\]) { + background-color: rgba(112,240,249,0.2); +} + +:is(.dark .dark\:bg-black) { + --tw-bg-opacity: 1; + background-color: rgb(13 14 18 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-card-bg-dark) { + --tw-bg-opacity: 1; + background-color: rgb(23 32 61 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-card-desc-bg-dark) { + --tw-bg-opacity: 1; + background-color: rgb(27 50 92 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-grey-black) { + --tw-bg-opacity: 1; + background-color: rgb(63 72 75 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-primary-bg-dark) { + --tw-bg-opacity: 1; + background-color: rgb(12 11 19 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-primary-dark) { + --tw-bg-opacity: 1; + background-color: rgb(112 240 249 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-secondary-bg-dark) { + --tw-bg-opacity: 1; + background-color: rgb(17 24 47 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:bg-transparent) { + background-color: transparent; +} + +:is(.dark .dark\:bg-opacity-\[0\.2\]) { + --tw-bg-opacity: 0.2; +} + +:is(.dark .dark\:bg-gradient-radial-mobile) { + background-image: radial-gradient(77.4% 73.09% at -3.68% 100%, #17203D 0%, #0C0B13 100%); +} + +:is(.dark .dark\:fill-primary-dark) { + fill: #70F0F9; +} + +:is(.dark .dark\:fill-white) { + fill: #fff; +} + +:is(.dark .dark\:\!text-white) { + --tw-text-opacity: 1 !important; + color: rgb(255 255 255 / var(--tw-text-opacity)) !important; +} + +:is(.dark .dark\:text-\[\#70F0F9\]) { + --tw-text-opacity: 1; + color: rgb(112 240 249 / var(--tw-text-opacity)); +} + +:is(.dark .dark\:text-black) { + --tw-text-opacity: 1; + color: rgb(13 14 18 / var(--tw-text-opacity)); +} + +:is(.dark .dark\:text-primary-dark) { + --tw-text-opacity: 1; + color: rgb(112 240 249 / var(--tw-text-opacity)); +} + +:is(.dark .dark\:text-white) { + --tw-text-opacity: 1; + color: rgb(255 255 255 / var(--tw-text-opacity)); +} + +:is(.dark .dark\:opacity-\[0\.1\]) { + opacity: 0.1; +} + +:is(.dark .dark\:opacity-\[0\.2\]) { + opacity: 0.2; +} + +:is(.dark .dark\:shadow-none) { + --tw-shadow: 0 0 #0000; + --tw-shadow-colored: 0 0 #0000; + box-shadow: var(--tw-ring-offset-shadow, 0 0 #0000), var(--tw-ring-shadow, 0 0 #0000), var(--tw-shadow); +} + +:is(.dark .placeholder\:dark\:text-white)::-moz-placeholder { + --tw-text-opacity: 1; + color: rgb(255 255 255 / var(--tw-text-opacity)); +} + +:is(.dark .placeholder\:dark\:text-white)::placeholder { + --tw-text-opacity: 1; + color: rgb(255 255 255 / var(--tw-text-opacity)); +} + +:is(.dark .dark\:before\:bg-primary-bg-dark)::before { + content: var(--tw-content); + --tw-bg-opacity: 1; + background-color: rgb(12 11 19 / var(--tw-bg-opacity)); +} + +:is(.dark .dark\:before\:bg-white)::before { + content: var(--tw-content); + --tw-bg-opacity: 1; + background-color: rgb(255 255 255 / var(--tw-bg-opacity)); +} + +@media (min-width: 640px) { + .sm\:block { + display: block; + } + + .sm\:grid-cols-2 { + grid-template-columns: repeat(2, minmax(0, 1fr)); + } + + .sm\:flex-row { + flex-direction: row; + } + + .sm\:p-14 { + padding: 3.5rem; + } + + .sm\:px-1 { + padding-left: 0.25rem; + padding-right: 0.25rem; + } + + .sm\:px-4 { + padding-left: 1rem; + padding-right: 1rem; + } +} + +@media (min-width: 768px) { + .md\:static { + position: static; + } + + .md\:mb-0 { + margin-bottom: 0px; + } + + .md\:mb-16 { + margin-bottom: 4rem; + } + + .md\:mb-6 { + margin-bottom: 1.5rem; + } + + .md\:mb-8 { + margin-bottom: 2rem; + } + + .md\:mt-6 { + margin-top: 1.5rem; + } + + .md\:block { + display: block; + } + + .md\:inline-block { + display: inline-block; + } + + .md\:flex { + display: flex; + } + + .md\:hidden { + display: none; + } + + .md\:h-fit { + height: -moz-fit-content; + height: fit-content; + } + + .md\:max-h-\[660px\] { + max-height: 660px; + } + + .md\:min-h-fit { + min-height: -moz-fit-content; + min-height: fit-content; + } + + .md\:w-\[168px\] { + width: 168px; + } + + .md\:w-\[30\%\] { + width: 30%; + } + + .md\:w-\[70\%\] { + width: 70%; + } + + .md\:w-fit { + width: -moz-fit-content; + width: fit-content; + } + + .md\:max-w-\[1276px\] { + max-width: 1276px; + } + + .md\:max-w-\[220px\] { + max-width: 220px; + } + + .md\:max-w-\[490px\] { + max-width: 490px; + } + + .md\:flex-1 { + flex: 1 1 0%; + } + + .md\:flex-\[1\] { + flex: 1; + } + + .md\:flex-\[2\] { + flex: 2; + } + + .md\:flex-row { + flex-direction: row; + } + + .md\:flex-col-reverse { + flex-direction: column-reverse; + } + + .md\:items-start { + align-items: flex-start; + } + + .md\:items-center { + align-items: center; + } + + .md\:gap-14 { + gap: 3.5rem; + } + + .md\:gap-9 { + gap: 2.25rem; + } + + .md\:p-10 { + padding: 2.5rem; + } + + .md\:p-\[60px\] { + padding: 60px; + } + + .md\:px-0 { + padding-left: 0px; + padding-right: 0px; + } + + .md\:px-10 { + padding-left: 2.5rem; + padding-right: 2.5rem; + } + + .md\:py-16 { + padding-top: 4rem; + padding-bottom: 4rem; + } + + .md\:py-7 { + padding-top: 1.75rem; + padding-bottom: 1.75rem; + } + + .md\:py-8 { + padding-top: 2rem; + padding-bottom: 2rem; + } + + .md\:text-left { + text-align: left; + } + + .md\:text-\[20px\] { + font-size: 20px; + } + + .md\:text-\[35px\] { + font-size: 35px; + } + + .md\:text-\[38px\] { + font-size: 38px; + } + + .md\:text-\[55px\] { + font-size: 55px; + } + + .md\:text-xl { + font-size: 1.25rem; + line-height: 1.75rem; + } + + .md\:leading-\[43px\] { + line-height: 43px; + } + + .md\:leading-\[55px\] { + line-height: 55px; + } + + .md\:leading-\[63px\] { + line-height: 63px; + } + + :is([dir="rtl"] .md\:rtl\:inline-block) { + display: inline-block; + } + + :is([dir="rtl"] .md\:rtl\:text-right) { + text-align: right; + } + + :is(.dark .dark\:md\:inline-block) { + display: inline-block; + } + + :is(.dark .md\:dark\:inline-block) { + display: inline-block; + } +} + +@media (min-width: 1024px) { + .lg\:absolute { + position: absolute; + } + + .lg\:relative { + position: relative; + } + + .lg\:top-0 { + top: 0px; + } + + .lg\:mb-0 { + margin-bottom: 0px; + } + + .lg\:mb-20 { + margin-bottom: 5rem; + } + + .lg\:mb-8 { + margin-bottom: 2rem; + } + + .lg\:mb-\[54px\] { + margin-bottom: 54px; + } + + .lg\:mb-\[90px\] { + margin-bottom: 90px; + } + + .lg\:mt-0 { + margin-top: 0px; + } + + .lg\:mt-\[10px\] { + margin-top: 10px; + } + + .lg\:flex { + display: flex; + } + + .lg\:hidden { + display: none; + } + + .lg\:h-0 { + height: 0px; + } + + .lg\:h-\[642px\] { + height: 642px; + } + + .lg\:h-\[855px\] { + height: 855px; + } + + .lg\:h-\[888px\] { + height: 888px; + } + + .lg\:h-\[890px\] { + height: 890px; + } + + .lg\:h-\[950px\] { + height: 950px; + } + + .lg\:h-\[calc\(100vh-66px\)\] { + height: calc(100vh - 66px); + } + + .lg\:h-auto { + height: auto; + } + + .lg\:h-fit { + height: -moz-fit-content; + height: fit-content; + } + + .lg\:max-h-\[888px\] { + max-height: 888px; + } + + .lg\:w-2\/5 { + width: 40%; + } + + .lg\:w-3\/5 { + width: 60%; + } + + .lg\:w-auto { + width: auto; + } + + .lg\:w-full { + width: 100%; + } + + .lg\:max-w-\[240px\] { + max-width: 240px; + } + + .lg\:max-w-\[448px\] { + max-width: 448px; + } + + .lg\:grid-cols-4 { + grid-template-columns: repeat(4, minmax(0, 1fr)); + } + + .lg\:flex-row { + flex-direction: row; + } + + .lg\:flex-col { + flex-direction: column; + } + + .lg\:items-start { + align-items: flex-start; + } + + .lg\:items-center { + align-items: center; + } + + .lg\:gap-0 { + gap: 0px; + } + + .lg\:gap-16 { + gap: 4rem; + } + + .lg\:gap-28 { + gap: 7rem; + } + + .lg\:gap-5 { + gap: 1.25rem; + } + + .lg\:gap-\[350px\] { + gap: 350px; + } + + .lg\:bg-transparent { + background-color: transparent; + } + + .lg\:bg-white { + --tw-bg-opacity: 1; + background-color: rgb(255 255 255 / var(--tw-bg-opacity)); + } + + .lg\:px-0 { + padding-left: 0px; + padding-right: 0px; + } + + .lg\:px-5 { + padding-left: 1.25rem; + padding-right: 1.25rem; + } + + .lg\:px-7 { + padding-left: 1.75rem; + padding-right: 1.75rem; + } + + .lg\:px-\[20px\] { + padding-left: 20px; + padding-right: 20px; + } + + .lg\:px-\[50px\] { + padding-left: 50px; + padding-right: 50px; + } + + .lg\:py-0 { + padding-top: 0px; + padding-bottom: 0px; + } + + .lg\:py-2 { + padding-top: 0.5rem; + padding-bottom: 0.5rem; + } + + .lg\:py-4 { + padding-top: 1rem; + padding-bottom: 1rem; + } + + .lg\:py-5 { + padding-top: 1.25rem; + padding-bottom: 1.25rem; + } + + .lg\:py-\[50px\] { + padding-top: 50px; + padding-bottom: 50px; + } + + .lg\:pt-0 { + padding-top: 0px; + } + + .lg\:text-center { + text-align: center; + } + + .lg\:text-\[32px\] { + font-size: 32px; + } + + .lg\:text-\[35px\] { + font-size: 35px; + } + + .lg\:text-\[38px\] { + font-size: 38px; + } + + .lg\:text-\[45px\] { + font-size: 45px; + } + + .lg\:text-\[65px\] { + font-size: 65px; + } + + .lg\:text-base { + font-size: 1rem; + line-height: 1.5rem; + } + + .lg\:leading-\[36px\] { + line-height: 36px; + } + + .lg\:leading-\[45px\] { + line-height: 45px; + } + + .lg\:shadow-\[0_0_3px_rgb\(60_72_88_\/_15\%\)\] { + --tw-shadow: 0 0 3px rgb(60 72 88 / 15%); + --tw-shadow-colored: 0 0 3px var(--tw-shadow-color); + box-shadow: var(--tw-ring-offset-shadow, 0 0 #0000), var(--tw-ring-shadow, 0 0 #0000), var(--tw-shadow); + } + + :is([dir="ltr"] .ltr\:lg\:ml-4) { + margin-left: 1rem; + } + + :is([dir="ltr"] .ltr\:lg\:ml-5) { + margin-left: 1.25rem; + } + + :is([dir="ltr"] .lg\:ltr\:text-left) { + text-align: left; + } + + :is([dir="rtl"] .rtl\:lg\:mr-4) { + margin-right: 1rem; + } + + :is([dir="rtl"] .rtl\:lg\:mr-5) { + margin-right: 1.25rem; + } + + :is([dir="rtl"] .lg\:rtl\:text-right) { + text-align: right; + } + + :is(.dark .dark\:lg\:flex) { + display: flex; + } + + :is(.dark .dark\:lg\:hidden) { + display: none; + } + + :is(.dark .dark\:lg\:bg-black) { + --tw-bg-opacity: 1; + background-color: rgb(13 14 18 / var(--tw-bg-opacity)); + } + + :is(.dark .dark\:lg\:bg-gradient-radial) { + background-image: radial-gradient(88.77% 102.03% at 92.64% -13.22%, #17203D 0%, #0C0B13 100%); + } + + :is(.dark .dark\:lg\:bg-none) { + background-image: none; + } +} + +@media (min-width: 1280px) { + .xl\:absolute { + position: absolute; + } + + .xl\:sticky { + position: sticky; + } + + .xl\:mb-0 { + margin-bottom: 0px; + } + + .xl\:mb-8 { + margin-bottom: 2rem; + } + + .xl\:mb-\[25px\] { + margin-bottom: 25px; + } + + .xl\:block { + display: block; + } + + .xl\:flex { + display: flex; + } + + .xl\:hidden { + display: none; + } + + .xl\:h-\[888px\] { + height: 888px; + } + + .xl\:h-\[calc\(100vh-66px\)\] { + height: calc(100vh - 66px); + } + + .xl\:h-full { + height: 100%; + } + + .xl\:max-h-\[888px\] { + max-height: 888px; + } + + .xl\:min-h-\[565px\] { + min-height: 565px; + } + + .xl\:min-w-\[600px\] { + min-width: 600px; + } + + .xl\:max-w-\[600px\] { + max-width: 600px; + } + + .xl\:flex-row { + flex-direction: row; + } + + .xl\:flex-row-reverse { + flex-direction: row-reverse; + } + + .xl\:items-start { + align-items: flex-start; + } + + .xl\:items-center { + align-items: center; + } + + .xl\:justify-start { + justify-content: flex-start; + } + + .xl\:justify-between { + justify-content: space-between; + } + + .xl\:justify-around { + justify-content: space-around; + } + + .xl\:gap-10 { + gap: 2.5rem; + } + + .xl\:gap-8 { + gap: 2rem; + } + + .xl\:text-left { + text-align: left; + } + + .xl\:text-justify { + text-align: justify; + } + + .xl\:text-\[16px\] { + font-size: 16px; + } + + .xl\:bg-secondary-bg-light { + --tw-bg-opacity: 1; + background-color: rgb(243 246 247 / var(--tw-bg-opacity)); + } + + :is([dir="ltr"] .ltr\:xl\:ml-10) { + margin-left: 2.5rem; + } + + :is([dir="ltr"] .ltr\:xl\:ml-8) { + margin-left: 2rem; + } + + :is([dir="rtl"] .rtl\:xl\:mr-10) { + margin-right: 2.5rem; + } + + :is([dir="rtl"] .rtl\:xl\:mr-8) { + margin-right: 2rem; + } + + :is([dir="rtl"] .xl\:rtl\:text-right) { + text-align: right; + } + + :is(.dark .dark\:xl\:bg-secondary-bg-dark) { + --tw-bg-opacity: 1; + background-color: rgb(17 24 47 / var(--tw-bg-opacity)); + } +} diff --git a/apps/smp-server/static/media/testflight.png b/apps/smp-server/static/media/testflight.png new file mode 100644 index 000000000..8111a69d5 Binary files /dev/null and b/apps/smp-server/static/media/testflight.png differ diff --git a/apps/smp-server/web/Static.hs b/apps/smp-server/web/Static.hs new file mode 100644 index 000000000..4d25f2067 --- /dev/null +++ b/apps/smp-server/web/Static.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Static where + +import Control.Logger.Simple +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import Data.Text.Encoding (encodeUtf8) +import Network.Wai.Application.Static as S +import Network.Wai.Handler.Warp as W +import qualified Network.Wai.Handler.WarpTLS as W +import Simplex.Messaging.Encoding.String (strEncode) +import Simplex.Messaging.Server.Information +import Simplex.Messaging.Server.Main (EmbeddedWebParams (..), WebHttpsParams (..)) +import Simplex.Messaging.Transport.Client (TransportHost (..)) +import Simplex.Messaging.Util (tshow) +import Static.Embedded as E +import System.Directory (createDirectoryIfMissing) +import System.FilePath +import UnliftIO.Concurrent (forkFinally) + +serveStaticFiles :: EmbeddedWebParams -> IO () +serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams} = do + forM_ webHttpPort $ \port -> flip forkFinally (\e -> logError $ "HTTP server crashed: " <> tshow e) $ do + logInfo $ "Serving static site on port " <> tshow port + W.runSettings (mkSettings port) (S.staticApp $ S.defaultFileServerSettings webStaticPath) + forM_ webHttpsParams $ \WebHttpsParams {port, cert, key} -> flip forkFinally (\e -> logError $ "HTTPS server crashed: " <> tshow e) $ do + logInfo $ "Serving static site on port " <> tshow port <> " (TLS)" + W.runTLS (W.tlsSettings cert key) (mkSettings port) (S.staticApp $ S.defaultFileServerSettings webStaticPath) + where + mkSettings port = setPort port defaultSettings + +generateSite :: ServerInformation -> Maybe TransportHost -> FilePath -> IO () +generateSite si onionHost sitePath = do + createDirectoryIfMissing True sitePath + B.writeFile (sitePath "index.html") $ serverInformation si onionHost + createDirectoryIfMissing True $ sitePath "media" + forM_ E.mediaContent $ \(path, bs) -> B.writeFile (sitePath "media" path) bs + createDirectoryIfMissing True $ sitePath "contact" + B.writeFile (sitePath "contact" "index.html") E.linkHtml + createDirectoryIfMissing True $ sitePath "invitation" + B.writeFile (sitePath "invitation" "index.html") E.linkHtml + logInfo $ "Generated static site contents at " <> tshow sitePath + +serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString +serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs + where + substs = substConfig <> maybe [] substInfo information <> [("onionHost", strEncode <$> onionHost)] + substConfig = + [ ( "persistence", + Just $ case persistence config of + SPMMemoryOnly -> "In-memory only" + SPMQueues -> "Queues" + SPMMessages -> "Queues and messages" + ), + ("messageExpiration", Just $ maybe "Never" (fromString . timedTTLText) $ messageExpiration config), + ("statsEnabled", Just . yesNo $ statsEnabled config), + ("newQueuesAllowed", Just . yesNo $ newQueuesAllowed config), + ("basicAuthEnabled", Just . yesNo $ basicAuthEnabled config) + ] + yesNo True = "Yes" + yesNo False = "No" + substInfo spi = + concat + [ basic, + maybe [("usageConditions", Nothing), ("usageAmendments", Nothing)] conds (usageConditions spi), + maybe [("operator", Nothing)] operatorE (operator spi), + maybe [("admin", Nothing)] admin (adminContacts spi), + maybe [("complaints", Nothing)] complaints (complaintsContacts spi), + maybe [("hosting", Nothing)] hostingE (hosting spi), + server + ] + where + basic = + [ ("sourceCode", Just . encodeUtf8 $ sourceCode spi), + ("website", encodeUtf8 <$> website spi) + ] + conds ServerConditions {conditions, amendments} = + [ ("usageConditions", Just $ encodeUtf8 conditions), + ("usageAmendments", encodeUtf8 <$> amendments) + ] + operatorE Entity {name, country} = + [ ("operator", Just ""), + ("operatorEntity", Just $ encodeUtf8 name), + ("operatorCountry", encodeUtf8 <$> country) + ] + admin ServerContactAddress {simplex, email, pgp} = + [ ("admin", Just ""), + ("adminSimplex", strEncode <$> simplex), + ("adminEmail", encodeUtf8 <$> email), + ("adminPGP", encodeUtf8 . pkURI <$> pgp), + ("adminPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp) + ] + complaints ServerContactAddress {simplex, email, pgp} = + [ ("complaints", Just ""), + ("complaintsSimplex", strEncode <$> simplex), + ("complaintsEmail", encodeUtf8 <$> email), + ("complaintsPGP", encodeUtf8 . pkURI <$> pgp), + ("complaintsPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp) + ] + hostingE Entity {name, country} = + [ ("hosting", Just ""), + ("hostingEntity", Just $ encodeUtf8 name), + ("hostingCountry", encodeUtf8 <$> country) + ] + server = + [ ("serverCountry", fmap encodeUtf8 $ serverCountry =<< information) + ] + +-- Copy-pasted from simplex-chat Simplex.Chat.Types.Preferences +{-# INLINE timedTTLText #-} +timedTTLText :: (Integral i, Show i) => i -> String +timedTTLText 0 = "0 sec" +timedTTLText ttl = do + let (m', s) = ttl `quotRem` 60 + (h', m) = m' `quotRem` 60 + (d', h) = h' `quotRem` 24 + (mm, d) = d' `quotRem` 30 + unwords $ + [mms mm | mm /= 0] + <> [ds d | d /= 0] + <> [hs h | h /= 0] + <> [ms m | m /= 0] + <> [ss s | s /= 0] + where + ss s = show s <> " sec" + ms m = show m <> " min" + hs 1 = "1 hour" + hs h = show h <> " hours" + ds 1 = "1 day" + ds 7 = "1 week" + ds 14 = "2 weeks" + ds d = show d <> " days" + mms 1 = "1 month" + mms mm = show mm <> " months" + +-- | Rewrite source with provided substitutions +render :: ByteString -> [(ByteString, Maybe ByteString)] -> ByteString +render src = \case + [] -> src + (label, content') : rest -> render (section_ label content' src) rest + +-- | Rewrite section content inside @...@ markers. +-- Markers are always removed when found. Closing marker is mandatory. +-- If content is absent, whole section is removed. +-- Section content is delegated to `item_`. If no sections found, the whole source is delegated. +section_ :: ByteString -> Maybe ByteString -> ByteString -> ByteString +section_ label content' src = + case B.breakSubstring startMarker src of + (_, "") -> item_ label (fromMaybe "" content') src -- no section, just replace items + (before, afterStart') -> + -- found section start, search for end too + case B.breakSubstring endMarker $ B.drop (B.length startMarker) afterStart' of + (_, "") -> error $ "missing section end: " <> show endMarker + (inside, next') -> + let next = B.drop (B.length endMarker) next' + in case content' of + Nothing -> before <> next -- collapse section + Just content -> before <> item_ label content inside <> section_ label content' next + where + startMarker = " label <> ">" + endMarker = " label <> ">" + +-- | Replace all occurences of @${label}@ with provided content. +item_ :: ByteString -> ByteString -> ByteString -> ByteString +item_ label content' src = + case B.breakSubstring marker src of + (done, "") -> done + (before, after') -> before <> content' <> item_ label content' (B.drop (B.length marker) after') + where + marker = "${" <> label <> "}" diff --git a/apps/smp-server/web/Static/Embedded.hs b/apps/smp-server/web/Static/Embedded.hs new file mode 100644 index 000000000..23698dd6f --- /dev/null +++ b/apps/smp-server/web/Static/Embedded.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Static.Embedded where + +import Data.FileEmbed (embedDir, embedFile) +import Data.ByteString (ByteString) + +indexHtml :: ByteString +indexHtml = $(embedFile "apps/smp-server/static/index.html") + +linkHtml :: ByteString +linkHtml = $(embedFile "apps/smp-server/static/link.html") + +mediaContent :: [(FilePath, ByteString)] +mediaContent = $(embedDir "apps/smp-server/static/media/") diff --git a/notes-flow.txt b/notes-flow.txt new file mode 100644 index 000000000..93f984509 --- /dev/null +++ b/notes-flow.txt @@ -0,0 +1,23 @@ +common: + corrId - random BS, used as CbNonce + entityId - p2r tlsUniq + +# setup +s->p: "proxy", uri, auth? + # unless connected + p->r: "p_handshake" + p<-r: "r_key", tls-signed dh pub +s<-r: "r_key", tls-signed dh pub # reply entityId contains tlsUniq + +# working +s ; generate random dh priv, make shared secret +s->p: s2r("forward", random dh pub, SEND command blob) + p->r: p2r("forward", random dh pub, s2r("forward", ...))) + r->c@ "msg", ... + p<-r: p2r("r_res", s2r("ok" / "error", error)) +s<-p@ s2r("ok" / "error", error) + +# expired + p<-r@ p2r("error", "key expired") +s<-p@ "error", "key expired" +s ; reconnect \ No newline at end of file diff --git a/package.yaml b/package.yaml index 084fe3a8f..303e84ef7 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplexmq -version: 5.7.0.4 +version: 6.0.0.1 synopsis: SimpleXMQ message broker description: | This package includes <./docs/Simplex-Messaging-Server.html server>, @@ -22,6 +22,8 @@ extra-source-files: - CHANGELOG.md - cbits/sha512.h - cbits/sntrup761.h + - apps/smp-server/static/*.html + - apps/smp-server/static/media/* dependencies: - aeson == 2.2.* @@ -85,6 +87,9 @@ flags: manual: True default: True +# cpp-options: +# - -Dslow_servers + when: - condition: flag(swift) cpp-options: @@ -110,10 +115,16 @@ library: executables: smp-server: - source-dirs: apps/smp-server + source-dirs: + - apps/smp-server + - apps/smp-server/web main: Main.hs dependencies: + - file-embed - simplexmq + - wai-app-static + - warp + - warp-tls ghc-options: - -threaded - -rtsopts @@ -136,15 +147,6 @@ executables: - -threaded - -rtsopts - smp-agent: - source-dirs: apps/smp-agent - main: Main.hs - dependencies: - - simplexmq - ghc-options: - - -threaded - - -rtsopts - xftp: source-dirs: apps/xftp main: Main.hs @@ -177,12 +179,31 @@ tests: ghc-options: # - -haddock - - -Wall + - -Weverything + - -Wno-missing-exported-signatures + - -Wno-missing-import-lists + - -Wno-missed-specialisations + - -Wno-all-missed-specialisations + - -Wno-unsafe + - -Wno-safe + - -Wno-missing-local-signatures + - -Wno-missing-kind-signatures + - -Wno-missing-deriving-strategies + - -Wno-monomorphism-restriction + - -Wno-prepositive-qualified-module + - -Wno-unused-packages + - -Wno-implicit-prelude + - -Wno-missing-safe-haskell-mode + - -Wno-missing-export-lists + - -Wno-partial-fields - -Wcompat + - -Werror=incomplete-record-updates - -Werror=incomplete-patterns + - -Werror=incomplete-uni-patterns + - -Werror=missing-methods + - -Werror=tabs - -Wredundant-constraints - -Wincomplete-record-updates - - -Wincomplete-uni-patterns - -Wunused-type-patterns - -O2 diff --git a/protocol/agent-protocol.md b/protocol/agent-protocol.md index 0da8af828..d8744f128 100644 --- a/protocol/agent-protocol.md +++ b/protocol/agent-protocol.md @@ -1,3 +1,5 @@ +Version 5, 2024-06-22 + # SMP agent protocol - duplex communication over SMP protocol ## Table of contents @@ -5,69 +7,61 @@ - [Abstract](#abstract) - [SMP agent](#smp-agent) - [SMP servers management](#smp-servers-management) -- [SMP agent protocol components](#smp-agent-protocol-components) +- [SMP agent protocol scope](#smp-agent-protocol-scope) - [Duplex connection procedure](#duplex-connection-procedure) +- [Contact addresses](#contact-addresses) - [Communication between SMP agents](#communication-between-smp-agents) - [Message syntax](#messages-between-smp-agents) - [HELLO message](#hello-message) - - [REPLY message](#reply-message) - - [MSG message](#msg-message) - - [INV message](#inv-message) - - [ACK message](#ack-message) - - [NEW message](#new-message) - - [DEL message](#del-message) -- [SMP agent commands](#smp-agent-commands) - - [Client commands and server responses](#client-commands-and-server-responses) - - [NEW command and INV response](#new-command-and-inv-response) - - [JOIN command](#join-command) - - [CONF notification and LET command](#conf-notification-and-let-command) - - [REQ notification and ACPT command](#req-notification-and-acpt-command) - - [INFO and CON notifications](#info-and-con-notifications) - - [SUB command](#sub-command) - - [SEND command and MID, SENT and MERR responses](#send-command-and-mid-sent-and-merr-responses) - - [MSG notification](#msg-notification) - - [END notification](#end-notification) - - [OFF command](#off-command) - - [DEL command](#del-command) -- [Connection request](#connection-request) + - [A_MSG message](#a_msg-message) + - [A_RCVD message](#a_rcvd-message) + - [EREADY message](#eready-message) + - [A_QCONT message](#a_qcont-message) + - [Rotating messaging queue](#rotating-messaging-queue) +- [End-to-end encryption](#end-to-end-encryption) +- [Connection link: 1-time invitation and contact address](#connection-link-1-time-invitation-and-contact-address) +- [Appendix A: SMP agent API](#smp-agent-api) + - [API functions](#api-functions) + - [API events](#api-events) ## Abstract The purpose of SMP agent protocol is to define the syntax and the semantics of communications between the client and the agent that connects to [SMP](./simplex-messaging.md) servers. It provides: -- protocol to create and manage bi-directional (duplex) connections between the users of SMP agents consisting of two (or more) separate unidirectional (simplex) SMP queues, abstracting away multiple steps required to establish bi-directional connections and any information about the servers location from the users of the agent protocol. +- API to create and manage bi-directional (duplex) connections between the users of SMP agents consisting of two (or more) separate unidirectional (simplex) SMP queues, abstracting away multiple steps required to establish bi-directional connections and any information about the servers location from the users of the agent protocol. - management of E2E encryption between SMP agents, generating ephemeral asymmetric keys for each connection. - SMP command authentication on SMP servers, generating ephemeral keys for each SMP queue. - TCP/TLS transport handshake with SMP servers. - validation of message integrity. -SMP agent protocol provides no encryption or security on the client side - it is assumed that the agent is executed in the trusted and secure environment, in one of three ways: -- via TCP network using secure connection. -- via local port (when the agent runs on the same device as a separate process). -- via agent library, when the agent logic is included directly into the client application - [SimpleX Chat for terminal](https://github.com/simplex-chat/simplex-chat) uses this approach. +SMP agent API provides no security between the agent and the client - it is assumed that the agent is executed in the trusted and secure environment, via the agent library, when the agent logic is included directly into the client application - [SimpleX Chat for terminal](https://github.com/simplex-chat/simplex-chat) uses this approach. ## SMP agent -SMP agents communicate with each other via SMP servers using [simplex messaging protocol (SMP)](./simplex-messaging.md) according to the commands received from its users. This protocol is a middle layer in SimpleX protocols (above SMP protocol but below any application level protocol) - it is intended to be used by client-side applications that need secure asynchronous bi-directional communication channels ("connections"). +SMP agents communicate with each other via SMP servers using [simplex messaging protocol (SMP)](./simplex-messaging.md) according to the API calls used by the client applications. This protocol is a middle layer in SimpleX protocols (above SMP protocol but below any application level protocol) - it is intended to be used by client-side applications that need secure asynchronous bi-directional communication channels ("connections"). The agent must have a persistent storage to manage the states of known connections and of the client-side information of SMP queues that each connection consists of, and also the buffer of the most recent sent and received messages. The number of the messages that should be stored is implementation specific, depending on the error management approach that the agent implements; at the very least the agent must store the hashes and IDs of the last received and sent messages. ## SMP servers management -SMP agent protocol commands do not contain the addresses of the SMP servers that the agent will use to create and use the connections (excluding the server address in queue URIs used in JOIN command). The list of the servers is a part of the agent configuration and can be dynamically changed by the agent implementation: +SMP agent API does not use the addresses of the SMP servers that the agent will use to create and use the connections (excluding the server address in queue URIs used in JOIN command). The list of the servers is a part of the agent configuration and can be dynamically changed by the agent implementation: - by the client applications via any API that is outside of scope of this protocol. - by the agents themselves based on availability and latency of the configured servers. -## SMP agent protocol components +## SMP agent protocol scope -SMP agent protocol has 3 main parts: +SMP agent protocol has 2 main parts: -- the syntax and semantics of the messages that SMP agents exchange with each other in order to: +- the messages that SMP agents exchange with each other in order to: - negotiate establishing unidirectional (simplex) encrypted queues on SMP servers. - exchange client messages and delivery notifications, providing sequential message IDs and message integrity (by including the hash of the previous message). -- the syntax and semantics of the commands that are sent by the agent clients to the agents. This protocol allows to create and manage multiple connections, each consisting of two or more SMP queues. -- the syntax and semantics of the message that the clients of SMP agents should send out-of-band (as pre-shared "invitation" including queue URIs) to protect [E2E encryption][1] from active attacks ([MITM attacks][2]). + - re-negotiate messaging queues to use and connection e2e encryption. +- the messages that the clients of SMP agents should send out-of-band (as pre-shared "invitation" including queue URIs) to protect [E2E encryption][1] from active attacks ([MITM attacks][2]). + +[Appendix A](#appendix-a-smp-agent-api) of this document describes: +- the functional API used by the client application with the agent. This API allows to create and manage multiple connections, each consisting of two or more SMP queues. +- events that the agent passes to the clients. ## Duplex connection procedure @@ -75,54 +69,126 @@ SMP agent protocol has 3 main parts: The procedure of establishing a duplex connection is explained on the example of Alice and Bob creating a bi-directional connection consisting of two unidirectional (simplex) queues, using SMP agents (A and B) to facilitate it, and two different SMP servers (which could be the same server). It is shown on the diagram above and has these steps: -1. Alice requests the new connection from the SMP agent A using SMP NEW command. -2. Agent A creates an SMP connection on the server (using [SMP protocol](./simplex-messaging.md)) and responds to Alice with the invitation that contains queue information and the encryption key Bob's agent B should use. The invitation format is described in [Connection request](#connection-request). -3. Alice sends the [connection request](#connection-request) to Bob via any secure channel (out-of-band message). -4. Bob sends `JOIN` command with the connection request as a parameter to agent B to accept the connection. -5. Establishing Alice's SMP queue (with SMP protocol commands): - - Agent B sends an "SMP confirmation" with SMP SEND command to the SMP queue specified in the connection request - SMP confirmation is an unauthenticated message with an ephemeral key that will be used to authenticate Bob's commands to the queue, as described in SMP protocol, and Bob's info (profile, public key for E2E encryption, etc.). This message is encrypted using key passed in the connection request (or with the derived key, in which case public key for key derivation should be sent in clear text). - - Agent A receives the SMP confirmation containing Bob's key and info as SMP MSG. - - Agent A notifies Alice sending REQ notification with Bob's info. - - Alice accepts connection request with ACPT command. - - Agent A secures the queue with SMP KEY command. - - Agent B tries sending authenticated SMP SEND command with agent `HELLO` message until it succeeds. Once it succeeds, Bob's agent "knows" the queue is secured. -6. Agent B creates a new SMP queue on the server. -7. Establish Bob's SMP queue: - - Agent B sends `REPLY` message (SMP SEND command) with the connection request to this 2nd queue to Alice's agent (via the 1st queue) - this connection request SHOULD use "simplex" URI scheme. - - Agent A, having received `REPLY` message, sends unauthenticated message (SMP SEND) to SMP queue with Alice agent's ephemeral key that will be used to authenticate Alice's commands to the queue, as described in SMP protocol, and Alice's info. - - Bob's agent receives the key and Alice's information and secures the queue (SMP KEY). - - Bob's agent sends the notification `INFO` with Alice's information to Bob. - - Alice's agent keeps sending `HELLO` message until it succeeds. -8. Agents A and B notify Alice and Bob that connection is established. - - Once sending `HELLO` succeeds, Alice's agent sends to Alice `CON` notification that confirms that now both parties can communicate. - - Once Bob's agent receives `HELLO` from Alice's agent, it sends to Bob `CON` notification as well. +1. Alice requests the new connection from the SMP agent A using agent `createConnection` api function. +2. Agent A creates an SMP queue on the server (using [SMP protocol](./simplex-messaging.md) `NEW` command) and responds to Alice with the invitation that contains queue information and the encryption keys Bob's agent B should use. The invitation format is described in [Connection link](connection-link-1-time-invitation-and-contact-address). +3. Alice sends the [connection link](#connection-link-1-time-invitation-and-contact-address) to Bob via any secure channel (out-of-band message) - as a link or as a QR code. +4. Bob uses agent `joinConnection` api function with the connection link as a parameter to agent B to accept the connection. +5. Agent B creates Bob's SMP reply queue with SMP server `NEW` command. +6. Agent B confirms the connection: sends an "SMP confirmation" with SMP server `SEND` command to the SMP queue specified in the connection link - SMP confirmation is an unauthenticated message with an ephemeral key that will be used to authenticate Bob's commands to the queue, as described in SMP protocol, and Bob's info (profile, public key for E2E encryption, and the connection link to this 2nd queue to Agent A - this connection link SHOULD use "simplex" URI scheme). This message is encrypted using key passed in the connection link (or with the derived shared secret, in which case public key for key derivation should be sent in clear text). +6. Alice confirms and continues the connection: + - Agent A receives the SMP confirmation containing Bob's key, reply queue and info as SMP server `MSG`. + - Agent A notifies Alice sending `CONF` notification with Bob's info. + - Alice allows connection to continue with agent `allowConnection` api function. + - Agent A secures the queue with SMP server `KEY` command. + - Agent A sends SMP confirmation with ephemeral sender key, ephemeral public encryption key and profile (but without reply queue). +7. Agent B confirms the connection: + - receives the confirmation. + - sends the notification `INFO` with Alice's information to Bob. + - secures SMP queue that it sent to Alice in the first confirmation with SMP `KEY` command . + - sends `HELLO` message via SMP `SEND` command. This confirms that the reply queue is secured and also validates that Agent A secured the first SMP queue +8. Agent A notifies Alice. + - receives `HELLO` message from Agent B. + - sends `HELLO` message to Agent B via SMP `SEND` command. + - sends `CON` notification to Alice, confirming that the connection is established. +9. Agent B notifies Bob. + - Once Agent B receives `HELLO` from Agent A, it sends to Bob `CON` notification as well. At this point the duplex connection between Alice and Bob is established, they can use `SEND` command to send messages. The diagram also shows how the connection status changes for both parties, where the first part is the status of the SMP queue to receive messages, and the second part - the status of the queue to send messages. The most communication happens between the agents and servers, from the point of view of Alice and Bob there are 4 steps (not including notifications): -1. Alice requests a new connection with `NEW` command and receives the invitation. -2. Alice passes connection request out-of-band to Bob. -3. Bob accepts the connection with `JOIN` command with the connection request to his agent. -4. Alice accepts the connection with `ACPT` command. +1. Alice requests a new connection with `createConnection` agent API function and receives the connection link. +2. Alice passes connection link out-of-band to Bob. +3. Bob accepts the connection with `joinConnection` agent API function with the connection link to his agent. +4. Alice accepts the connection with `ACPT` agent API function. 5. Both parties receive `CON` notification once duplex connection is established. Clients SHOULD support establishing duplex connection asynchronously (when parties are intermittently offline) by persisting intermediate states and resuming SMP queue subscriptions. +## Fast duplex connection procedure + +Previously described duplex connection procedure requires sending 4 messages creating a bad UX for the users - it requires waiting until each party in online before the messages can be sent. + +It allows users validating connecting party profile before proceeding with the connection, but it turned out to be unnecessary UX step and is not used in the client applications. + +It also protects against an attacker who compromised TLS and uses the sender queue ID sent to the recipient to secure the queue before the sender can. This attack is very hard, and this accepting its risk is better than worse UX. Future protocol versions could mitigate this attack by encrypting entity IDs. + +Faster duplex connection process is possible with the `SKEY` command added in v9 of SMP protocol. + +![Fast duplex connection procedure](./diagrams/duplex-messaging/duplex-creating-fast.svg) + +1. Alice requests the new connection from the SMP agent A using agent `createConnection` api function +2. Agent A creates an SMP queue on the server (using [SMP protocol](./simplex-messaging.md) `NEW` command with the flag allowing the sender to secure the queue) and responds to Alice with the invitation that contains queue information and the encryption keys Bob's agent B should use. The invitation format is described in [Connection link](connection-link-1-time-invitation-and-contact-address). +3. Alice sends the [connection link](connection-link-1-time-invitation-and-contact-address) to Bob via any secure channel (out-of-band message) - as a link or as a QR code. This link contains the flag that the queue can be secured by the sender. +4. Bob uses agent `joinConnection` api function with the connection link as a parameter to agent B to accept the connection. +5. Agent B secures Alice's queue with SMP command `SKEY` - this command can be proxied. +6. Agent B creates Bob's SMP reply queue with SMP server `NEW` command (with the flag allowing the sender to secure the queue). +7. Agent B confirms the connection: sends an "SMP confirmation" with SMP server `SEND` command to the SMP queue specified in the connection link - SMP confirmation is an unauthenticated message with an ephemeral key that will be used to authenticate Bob's commands to the queue, as described in SMP protocol, and Bob's info (profile, public key for E2E encryption, and the connection link to this 2nd queue to Agent A - this connection link SHOULD use "simplex" URI scheme). This message is encrypted using key passed in the connection link (or with the derived shared secret, in which case public key for key derivation should be sent in clear text). +8. Alice confirms the connection: + - Agent A receives the SMP confirmation containing Bob's key, reply queue and info as SMP server `MSG`. + - Agent A notifies Alice sending `CONF` notification with Bob's info (that indicates that Agent B already secured the queue). + - Alice allows connection to continue with agent `allowConnection` api function. + - Agent A secures Bob's queue with SMP command `SKEY`. + - Agent A sends SMP confirmation with ephemeral public encryption key and profile (but without reply queue, and without sender key). +9. Agent A notifies Alice with `CON` notification. +10. Agent B notifies Bob about connection success: + - receives confirmation message from Alice. + - sends the notification `INFO` with Alice's information to Bob. + - sends `CON` notification to Bob. + +## Contact addresses + +SMP agents support creating a special type of connection - a contact address - that allows to connect to multiple network users who can send connection requests by sending 1-time connection links to the message queue. + +This connection address uses a messaging queue on SMP server to receive invitations to connect - see `agentInvitation` message below. Once connection request is accepted, a new connection is created and the address itself is no longer used to send the messages - deleting this address does not disrupt the connections that were created via it. + ## Communication between SMP agents To establish duplex connections and to send messages on behalf of their clients, SMP agents communicate via SMP servers. Agents use SMP message client body (the part of the SMP message after header - see [SMP protocol](./simplex-messaging.md)) to transmit agent client messages and exchange messages between each other. -Each SMP message client body, once decrypted, contains 3 parts (one of them may include binary message body), as defined by `decryptedSmpMessageBody` syntax: +These messages are encrypted with per-queue shared secret using NaCL crypto_box and can be of 4 types, as defined by `decryptedSMPClientMessage`: +- `agentConfirmation` - used when confirming SMP queues, contains connection information encrypted with double ratchet. This envelope can only contain `agentConnInfo` or `agentConnInfoReply` encrypted with double ratchet. +- `agentMsgEnvelope` - contains different agent messages encrypted with double ratchet, as defined in `agentMessage`. +- `agentInvitation` - sent to SMP queue that is used as contact address, does not use double ratchet. +- `agentRatchetKey` - used to re-negotiate double ratchet encryption - can contain additional information in `agentRatchetKey`. +```abnf +decryptedSMPClientMessage = agentConfirmation / agentMsgEnvelope / agentInvitation / agentRatchetKey +agentConfirmation = agentVersion %s"C" ("0" / "1" sndE2EEncryptionParams) encConnInfo +agentVersion = 2*2 OCTET +sndE2EEncryptionParams = TODO +encConnInfo = doubleRatchetEncryptedMessage + +agentMsgEnvelope = agentVersion %s"M" encAgentMessage +encAgentMessage = doubleRatchetEncryptedMessage + +agentInvitation = agentVersion %s"I" connReqLength connReq connInfo +connReqLength = 2*2 OCTET ; Word16 + +agentRatchetKey = agentVersion %s"R" rcvE2EEncryptionParams agentRatchetInfo +rcvE2EEncryptionParams = TODO + +doubleRatchetEncryptedMessage = TODO +``` + +This syntax of decrypted SMP client message body is defined by `decryptedAgentMessage` below. + +Decrypted SMP message client body can be one of 4 types: +- `agentConnInfo` - used by the initiating party when confirming reply queue - sent in `agentConfirmation` envelope. +- `agentConnInfoReply` - used by accepting party, includes reply queue(s) in the initial confirmation - sent in `agentConfirmation` envelope. +- `agentRatchetInfo` - used to pass additional information when renegotiating double ratchet encryption - sent in `agentRatchetKey` envelope. +- `agentMessage` - all other agent messages. + +`agentMessage` contains these parts: - `agentMsgHeader` - agent message header that contains sequential agent message ID for a particular SMP queue, agent timestamp (ISO8601) and the hash of the previous message. -- `agentMessage` - a command/message to the other SMP agent: - - to establish the connection with two SMP queues (`helloMsg`, `replyQueueMsg`) - - to send and to acknowledge user messages (`clientMsg`, `acknowledgeMsg`) - - to manage SMP queue rotation (`newQueueMessage`, `deleteQueueMsg`) - - to manage encryption key rotation (TODO) +- `aMessage` - a command/message to the other SMP agent: + - to confirm the connection (`HELLO`). + - to send and to confirm reception of user messages (`A_MSG`, `A_RCVD`). + - to confirm that the new double ratchet encryption is agreed (`EREADY`). + - to notify another party that it can continue sending messages after queue capacity was exceeded (`A_QCONT`). + - to manage SMP queue rotation (`QADD`, `QKEY`, `QUSE`, `QTEST`). - `msgPadding` - an optional message padding to make all SMP messages have constant size, to prevent servers from observing the actual message size. The only case the message padding can be absent is when the message has exactly the maximum size, in all other cases the message MUST be padded to a fixed size. ### Messages between SMP agents @@ -130,269 +196,160 @@ Each SMP message client body, once decrypted, contains 3 parts (one of them may Message syntax below uses [ABNF][3] with [case-sensitive strings extension][4]. ```abnf -decryptedSmpMessageBody = agentMsgHeader CRLF agentMessage CRLF msgPadding -agentMsgHeader = agentMsgId SP previousMsgHash ; here `agentMsgId` is sequential ID set by the sending agent -agentMsgId = 1*DIGIT -previousMsgHash = encoded -encoded = +decryptedAgentMessage = agentConnInfo / agentConnInfoReply / agentRatchetInfo / agentMessage +agentConnInfo = %s"I" connInfo +connInfo = *OCTET +agentConnInfoReply = %s"D" smpQueues connInfo +agentRatchetInfo = %s"R" ratchetInfo -agentMessage = helloMsg / replyQueueMsg / - clientMsg / invitationMsg / - newQueueMessage / deleteQueueMsg +agentMessage = %s"M" agentMsgHeader aMessage msgPadding +agentMsgHeader = agentMsgId prevMsgHash +agentMsgId = 8*8 OCTET ; Int64 +prevMsgHash = shortString -msgPadding = *OCTET ; optional random bytes to get messages to the same size (as defined in SMP message size) +aMessage = HELLO / A_MSG / A_RCVD / EREADY / A_QCONT / + QADD / QKEY / QUSE / QTEST -helloMsg = %s"H" +HELLO = %s"H" -replyQueueMsg = %s"R" connectionRequest ; `connectionRequest` is defined below -; this message can only be sent by the second connection party +A_MSG = %s"M" userMsgBody +userMsgBody = *OCTET -clientMsg = %s"M" clientMsgBody -clientMsgBody = *OCTET +A_RCVD = %s"V" msgReceipt +msgReceipt = agentMsgId msgHash rcptLength rcptInfo -; TODO remove and move to "public" header -invitationMsg = %s"INV" SP connReqInvitation SP connInfo -; `connReqInvitation` and `connInfo` are defined below +EREADY = %s"E" agentMsgId -newQueueMsg = %s"N" queueURI -; this message can be sent by any party to add SMP queue to the connection. -; NOT SUPPORTED in the current implementation +A_QCONT = %s"QC" sndQueueAddr -deleteQueueMsg = %s"D" queueURI -; notification that the queue with passed URI will be deleted -; no need to notify the other party about suspending queue separately, as suspended and deleted queues are indistinguishable to the sender -; NOT SUPPORTED in the current implementation +QADD = %s"QA" sndQueues +sndQueues = length 1*(newQueueUri replacedSndQueue) +newQueueUri = clientVRange smpServer senderId dhPublicKey [sndSecure] +dhPublicKey = length x509encoded +sndSecure = "T" +replacedSndQueue = "0" / "1" sndQueueAddr + +QKEY = %s"QK" sndQueueKeys +sndQueueKeys = length 1*(newQueueInfo senderKey) +newQueueInfo = version smpServer senderId dhPublicKey [sndSecure] +senderKey = length x509encoded + +QUSE = %s"QU" sndQueuesReady +sndQueuesReady = length 1*(sndQueueAddr primary) +primary = %s"T" / %s"F" + +QTEST = %s"QT" sndQueueAddrs +sndQueueAddrs = length 1*sndQueueAddr + +sndQueueAddr = smpServer senderId +smpServer = hosts port keyHash +hosts = length 1*host +host = shortString +port = shortString +keyHash = shortString +senderId = shortString + +clientVRange = version version +version = 2*2 OCTET + +msgPadding = *OCTET +rcptLength = 2*2 OCTET +shortString = length *OCTET +length = 1*1 OCTET ``` #### HELLO message -This is the first message that both agents send after the respective SMP queue is secured by the receiving agent (see diagram). It MAY contain the public key that the recipient would use to verify messages signed by the sender. +This is the first message that both agents send after the respective SMP queue is secured by the receiving agent (see diagram). -Sending agent might need to retry sending HELLO message, as it would not have any other confirmation that the queue is secured other than the success of sending this message with the signed SMP SEND command. +This message is not used with [fast duplex connection](#fast-duplex-connection-procedure). -#### REPLY message +#### A_MSG message -This is the message that is sent by the agent that received an out-of-band connection request to pass the connection request for the reply SMP queues to the agent that originated the connection (see diagram). +This is the agent envelope used to send client messages once the connection is established. This is different from the MSG sent by SMP server to the agent and MSG event from SMP agent to the client that are sent in different contexts. -#### MSG message +#### A_RCVD message -This is the agent envelope used to send client messages once the connection is established. Do not confuse it with the MSG response from SMP server to the agent and MSG response from SMP agent to the client that are sent in different contexts. +This message is sent to confirm the client message reception. It includes received message number and message hash. -#### INV message +#### EREADY message -This message is sent to the SMP queue(s) in `connReqContact`, to establish a new connection via existing unsecured queue, that acts as a permanent connection link of a user. +This message is sent after re-negotiating a new double ratchet encryption with `agentRatchetKey`. -#### ACK message +#### A_QCONT message -This message is sent to confirm the client message reception. It includes received message number, message hash and the reception status. +This message is sent to notify the sender client that it can continue sending the messages after queue capacity was exhausted. -#### NEW message +### Rotating messaging queue -This message is sent to add an additional SMP queue to the connection. Unlike REPLY message it can be sent at any time. +SMP agents SHOULD support 4 messages to rotate message reception to another messaging server: +`QADD`: add the new queue address(es) to the connection - sent by the client that initiates rotation. +`QKEY`: pass sender's key via existing connection (SMP confirmation message will not be used, to avoid the same "race" of the initial key exchange that would create the risk of intercepting the queue for the attacker) - sent by the client accepting the rotation +`QUSE`: instruct the sender to use the new queue with sender's queue ID as parameter. From this point some messages can be sent to both the new queue and the old queue. +`QTEST`: send test message to the new connection. Any other message can be sent if available to continue rotation, the absence of this message is not an error. Once this message is successfully sent the sender will stop using the old queue. Once this message (or any other message in the new queue) is received, the recipient will stop using the old queue and delete it. -#### DEL message +**Queue rotation procedure** -This message is sent to notify that the queue with passed URI will be deleted - having received this message, the receiving agent should no longer send messages to this queue. In case it was the last remaining send queue in the duplex connection, the agent MAY also delete the reply queue(s) in the connection. +![Queue rotation procedure](./diagrams/duplex-messaging/queue-rotation.svg) -## SMP agent commands +`SKEY` command added in v9 of SMP protocol allows for faster queue rotation procedure. -This part describes the transmissions between users and client-side SMP agents: commands that the users send to create and operate duplex connections and SMP agent responses and messages they deliver. +**Fast queue rotation procedure** -Commands syntax below is provided using [ABNF][3] with [case-sensitive strings extension][4]. +![Fast queue rotation procedure](./diagrams/duplex-messaging/queue-rotation-fast.svg) -Each transmission between the user and SMP agent must have this format/syntax: +## End-to-end encryption -```abnf -agentTransmission = [corrId] CRLF [connId] CRLF agentCommand +Messages between SMP agents have two layers of e2e encryption: +- simple encryption agreed in SMP protocol with a fixed key agreed when the messaging queue is agreed by parties. +- post-quantum resistant augmented double ratchet algorithm (PQDR) specified in [this document](./pqdr.md). -corrId = 1*(%x21-7F) ; any characters other than control/whitespace +The protocol supports adding and removing post-quantum KEM primitive to the key agreement in double ratchet: +- to support migration of pre-existing connections to PQDR. +- to be able to disable PQ key agreement. +- to be able to use invitation links and contact addresses without large PQ keys. -connId = encoded +Possible scenarios below show the possible states of PQ key agreement, assuming that both clients support it. -agentCommand = (userCmd / agentMsg) CRLF -userCmd = newCmd / joinCmd / letCmd / acceptCmd / subscribeCmd / sendCmd / acknowledgeCmd / suspendCmd / deleteCmd -agentMsg = invitation / confMsg / connReqMsg / connInfo / connected / unsubscribed / connDown / connUp / messageId / sent / messageError / message / received / ok / error +Possible options for each stage are: +- no KEM encapsulation key was sent (No PQ key), +- only KEM encapsulation key was sent, but not ciphertext yet (PQ key sent), +- both KEM encapsulation key from one KEM agreement and ciphertext from the previous agreement were sent (PQ key + PQ ct sent). -newCmd = %s"NEW" SP connectionMode [SP %s"NO_ACK"] ; response is `invitation` or `error` -; NO_ACK parameter currently not supported +`+` in the table means that this scenario is possible, and `-` - that it is not possible. -connectionMode = %s"INV" / %s"CON" +| Connection stage | No PQ key | PQ key sent | PQ key + PQ ct sent | +|:------------------------------------------------------:|:----------------:|:----------------:|:-------------------:| +| invitation | + | + | - | +| confirmation, in reply to:
no-pq inv
pq inv |  
+
+ |  
+
- |  
-
+ | +| 1st msg, in reply to:
no-pq conf
pq/pq+ct conf |  
+
+ |  
+
- |  
-
+ | +| Nth msg, in reply to:
no-pq msg
pq/pq+ct msg |  
+
+ |  
+
- |  
-
+ | -invitation = %s"INV" SP connectionRequest ; `connectionRequest` is defined below +These scenarios can be reduced to: +1. initial invitation optionally has PQ key, but must not have ciphertext. +2. all subsequent messages should be allowed without PQ key/ciphertext, but: + - if the previous message had PQ key or PQ key with ciphertext, they must either have no PQ key, or have PQ key with ciphertext (PQ key without ciphertext is an error). + - if the previous message had no PQ key, they must either have no PQ key, or have PQ key without ciphertext (PQ key with ciphertext is an error). -confMsg = %s"CONF" SP confirmationId SP msgBody -; msgBody here is any binary information identifying connection request +The rules for calculating the shared secret for received/sent messages are (assuming received message is valid according to the above rules): -letCmd = %s"LET" SP confirmationId SP msgBody -; msgBody here is any binary information identifying connecting party +| sent msg >
V received msg | no-pq | pq | pq+ct | +|:------------------------------:|:-----------:|:-------:|:---------------:| +| no-pq | DH / DH | DH / DH | err | +| pq (sent msg was NOT pq) | DH / DH | err | DH / DH+KEM | +| pq+ct (sent msg was NOT no-pq) | DH+KEM / DH | err | DH+KEM / DH+KEM | -confirmationId = 1*DIGIT +To summarize, the upgrade to DH+KEM secret happens in a sent message that has PQ key with ciphertext sent in reply to message with PQ key only (without ciphertext), and the downgrade to DH secret happens in the message that has no PQ key. -connReqMsg = %s"REQ" SP invitationId SP msgBody -; msgBody here is any binary information identifying connection request +## Connection link: 1-time invitation and contact address -acceptCmd = %s"ACPT" SP invitationId SP msgBody -; msgBody here is any binary information identifying connecting party +Connection links are generated by SMP agent in response to `createConnection` api call, used by another party user with `joinConnection` api, and then another connection link is sent by the agent in `agentConnInfoReply` and used by the first party agent to connect to the reply queue (the second part of the process is invisible to the users). -invitationId = 1*DIGIT - -connInfo = %s"INFO" SP msgBody -; msgBody here is any binary information identifying connecting party - -connected = %s"CON" - -subscribeCmd = %s"SUB" ; response is `ok` or `error` - -unsubscribed = %s"END" -; when another agent (or another client of the same agent) -; subscribes to the same SMP queue on the server - -connDown = %s"DOWN" -; lost connection (e.g. because of Internet connectivity or server is down) - -connUp = %s"UP" -; restored connection - -joinCmd = %s"JOIN" SP connectionRequest SP connInfo [SP %s"NO_REPLY"] [SP %s"NO_ACK"] -; `connectionRequest` and `connInfo` are defined below -; response is `connected` or `error` -; parameters NO_REPLY and NO_ACK are currently not supported - -suspendCmd = %s"OFF" ; can be sent by either party, response `ok` or `error` - -deleteCmd = %s"DEL" ; can be sent by either party, response `ok` or `error` - -sendCmd = %s"SEND" SP msgBody -; send syntax is similar to that of SMP protocol, but it is wrapped in SMP message -msgBody = stringMsg | binaryMsg -stringMsg = ":" string ; until CRLF in the transmission -string = *(%x01-09 / %x0B-0C / %x0E-FF %) ; any characters other than NUL, CR and LF -binaryMsg = size CRLF msgBody CRLF ; the last CRLF is in addition to CRLF in the transmission -size = 1*DIGIT ; size in bytes -msgBody = *OCTET ; any content of specified size - safe for binary - -messageId = %s"MID" SP agentMsgId - -sent = %s"SENT" SP agentMsgId - -messageError = %s"MERR" SP agentMsgId SP - -message = %s"MSG" SP msgIntegrity SP recipientMeta SP brokerMeta SP senderMeta SP binaryMsg -recipientMeta = %s"R=" agentMsgId "," agentTimestamp ; receiving agent message metadata -brokerMeta = %s"B=" brokerMsgId "," brokerTimestamp ; broker (server) message metadata -senderMeta = %s"S=" agentMsgId ; sending agent message ID -brokerMsgId = encoded -brokerTimestamp = -msgIntegrity = ok / msgIntegrityError - -msgIntegrityError = %s"ERR" SP msgIntegrityErrorType -msgIntegrityErrorType = skippedMsgErr / badMsgIdErr / badHashErr - -skippedMsgErr = %s"NO_ID" SP missingFromMsgId SP missingToMsgId -badMsgIdErr = %s"ID" SP previousMsgId ; ID is lower than the previous -badHashErr = %s"HASH" - -missingFromMsgId = agentMsgId -missingToMsgId = agentMsgId -previousMsgId = agentMsgId - -acknowledgeCmd = %s"ACK" SP agentMsgId ; ID assigned by receiving agent (in MSG "R") - -received = %s"RCVD" SP agentMsgId SP msgIntegrity -; ID assigned by sending agent (in SENT response) -; currently not implemented - -msgStatus = ok | error - -ok = %s"OK" - -error = %s"ERR" SP -``` - -### Client commands and server responses - -#### NEW command and INV response - -`NEW` command is used to create a connection and a connection request to be sent out-of-band to another protocol user (the joining party). It should be used by the client of the agent that initiates creating a duplex connection (the initiating party). - -`INV` response is sent by the agent to the client of the initiating party. - -`NEW` command has `connectionMode` parameter to define the connection mode - to be used to communicate with a single contact (invitation mode, `connectionMode` is `INV`) or to accept connection requests from anybody (contact mode, `connectionMode` is `CON`). The type of connection request is determined by `connectionMode` parameter. - -#### JOIN command - -It is used to create a connection and accept the connection request received out-of-band. It should be used by the client of the agent that accepts the connection (the joining party). - -#### CONF notification and LET command - -When the joining party uses `JOIN` command to accept connection invitation created with `NEW INV` command, the initiating party will receive `CONF` notification with some numeric identifier and an additional binary information, that can be used to identify the joining party or for any other purpose. - -To continue with the connection the initiating party should use `LET` command. - -#### REQ notification and ACPT command - -When the joining party uses `JOIN` command to connect to the contact created with `NEW CON` command, the initiating party will receive `REQ` notification with some numeric identifier and an additional binary information, that can be used to identify the joining party or for any other purpose. - -To continue with the connection the party that created the contact should use `ACPT` command. - -#### INFO and CON notifications - -After the initiating party proceeds with the connection using `ACPT` command, the joining party will receive `INFO` notification that can be used to identify the initiating party or for any other purpose. - -Once the connection is established and ready to accept client messages, both agents will send `CON` notification to their clients. - -#### SUB command - -This command can be used by the client to resume receiving messages from the connection that was created in another TCP/client session. Agent response to this command can be `OK` or `ERR` in case connection does not exist (or can only be used to send connections - e.g. when the reply queue was not created). - -#### SEND command and MID, SENT, RCVD and MERR responses - -`SEND` command is used by the client to send messages. - -`MID` response with the message ID (the sequential message number that includes both sent and received messages in the connection) is sent to the client to confirm that the message is accepted by the agent, before it is sent to the SMP server. - -`SENT` notification is sent by the agent to confirm that the message was delivered to at least one of SMP servers. This notification contains the same message ID as `MID` notification. `SENT` notification, depending on network availability, can be sent at any time later, potentially in the next client session. - -`RCVD` notification is sent by the agent when it receives `ACK` message from the receiving agent. This notification contains reception status, only one successful notification will be sent, and multiple error notifications will be sent in case `ACK` had error status. - -In case of the failure to send the message for any other reason than network connection or message queue quota - e.g. authentication error (`ERR AUTH`) or syntax error (`ERR CMD error`), the agent will send to the client `MERR` notification with the message ID, and this message delivery will no longer be attempted to this SMP queue. - -#### MSG notification - -It is sent by the agent to the client when agent receives the message from the SMP server. It has message ID and timestamp from both the receiving and sending agents and from SMP server: -- recipient agent ID is intended to be used to refer to the message in the future. -- sender agent ID is intended to be used to identify any missed / skipped message(s) -- broker ID should be used to detect duplicate deliveries (it would happen if TCP connection is lost before the message is acknowledged by the agent - see [SMP protocol](./simplex-messaging.md)) - -#### END notification - -It is sent by the agent to the client when agent receives SMP protocol `END` notification from SMP server. It indicates that another agent has subscribed to the same SMP queue on the server and the server terminated the subscription of the current agent. - -#### DOWN and UP notifications - -These notifications are sent when server or network connection is, respectively, `DOWN` or back `UP`. - -All the subscriptions made in the current client session will be automatically resumed when `UP` notification is received. - -#### OFF command - -It is used to suspend the receiving SMP queue - sender will no longer be able to send the messages to the connection, but the recipient can retrieve the remaining messages. Agent response to this command can be `OK` or `ERR`. This command is irreversible. - -#### DEL command - -It is used to delete the connection and all messages in it, as well as the receiving SMP queue and all messages in it that were remaining on the server. Agent response to this command can be `OK` or `ERR`. This command is irreversible. - -## Connection request - -Connection request `connectionRequest` is generated by SMP agent in response to `newCmd` command (`"NEW"`), used by another party user with `joinCmd` command (`"JOIN"`), and then another connection request is sent by the agent in `replyQueueMsg` and used by the first party agent to connect to the reply queue (the second part of the process is invisible to the users). - -Connection request syntax: +Connection link syntax: ``` -connectionRequest = connectionScheme "/" connReqType "#/?smp=" smpQueues "&e2e=" e2eEncryption -connReqType = %s"invitation" / %s"contact" -; this parameter has the same meaning as connectionMode in agent commands -; `NEW INV` creates `invitation` connection request, `NEW CON` - `contact` +connectionLink = connectionScheme "/" connLinkType "#/?smp=" smpQueues "&e2e=" e2eEncryption +connLinkType = %s"invitation" / %s"contact" connectionScheme = (%s"https://" clientAppServer) | %s"simplex:" clientAppServer = hostname [ ":" port ] ; client app server, e.g. simplex.chat @@ -407,12 +364,112 @@ smpQueue = All parameters are passed via URI hash to avoid sending them to the server (in case "https" scheme is used) - they can be used by the client-side code and processed by the client application. Parameters `smp` and `e2e` can be present in any order, any unknown additional parameters SHOULD be ignored. -`clientAppServer` is not an SMP server - it is a server that shows the instruction on how to download the client app that will connect using this connection request. This server can also host a mobile or desktop app manifest so that this link is opened directly in the app if it is installed on the device. +`clientAppServer` is not an SMP server - it is a server that shows the instruction on how to download the client app that will connect using this connection link. This server can also host a mobile or desktop app manifest so that this link is opened directly in the app if it is installed on the device. "simplex" URI scheme in `connectionProtocol` can be used instead of client app server, to connect without creating any web traffic. Client apps MUST support this URI scheme. See SMP protocol [out-of-band messages](./simplex-messaging.md#out-of-band-messages) for syntax of `queueURI`. +## Appendix A: SMP agent API + +The exact specification of agent library API and of the events that the agent sends to the client application is out of scope of the protocol specification. + +The list of some of the API functions and events below is supported by the reference implementation, and they are likely to be required by the client applications. + +### API functions + +The list of APIs below is not exhaustive and provided for information only. Please consult the source code for more information. + +#### Create conection + +`createConnection` api is used to create a connection - it returns the connection link that should be sent out-of-band to another protocol user (the joining party). It should be used by the client of the agent that initiates creating a duplex connection (the initiating party). + +This api is also used to create a contact address - a special connection that can be used by multiple people to connect to the user. + +Some communication scenarios may require fault-tolerant mechanism of creating connections that retries on network failures and continue retrying after the client is restarted. Such asynchronous API would return its result via `INV` event once it succeeds. + +#### Join connection + +`joinConnection` is used to create a connection record and accept the connection invitation received out-of-band. It should be used by the client of the agent that accepts the connection (the joining party). + +This api can also be required as asynchronous, in which case `OK` event will be dispatched to the client to indicate the success or `ERR` in case it permanently failed (e.g., in case connection was deleted by another party). + +#### Allow connection + +Once the client receives `CONF` event, it should use synchronous `allowConnection` api to proceed with the connection (both for the [standard](#duplex-connection-procedure) and for the [fast duplex procedure](#fast-duplex-connection-procedure)). + +In case this API is used as asynchronous it will return its result via `OK` or `ERR` event. + +#### Accept and reject connection requests + +Connection requests are delivered to the client application via `REQ` event. + +Client can `acceptContact` and `rejectContact`, with `OK` and `ERR` events in case of asynchronous calls. + +#### Send message + +`sendMessage` api is always asynchronous. The api call returns message ID, `SENT` event once the message is sent to the server, `MWARN` event in case of temporary delivery failure that can be resolved by the user (e.g., by connecting via Tor or by upgrading the client) and `MERR` in case of permanent delivery failure. + +#### Acknowledge received message + +Messages are delivered to the client application via `MSG` event. + +Client application must always `ackMessage` to receive the next one - failure to call it in reference implementation will prevent the delivery of subsequent messages until the client reconnects to the server. + +This api is also used to acknowledge message delivery to the sending party - that party client application will receive `RCVD` event. + +#### Subscribe connection + +`subscribeConnection` api is used by the client to resume receiving messages from the connection that was created in another TCP/client session. + +#### Get notification message + +`getNotificationMessage` is used by push notification subsystem of the client application to receive the message from a specific messaging queue mentioned in the notification. The client application would receive `MSG` and any other events from the agent, and then `MSGNTF` event once the message related to this notification is received. + +#### Rotate message queue to another server + +`switchConnection` api is used to rotate connection queues to another messaging server. + +#### Renegotiate e2e encryption + +`synchronizeRatchet` api is used to re-negotiate double ratchet encryption for the connection. + +#### Delete connection + +`deleteConnection` api is used to delete connection. In case of asynchronous call, the connection deletion will be confirmed with `DEL_RCVQ` and `DEL_CONN` events. + +#### Suspend connection + +`suspendConnection` api is used to prevent any further messages delivered to the connection without deleting it. + +### API events + +Agent API uses these events dispatch to notify client application about events related to the connections: +- `INV` - connection invitation or connection address URI after connection is created. +- `CONF` - confirmation that connection is accepted by another party. When the accepting party uses `joinConnection` api to accept connection invitation, the initiating party will receive `CONF` notification with some identifier and additional information from the accepting party (e.g., profile). To continue the connection the initiating party client should use `allowConnection` api. +- `REQ` - connection request is sent when another party uses `joinConnection` api with contact address. The client application can use `acceptContact` or `rejectContact` api. +- `INFO` - information from the party that initiated the connection with `createConnection` sent to the party accepting the connection with `joinConnection`. +- `CON` - notification that connection is established sent to both parties of the connection. +- `END` - notification that connection subscription is terminated when another client subscribed to the same messaging queue. +- `DOWN` - notification that connection server is temporarily unavailable. +- `UP` - notification that the subscriptions made in the current client session are resumed after the server became available. +- `SWITCH` - notification about queue rotation process. +- `RSYNC` - notification about e2e encryption re-negotiation process. +- `SENT` - notification to confirm that the message was delivered to at least one of SMP servers. This notification contains the same message ID as returned to `sendMessage` api. `SENT` notification, depending on network availability, can be sent at any time later, potentially in the next client session. +- `MWARN` - temporary delivery failure that can be resolved by the user (e.g., by connecting via Tor or by upgrading the client). +- `MERR` - notification about permanent message delivery failure. +- `MERRS` - notification about permanent message delivery failure for multiple messages (e.g., when multiple messages expire). +- `MSG` - sent when agent receives the message from the SMP server. +- `MSGNTF` - sent after agent received and processed the message referenced in the push notification. +- `RCVD` - notification confirming message receipt by another party. +- `QCONT` - notification that the agent continued sending messages after queue capacity was exceeded and recipient received all messages. +- `DEL_RCVQ` - confirmation that message queue was deleted. +- `DEL_CONN` - confirmation that connection was deleted. +- `OK` - confirmation that asynchronous api call was successful. +- `ERR` - error of asynchronous api call or some other error event. + +This list of events is not exhaustive and provided for information only. Please consult the source code for more information. + [1]: https://en.wikipedia.org/wiki/End-to-end_encryption [2]: https://en.wikipedia.org/wiki/Man-in-the-middle_attack [3]: https://tools.ietf.org/html/rfc5234 diff --git a/protocol/diagrams/duplex-messaging/duplex-creating-fast.mmd b/protocol/diagrams/duplex-messaging/duplex-creating-fast.mmd new file mode 100644 index 000000000..674cc502f --- /dev/null +++ b/protocol/diagrams/duplex-messaging/duplex-creating-fast.mmd @@ -0,0 +1,65 @@ +sequenceDiagram + participant A as Alice + participant AA as Alice's
agent + participant AS as Alice's
server + participant BS as Bob's
server + participant BA as Bob's
agent + participant B as Bob + + note over AA, BA: status (receive/send): NONE/NONE + + note over A, AA: 1. request connection
from agent + A ->> AA: createConnection + + note over AA, AS: 2. create Alice's SMP queue + AA ->> AS: NEW: create SMP queue
allow sender to secure + AS ->> AA: IDS: SMP queue IDs + note over AA: status: NEW/NONE + + AA ->> A: INV: invitation
to connect + + note over A, B: 3. out-of-band invitation + A ->> B: OOB: invitation to connect + + note over BA, B: 4. accept connection + B ->> BA: joinConnection:
via invitation info + note over BA: status: NONE/NEW + + note over BA, AS: 5. secure Alice's SMP queue + BA ->> AS: SKEY: secure queue (this command needs to be proxied) + note over BA: status: NONE/SECURED + + note over BA, BS: 6. create Bob's SMP queue + BA ->> BS: NEW: create SMP queue
allow sender to secure + BS ->> BA: IDS: SMP queue IDs + note over BA: status: NEW/SECURED + + note over BA, AA: 7. confirm Alice's SMP queue + BA ->> AS: SEND: Bob's info without sender's key (SMP confirmation with reply queues) + note over BA: status: NEW/CONFIRMED + + AS ->> AA: MSG: Bob's info without
sender server key + note over AA: status: CONFIRMED/NEW + AA ->> AS: ACK: confirm message + AA ->> A: CONF: connection request ID
and Bob's info + A -> AA: allowConnection: accept connection request,
send Alice's info + + note over AA, BS: 8. secure Bob's SMP queue + AA ->> BS: SKEY: secure queue (this command needs to be proxied) + note over BA: status: CONFIRMED/SECURED + + AA ->> BS: SEND: Alice's info without sender's server key (SMP confirmation without reply queues) + note over AA: status: CONFIRMED/CONFIRMED + + note over AA, A: 9. notify Alice
about connection success
(no HELLO needed in v6) + AA ->> A: CON: connected + note over AA: status: ACTIVE/ACTIVE + + note over BA, B: 10. notify Bob
about connection success + BS ->> BA: MSG: Alice's info without
sender's server key + note over BA: status: CONFIRMED/CONFIRMED + BA ->> B: INFO: Alice's info + BA ->> BS: ACK: confirm message + + BA ->> B: CON: connected + note over BA: status: ACTIVE/ACTIVE diff --git a/protocol/diagrams/duplex-messaging/duplex-creating-fast.svg b/protocol/diagrams/duplex-messaging/duplex-creating-fast.svg new file mode 100644 index 000000000..bea3bb23d --- /dev/null +++ b/protocol/diagrams/duplex-messaging/duplex-creating-fast.svg @@ -0,0 +1,3 @@ + + +BobBob'sagentBob'sserverAlice'sserverAlice'sagentAliceBobBob'sagentBob'sserverAlice'sserverAlice'sagentAlicestatus (receive/send): NONE/NONE1. request connectionfrom agent2. create Alice's SMP queuestatus: NEW/NONE3. out-of-band invitation4. accept connectionstatus: NONE/NEW5. secure Alice's SMP queuestatus: NONE/SECURED6. create Bob's SMP queuestatus: NEW/SECURED7. confirm Alice's SMP queuestatus: NEW/CONFIRMEDstatus: CONFIRMED/NEW8. secure Bob's SMP queuestatus: CONFIRMED/SECUREDstatus: CONFIRMED/CONFIRMED9. notify Aliceabout connection success(no HELLO needed in v6)status: ACTIVE/ACTIVE10. notify Bobabout connection successstatus: CONFIRMED/CONFIRMEDstatus: ACTIVE/ACTIVEcreateConnectionNEW: create SMP queueallow sender to secureIDS: SMP queue IDsINV: invitationto connectOOB: invitation to connectjoinConnection:via invitation infoSKEY: secure queue (this command needs to be proxied)NEW: create SMP queueallow sender to secureIDS: SMP queue IDsSEND: Bob's info without sender's key (SMP confirmation with reply queues)MSG: Bob's info withoutsender server keyACK: confirm messageCONF: connection request IDand Bob's infoallowConnection: accept connection request,send Alice's infoSKEY: secure queue (this command needs to be proxied)SEND: Alice's info without sender's server key (SMP confirmation without reply queues)CON: connectedMSG: Alice's info withoutsender's server keyINFO: Alice's infoACK: confirm messageCON: connected \ No newline at end of file diff --git a/protocol/diagrams/duplex-messaging/duplex-creating-v2.mmd b/protocol/diagrams/duplex-messaging/duplex-creating-v2.mmd deleted file mode 100644 index 09ee913ff..000000000 --- a/protocol/diagrams/duplex-messaging/duplex-creating-v2.mmd +++ /dev/null @@ -1,71 +0,0 @@ -sequenceDiagram - participant A as Alice - participant AA as Alice's
agent - participant AS as Alice's
server - participant BS as Bob's
server - participant BA as Bob's
agent - participant B as Bob - - note over AA, BA: status (receive/send): NONE/NONE - - note over A, AA: 1. request connection
from agent - A ->> AA: NEW: create
duplex connection - - note over AA, AS: 2. create Alice's SMP queue - AA ->> AS: NEW: create SMP queue - AS ->> AA: IDS: SMP queue IDs - note over AA: status: NEW/NONE - - AA ->> A: INV: invitation
to connect - - note over A, B: 3. out-of-band invitation - A ->> B: OOB: invitation to connect - - note over BA, B: 4. accept connection - B ->> BA: JOIN:
via invitation info - note over BA: status: NONE/NEW - - note over BA, BS: 5. create Bob's SMP queue - BA ->> BS: NEW: create SMP queue - BS ->> BA: IDS: SMP queue IDs - note over BA: status: NEW/NEW - - note over BA, AA: 6. establish Alice's SMP queue - BA ->> AS: SEND: Bob's info and sender server key (SMP confirmation with reply queues) - note over BA: status: NEW/CONFIRMED - - AS ->> AA: MSG: Bob's info and
sender server key - note over AA: status: CONFIRMED/NONE - AA ->> AS: ACK: confirm message - AA ->> A: CONF: connection request ID
and Bob's info - A ->> AA: LET: accept connection request,
send Alice's info - AA ->> AS: KEY: secure queue - note over AA: status: SECURED/NONE - - AA ->> BS: SEND: Alice's info and sender's server key (SMP confirmation without reply queues) - note over AA: status: SECURED/CONFIRMED - - BS ->> BA: MSG: Alice's info and
sender's server key - note over BA: status: CONFIRMED/CONFIRMED - BA ->> B: INFO: Alice's info - BA ->> BS: ACK: confirm message - BA ->> BS: KEY: secure queue - note over BA: status: SECURED/CONFIRMED - - BA ->> AS: SEND: HELLO: only needs to be sent once in v2 - - note over BA: status: SECURED/ACTIVE - note over BA, B: 7a. notify Bob
about connection success - BA ->> B: CON: connected - - AS ->> AA: MSG: HELLO: Alice's agent
knows Bob can send - note over AA: status: SECURED/ACTIVE - AA ->> AS: ACK: confirm message - note over A, AA: 7a. notify Alice
about connection success - AA ->> A: CON: connected - - AA ->> BS: SEND: HELLO: only needs to be sent once in v2 - note over AA: status: ACTIVE/ACTIVE - BS ->> BA: MSG: HELLO: Bob's agent
knows Alice can send - note over BA: status: ACTIVE/ACTIVE - BA ->> BS: ACK: confirm message diff --git a/protocol/diagrams/duplex-messaging/duplex-creating.mmd b/protocol/diagrams/duplex-messaging/duplex-creating.mmd index 738bad325..5cddf6aa4 100644 --- a/protocol/diagrams/duplex-messaging/duplex-creating.mmd +++ b/protocol/diagrams/duplex-messaging/duplex-creating.mmd @@ -8,8 +8,8 @@ sequenceDiagram note over AA, BA: status (receive/send): NONE/NONE - note over A, AA: 1. request connection from agent - A ->> AA: NEW: create
duplex connection + note over A, AA: 1. request connection
from agent + A ->> AA: createConnection note over AA, AS: 2. create Alice's SMP queue AA ->> AS: NEW: create SMP queue @@ -17,63 +17,58 @@ sequenceDiagram note over AA: status: NEW/NONE AA ->> A: INV: invitation
to connect - note over AA: status: PENDING/NONE note over A, B: 3. out-of-band invitation A ->> B: OOB: invitation to connect note over BA, B: 4. accept connection - B ->> BA: JOIN:
via invitation info + B ->> BA: joinConnection:
via invitation info note over BA: status: NONE/NEW - note over BA, AA: 5. establish Alice's SMP queue - BA ->> AS: SEND: Bob's info and sender server key (SMP confirmation) - note over BA: status: NONE/CONFIRMED - activate BA + note over BA, BS: 5. create Bob's SMP queue + BA ->> BS: NEW: create SMP queue + BS ->> BA: IDS: SMP queue IDs + note over BA: status: NEW/NEW + + note over BA, AA: 6. confirm Alice's SMP queue + BA ->> AS: SEND: Bob's info and sender server key (SMP confirmation with reply queues) + note over BA: status: NEW/CONFIRMED + AS ->> AA: MSG: Bob's info and
sender server key note over AA: status: CONFIRMED/NONE AA ->> AS: ACK: confirm message AA ->> A: CONF: connection request ID
and Bob's info - A ->> AA: LET: accept connection request,
send Alice's info + A ->> AA: allowConnection: accept connection request,
send Alice's info AA ->> AS: KEY: secure queue note over AA: status: SECURED/NONE - BA ->> AS: SEND: HELLO: try sending until successful - deactivate BA - note over BA: status: NONE/ACTIVE - AS ->> AA: MSG: HELLO: Alice's agent
knows Bob can send - note over AA: status: ACTIVE/NONE - AA ->> AS: ACK: confirm message + AA ->> BS: SEND: Alice's info and sender's server key (SMP confirmation without reply queues) + note over AA: status: SECURED/CONFIRMED - note over BA, BS: 6. create Bob's SMP queue - BA ->> BS: NEW: create SMP queue - BS ->> BA: IDS: SMP queue IDs - note over BA: status: NEW/ACTIVE - - note over AA, BA: 7. establish Bob's SMP queue - BA ->> AS: SEND: REPLY: invitation to the connect - note over BA: status: PENDING/ACTIVE - AS ->> AA: MSG: REPLY: invitation
to connect - note over AA: status: ACTIVE/NEW - AA ->> AS: ACK: confirm message - - AA ->> BS: SEND: Alice's info and sender's server key - note over AA: status: ACTIVE/CONFIRMED - activate AA + note over BA, AA: 7. confirm Bob's SMP queue BS ->> BA: MSG: Alice's info and
sender's server key - note over BA: status: CONFIRMED/ACTIVE + note over BA: status: CONFIRMED/CONFIRMED BA ->> B: INFO: Alice's info BA ->> BS: ACK: confirm message BA ->> BS: KEY: secure queue + note over BA: status: SECURED/CONFIRMED + + BA ->> AS: SEND: HELLO message + note over BA: status: SECURED/ACTIVE - AA ->> BS: SEND: HELLO: try sending until successful - deactivate AA + AS ->> AA: MSG: HELLO: Alice's agent
knows Bob can send + note over AA: status: SECURED/ACTIVE + AA ->> AS: ACK: confirm message + AA ->> BS: SEND: HELLO + + note over A, AA: 8. notify Alice
about connection success + AA ->> A: CON: connected note over AA: status: ACTIVE/ACTIVE + BS ->> BA: MSG: HELLO: Bob's agent
knows Alice can send note over BA: status: ACTIVE/ACTIVE BA ->> BS: ACK: confirm message - note over A, B: 8. notify users about connection success - AA ->> A: CON: connected + note over BA, B: 9. notify Bob
about connection success BA ->> B: CON: connected diff --git a/protocol/diagrams/duplex-messaging/duplex-creating.svg b/protocol/diagrams/duplex-messaging/duplex-creating.svg index 138935d3b..bea3bb23d 100644 --- a/protocol/diagrams/duplex-messaging/duplex-creating.svg +++ b/protocol/diagrams/duplex-messaging/duplex-creating.svg @@ -1 +1,3 @@ -AliceAlice'sagentAlice'sserverBob'sserverBob'sagentBobstatus (receive/send): NONE/NONE1. request connection from agentNEW: createduplex connection2. create Alice's SMP queueNEW: create SMP queueIDS: SMP queue IDsstatus: NEW/NONEINV: invitationto connectstatus: PENDING/NONE3. out-of-band invitationOOB: invitation to connect4. accept connectionJOIN:via invitation infostatus: NONE/NEW5. establish Alice's SMP queueSEND: Bob's info and sender server key (SMP confirmation)status: NONE/CONFIRMEDMSG: Bob's info andsender server keystatus: CONFIRMED/NONEACK: confirm messageREQ: connection request IDand Bob's infoACPT: accept connection request,send Alice's infoKEY: secure queuestatus: SECURED/NONESEND: HELLO: try sending until successfulstatus: NONE/ACTIVEMSG: HELLO: Alice's agentknows Bob can sendstatus: ACTIVE/NONEACK: confirm message6. create Bob's SMP queueNEW: create SMP queueIDS: SMP queue IDsstatus: NEW/ACTIVE7. establish Bob's SMP queueSEND: REPLY: invitation to the connectstatus: PENDING/ACTIVEMSG: REPLY: invitationto connectstatus: ACTIVE/NEWACK: confirm messageSEND: Alice's info and sender's server keystatus: ACTIVE/CONFIRMEDMSG: Alice's info andsender's server keystatus: CONFIRMED/ACTIVEINFO: Alice's infoACK: confirm messageKEY: secure queuestatus: SECURED/ACTIVESEND: HELLO: try sending until successfulstatus: ACTIVE/ACTIVEMSG: HELLO: Bob's agentknows Alice can sendstatus: ACTIVE/ACTIVEACK: confirm message8. notify users about connection successCON: connectedCON: connectedAliceAlice'sagentAlice'sserverBob'sserverBob'sagentBob \ No newline at end of file + + +BobBob'sagentBob'sserverAlice'sserverAlice'sagentAliceBobBob'sagentBob'sserverAlice'sserverAlice'sagentAlicestatus (receive/send): NONE/NONE1. request connectionfrom agent2. create Alice's SMP queuestatus: NEW/NONE3. out-of-band invitation4. accept connectionstatus: NONE/NEW5. secure Alice's SMP queuestatus: NONE/SECURED6. create Bob's SMP queuestatus: NEW/SECURED7. confirm Alice's SMP queuestatus: NEW/CONFIRMEDstatus: CONFIRMED/NEW8. secure Bob's SMP queuestatus: CONFIRMED/SECUREDstatus: CONFIRMED/CONFIRMED9. notify Aliceabout connection success(no HELLO needed in v6)status: ACTIVE/ACTIVE10. notify Bobabout connection successstatus: CONFIRMED/CONFIRMEDstatus: ACTIVE/ACTIVEcreateConnectionNEW: create SMP queueallow sender to secureIDS: SMP queue IDsINV: invitationto connectOOB: invitation to connectjoinConnection:via invitation infoSKEY: secure queue (this command needs to be proxied)NEW: create SMP queueallow sender to secureIDS: SMP queue IDsSEND: Bob's info without sender's key (SMP confirmation with reply queues)MSG: Bob's info withoutsender server keyACK: confirm messageCONF: connection request IDand Bob's infoallowConnection: accept connection request,send Alice's infoSKEY: secure queue (this command needs to be proxied)SEND: Alice's info without sender's server key (SMP confirmation without reply queues)CON: connectedMSG: Alice's info withoutsender's server keyINFO: Alice's infoACK: confirm messageCON: connected \ No newline at end of file diff --git a/protocol/diagrams/duplex-messaging/queue-rotation-fast.mmd b/protocol/diagrams/duplex-messaging/queue-rotation-fast.mmd new file mode 100644 index 000000000..75887dd0b --- /dev/null +++ b/protocol/diagrams/duplex-messaging/queue-rotation-fast.mmd @@ -0,0 +1,17 @@ +sequenceDiagram + participant A as Alice + participant R as Current server
that has A's
receive queue + participant R' as New server
that has the new A's
receive queue + participant S as Server
that has A's send queue
(B's receive queue) + participant B as Bob + + A ->> R': NEW: create new queue
(allow SKEY) + A ->> S: SEND: QADD (R'): send address
of the new queue(s) + S ->> B: MSG: QADD (R') + B ->> R': SKEY: secure new queue + B ->> R': SEND: QTEST + R' ->> A: MSG: QTEST + A ->> R: DEL: delete the old queue + B ->> R': SEND: send messages to the new queue + R' ->> A: MSG: receive messages from the new queue + \ No newline at end of file diff --git a/protocol/diagrams/duplex-messaging/queue-rotation-fast.svg b/protocol/diagrams/duplex-messaging/queue-rotation-fast.svg new file mode 100644 index 000000000..823074823 --- /dev/null +++ b/protocol/diagrams/duplex-messaging/queue-rotation-fast.svg @@ -0,0 +1,3 @@ + + +BobServerthat has A's send queue(B's receive queue)New serverthat has the new A'sreceive queueCurrent serverthat has A'sreceive queueAliceBobServerthat has A's send queue(B's receive queue)New serverthat has the new A'sreceive queueCurrent serverthat has A'sreceive queueAliceNEW: create new queue(allow SKEY)SEND: QADD (R'): send addressof the new queue(s)MSG: QADD (R')SKEY: secure new queueSEND: QTESTMSG: QTESTDEL: delete the old queueSEND: send messages to the new queueMSG: receive messages from the new queue \ No newline at end of file diff --git a/protocol/diagrams/duplex-messaging/queue-rotation.mmd b/protocol/diagrams/duplex-messaging/queue-rotation.mmd new file mode 100644 index 000000000..9572a2c48 --- /dev/null +++ b/protocol/diagrams/duplex-messaging/queue-rotation.mmd @@ -0,0 +1,21 @@ +sequenceDiagram + participant A as Alice + participant R as Current server
that has A's
receive queue + participant R' as New server
that has the new A's
receive queue + participant S as Server
that has A's send queue
(B's receive queue) + participant B as Bob + + A ->> R': NEW: create new queue + A ->> S: SEND: QADD (R'): send address
of the new queue(s) + S ->> B: MSG: QADD (R') + B ->> R: SEND: QKEY (R'): sender's key
for the new queue(s) + R ->> A: MSG: QKEY(R') + A ->> R': KEY: secure new queue + A ->> S: SEND: QUSE (R'): instruction to use new queue(s) + S ->> B: MSG: QUSE (R') + B ->> R': SEND: QTEST + R' ->> A: MSG: QTEST + A ->> R: DEL: delete the old queue + B ->> R': SEND: send messages to the new queue + R' ->> A: MSG: receive messages from the new queue + \ No newline at end of file diff --git a/protocol/diagrams/duplex-messaging/queue-rotation.svg b/protocol/diagrams/duplex-messaging/queue-rotation.svg new file mode 100644 index 000000000..d477cd622 --- /dev/null +++ b/protocol/diagrams/duplex-messaging/queue-rotation.svg @@ -0,0 +1,3 @@ + + +BobServerthat has A's send queue(B's receive queue)New serverthat has the new A'sreceive queueCurrent serverthat has A'sreceive queueAliceBobServerthat has A's send queue(B's receive queue)New serverthat has the new A'sreceive queueCurrent serverthat has A'sreceive queueAliceNEW: create new queueSEND: QADD (R'): send addressof the new queue(s)MSG: QADD (R')SEND: QKEY (R'): sender's keyfor the new queue(s)MSG: QKEY(R')KEY: secure new queueSEND: QUSE (R'): instruction to use new queue(s)MSG: QUSE (R')SEND: QTESTMSG: QTESTDEL: delete the old queueSEND: send messages to the new queueMSG: receive messages from the new queue \ No newline at end of file diff --git a/protocol/diagrams/notifications/register-token-detailed.mmd b/protocol/diagrams/notifications/register-token-detailed.mmd new file mode 100644 index 000000000..bceef296f --- /dev/null +++ b/protocol/diagrams/notifications/register-token-detailed.mmd @@ -0,0 +1,30 @@ +sequenceDiagram + participant M as mobile app + participant C as chat core + participant A as agent + participant P as push server + participant APN as APN + + note over M, APN: get device token + M ->> APN: registerForRemoteNotifications() + APN ->> M: device token + + note over M, P: register device token with push server + M ->> C: /_ntf register + C ->> A: registerNtfToken() + A ->> P: TNEW + P ->> A: ID (tokenId) + A ->> C: registered + C ->> M: registered + + note over M, APN: verify device token + P ->> APN: E2E encrypted code
in background
notification + APN ->> M: deliver background notification with e2ee verification token + M ->> C: /_ntf verify + C ->> A: verifyNtfToken() + A ->> P: TVFY code + P ->> A: OK / ERR + A ->> C: verified + C ->> M: verified + + note over M, APN: now token ID can be used diff --git a/protocol/diagrams/notifications/register-token.mmd b/protocol/diagrams/notifications/register-token.mmd index bceef296f..caa05d716 100644 --- a/protocol/diagrams/notifications/register-token.mmd +++ b/protocol/diagrams/notifications/register-token.mmd @@ -1,30 +1,26 @@ sequenceDiagram - participant M as mobile app - participant C as chat core + participant C as client app participant A as agent - participant P as push server - participant APN as APN + participant P as SimpleX
Notification
Server + participant APN as Apple
Push Notifications
Server - note over M, APN: get device token - M ->> APN: registerForRemoteNotifications() - APN ->> M: device token + note over C, APN: get device token + C ->> APN: registerForRemoteNotifications() + APN ->> C: device token - note over M, P: register device token with push server - M ->> C: /_ntf register - C ->> A: registerNtfToken() + note over C, P: register device token with push server + C ->> A: registerToken A ->> P: TNEW P ->> A: ID (tokenId) A ->> C: registered - C ->> M: registered - note over M, APN: verify device token + note over C, APN: verify device token P ->> APN: E2E encrypted code
in background
notification - APN ->> M: deliver background notification with e2ee verification token - M ->> C: /_ntf verify - C ->> A: verifyNtfToken() + APN ->> C: deliver background notification with e2ee verification token + C ->> A: verifyToken
() A ->> P: TVFY code P ->> A: OK / ERR A ->> C: verified - C ->> M: verified - note over M, APN: now token ID can be used + note over C, APN: now token ID can be used + \ No newline at end of file diff --git a/protocol/diagrams/notifications/register-token.svg b/protocol/diagrams/notifications/register-token.svg new file mode 100644 index 000000000..662a185da --- /dev/null +++ b/protocol/diagrams/notifications/register-token.svg @@ -0,0 +1,3 @@ + + +ApplePush NotificationsServerSimpleXNotificationServeragentclient appApplePush NotificationsServerSimpleXNotificationServeragentclient appget device tokenregister device token with push serververify device tokennow token ID can be usedregisterForRemoteNotifications()device tokenregisterTokenTNEWID (tokenId)registeredE2E encrypted codein backgroundnotificationdeliver background notification with e2ee verification tokenverifyToken(<e2ee code>)TVFY codeOK / ERRverified \ No newline at end of file diff --git a/protocol/diagrams/notifications/subscription-detailed.mmd b/protocol/diagrams/notifications/subscription-detailed.mmd new file mode 100644 index 000000000..0db7cd7cc --- /dev/null +++ b/protocol/diagrams/notifications/subscription-detailed.mmd @@ -0,0 +1,40 @@ +sequenceDiagram + participant M as mobile app + participant C as chat core + participant A as agent + participant S as SMP server + participant N as NTF server + participant APN as APN + + note over M, APN: register subscription + + alt register existing + M -->> A: on /_ntf register, for subscribed queues + else create new connection + A -->> S: NEW / JOIN + note over A, S: ...
Connection handshake
... + S -->> A: CON + end + A ->> S: NKEY nKey + S ->> A: NID nId + A ->> N: SNEW tknId dhKey (smpServer, nId, nKey) + N ->> A: ID subId dhKey + N ->> S: NSUB nId + S ->> N: OK [/ NMSG] + + note over M, APN: notify about message + + S ->> N: NMSG + N ->> APN: APNSMutableContent
ntfQueue, nonce + APN ->> M: UNMutableNotificationContent + note over M, S: ...
Client awaken, message is received
... + S ->> M: message + note over M: mutate notification + + note over M, APN: change APN token + + APN ->> M: new device token + M -->> C: /_ntf_sub update tkn + C -->> A: updateNtfToken() + A -->> N: TUPD tknId newDeviceToken + note over M, N: ...
Verify token
... diff --git a/protocol/diagrams/notifications/subscription.mmd b/protocol/diagrams/notifications/subscription.mmd index 0db7cd7cc..8b4db971c 100644 --- a/protocol/diagrams/notifications/subscription.mmd +++ b/protocol/diagrams/notifications/subscription.mmd @@ -1,17 +1,16 @@ sequenceDiagram - participant M as mobile app - participant C as chat core + participant C as client app participant A as agent participant S as SMP server participant N as NTF server participant APN as APN - note over M, APN: register subscription + note over C, APN: register subscription alt register existing - M -->> A: on /_ntf register, for subscribed queues + C -->> A: registerToken else create new connection - A -->> S: NEW / JOIN + A -->> S: create/joinConnection note over A, S: ...
Connection handshake
... S -->> A: CON end @@ -20,21 +19,20 @@ sequenceDiagram A ->> N: SNEW tknId dhKey (smpServer, nId, nKey) N ->> A: ID subId dhKey N ->> S: NSUB nId - S ->> N: OK [/ NMSG] + S ->> N: OK / NMSG:
confirm subscription - note over M, APN: notify about message + note over C, APN: notify about message S ->> N: NMSG N ->> APN: APNSMutableContent
ntfQueue, nonce - APN ->> M: UNMutableNotificationContent - note over M, S: ...
Client awaken, message is received
... - S ->> M: message - note over M: mutate notification + APN ->> C: UNMutableNotificationContent + note over C, S: ...
Client awaken, message is received
... + S ->> C: message + note over C: show notification - note over M, APN: change APN token + note over C, APN: change APN token - APN ->> M: new device token - M -->> C: /_ntf_sub update tkn - C -->> A: updateNtfToken() + APN ->> C: new device token + C -->> A: updateToken() A -->> N: TUPD tknId newDeviceToken - note over M, N: ...
Verify token
... + note over C, N: ...
Verify token
... diff --git a/protocol/diagrams/notifications/subscription.svg b/protocol/diagrams/notifications/subscription.svg new file mode 100644 index 000000000..49840ce58 --- /dev/null +++ b/protocol/diagrams/notifications/subscription.svg @@ -0,0 +1,3 @@ + + +APNNTF serverSMP serveragentclient appAPNNTF serverSMP serveragentclient appregister subscription...Connection handshake...alt[register existing][create new connection]notify about message...Client awaken, message is received...show notificationchange APN token...Verify token...registerTokencreate/joinConnectionCONNKEY nKeyNID nIdSNEW tknId dhKey (smpServer, nId, nKey)ID subId dhKeyNSUB nIdOK / NMSG:confirm subscriptionNMSGAPNSMutableContentntfQueue, nonceUNMutableNotificationContentmessagenew device tokenupdateToken()TUPD tknId newDeviceToken \ No newline at end of file diff --git a/protocol/diagrams/simplex-messaging/simplex-creating-fast.mmd b/protocol/diagrams/simplex-messaging/simplex-creating-fast.mmd new file mode 100644 index 000000000..48a59988d --- /dev/null +++ b/protocol/diagrams/simplex-messaging/simplex-creating-fast.mmd @@ -0,0 +1,23 @@ +sequenceDiagram + participant B as Bob (sender) + participant S as server (queue RID) + participant A as Alice (recipient) + + note over A: creating queue
("public" key RK
for msg retrieval) + A ->> S: 1. create queue ("NEW") + S ->> A: respond with queue RID and SID ("IDS") + + note over A: out-of-band msg
(sender's queue SID
and "public" key EK
to encrypt msgs) + A -->> B: 2. send out-of-band message + + note over B: secure queue
(with "public" key SK for
sending messages) + B ->> S: 3. confirm queue ("SKEY" command authorized with SK) + + note over B: confirm queue
(public key
for e2e encryption
and any optional
encrypted info.) + B ->> S: 4. confirm queue ("SEND" command authorized with SK) + + S ->> A: 5. deliver Bob's message (MSG) + note over A: decrypt message
("private" key EK) + A ->> S: acknowledge message (ACK) + + note over S: 6. simplex
queue RID
is ready to use! diff --git a/protocol/diagrams/simplex-messaging/simplex-creating-fast.svg b/protocol/diagrams/simplex-messaging/simplex-creating-fast.svg new file mode 100644 index 000000000..37337435f --- /dev/null +++ b/protocol/diagrams/simplex-messaging/simplex-creating-fast.svg @@ -0,0 +1,3 @@ + + +Alice (recipient)server (queue RID)Bob (sender)Alice (recipient)server (queue RID)Bob (sender)creating queue("public" key RKfor msg retrieval)out-of-band msg(sender's queue SIDand "public" key EKto encrypt msgs)secure queue(with "public" key SK forsending messages)confirm queue(public keyfor e2e encryptionand any optionalencrypted info.)decrypt message("private" key EK)6. simplexqueue RIDis ready to use!1. create queue ("NEW")respond with queue RID and SID ("IDS")2. send out-of-band message3. confirm queue ("SKEY" command authorized with SK)4. confirm queue ("SEND" command authorized with SK)5. deliver Bob's message (MSG)acknowledge message (ACK) \ No newline at end of file diff --git a/protocol/diagrams/simplex-messaging/simplex-creating.mmd b/protocol/diagrams/simplex-messaging/simplex-creating.mmd index 5116c3bed..f38c174e8 100644 --- a/protocol/diagrams/simplex-messaging/simplex-creating.mmd +++ b/protocol/diagrams/simplex-messaging/simplex-creating.mmd @@ -10,11 +10,13 @@ sequenceDiagram note over A: out-of-band msg
(sender's queue SID
and "public" key EK
to encrypt msgs) A -->> B: 2. send out-of-band message - note over B: confirm queue
("public" key SK for
sending messages
and any optional
info encrypted with
"public" key EK) + note over B: confirm queue
("public" key SK for
sending messages,
public key for
e2e encryption
and any optional
encrypted info) B ->> S: 3. confirm queue ("SEND" command not signed) - S ->> A: 4. deliver Bob's message + S ->> A: 4. deliver Bob's message (MSG) note over A: decrypt message
("private" key EK) + A ->> S: acknowledge message (ACK) + A ->> S: 5. secure queue ("KEY", RK-signed) note over S: 6. simplex
queue RID
is ready to use! diff --git a/protocol/diagrams/simplex-messaging/simplex-creating.svg b/protocol/diagrams/simplex-messaging/simplex-creating.svg index 325fbb6cf..33dd288b3 100644 --- a/protocol/diagrams/simplex-messaging/simplex-creating.svg +++ b/protocol/diagrams/simplex-messaging/simplex-creating.svg @@ -1 +1,3 @@ -Bob (sender)server (queue RID)Alice (recipient)creating queue("public" key RKfor msg retrieval)1. create queue ("NEW")respond with queue RID and SID ("IDS")out-of-band msg(sender's queue SIDand "public" key EKto encrypt msgs)2. send out-of-band messageconfirm queue("public" key SK forsending messagesand any optionalinfo encrypted with"public" key EK)3. confirm queue ("SEND" command not signed)4. deliver Bob's messagedecrypt message("private" key EK)5. secure queue ("KEY", RK-signed)6. simplexqueue RIDis ready to use!Bob (sender)server (queue RID)Alice (recipient) \ No newline at end of file + + +Alice (recipient)server (queue RID)Bob (sender)Alice (recipient)server (queue RID)Bob (sender)creating queue("public" key RKfor msg retrieval)out-of-band msg(sender's queue SIDand "public" key EKto encrypt msgs)confirm queue("public" key SK forsending messages,public key fore2e encryptionand any optionalencrypted info)decrypt message("private" key EK)6. simplexqueue RIDis ready to use!1. create queue ("NEW")respond with queue RID and SID ("IDS")2. send out-of-band message3. confirm queue ("SEND" command not signed)4. deliver Bob's message (MSG)acknowledge message (ACK)5. secure queue ("KEY", RK-signed) \ No newline at end of file diff --git a/protocol/diagrams/xftp/xftp-receiving-file.mmd b/protocol/diagrams/xftp/xftp-receiving-file.mmd new file mode 100644 index 000000000..d1944368b --- /dev/null +++ b/protocol/diagrams/xftp/xftp-receiving-file.mmd @@ -0,0 +1,18 @@ +sequenceDiagram + participant B as Bob (recipient) + participant S as XFTP server(s) + + note over B: having received file description
from sender + + loop for each chunk + B ->> S: 1a. download chunk ("FGET") + S ->> B: send chunk body ("FILE") + + opt + B ->> S: 1b. acknowledge chunk reception ("FACK") + note over S: delete recipient ID + S ->> B: respond with ok ("OK") + end + end + + note over B: 2. combine chunks into a file
3. decrypt file using key from file description
4. extract file name and unpad the file
5. validate file digest with the file description diff --git a/protocol/diagrams/xftp/xftp-receiving-file.svg b/protocol/diagrams/xftp/xftp-receiving-file.svg new file mode 100644 index 000000000..aceeb653d --- /dev/null +++ b/protocol/diagrams/xftp/xftp-receiving-file.svg @@ -0,0 +1,3 @@ + + +XFTP server(s)Bob (recipient)XFTP server(s)Bob (recipient)having received file descriptionfrom senderdelete recipient IDopt​loop[for each chunk]2. combine chunks into a file3. decrypt file using key from file description4. extract file name and unpad the file5. validate file digest with the file description1a. download chunk ("FGET")send chunk body ("FILE")1b. acknowledge chunk reception ("FACK")respond with ok ("OK") \ No newline at end of file diff --git a/protocol/diagrams/xftp/xftp-sending-file.mmd b/protocol/diagrams/xftp/xftp-sending-file.mmd new file mode 100644 index 000000000..8e0b58498 --- /dev/null +++ b/protocol/diagrams/xftp/xftp-sending-file.mmd @@ -0,0 +1,23 @@ +sequenceDiagram + participant A as Alice (sender) + participant S as XFTP server(s) + participant B as recipient(s) + + note over A: 1. prepare file:
encrypt,
split into chunks,
generate recipient
keys, etc. + + loop for each chunk + A ->> S: 2a. register chunk ("FNEW") + S ->> A: respond with sender's and recipients' chunk IDs ("SIDS") + + opt + A ->> S: 2b. request additional recipient IDs ("FADD") + S ->> A: respond with added recipients' chunk IDs ("RIDS") + end + + A ->> S: 2c. upload chunk to chosen server ("FPUT") + S ->> A: respond with ok ("OK") + end + + note over A: 3. prepare file description(s) + + A -->> B: 4. send file description(s) out-of-band diff --git a/protocol/diagrams/xftp/xftp-sending-file.svg b/protocol/diagrams/xftp/xftp-sending-file.svg new file mode 100644 index 000000000..c3df658f5 --- /dev/null +++ b/protocol/diagrams/xftp/xftp-sending-file.svg @@ -0,0 +1,3 @@ + + +recipient(s)XFTP server(s)Alice (sender)recipient(s)XFTP server(s)Alice (sender)1. prepare file:encrypt,split into chunks,generate recipientkeys, etc.opt​loop[for each chunk]3. prepare file description(s)2a. register chunk ("FNEW")respond with sender's and recipients' chunk IDs ("SIDS")2b. request additional recipient IDs ("FADD")respond with added recipients' chunk IDs ("RIDS")2c. upload chunk to chosen server ("FPUT")respond with ok ("OK")4. send file description(s) out-of-band \ No newline at end of file diff --git a/protocol/diagrams/xrcp/session.mmd b/protocol/diagrams/xrcp/session.mmd new file mode 100644 index 000000000..2e98fbb1b --- /dev/null +++ b/protocol/diagrams/xrcp/session.mmd @@ -0,0 +1,44 @@ +sequenceDiagram + participant CI as Controller UI + participant CC as Controller Core + participant HC as Host Core + participant HI as Host UI + +note over CI, HI: 1. Session invitation +CI->>CC: "Link a mobile" +CC-->>CI: Session invitation URI +note over CC: Listen for TCP connection +activate CC +HI->>HC: Session invitation URI + +note over CI, HI: 2. Establishing TLS connection +HC-->>CC: TCP connect +note over CC, HC: TLS handshake +par + note over CC: validate client X509 credentials + CC->>CI: session code from tlsUnique + CI-->>CC: user confirmation +and + note over HC: validate server X509 credentials + HC->>HI: session code from tlsUnique + HI-->>HC: user confirmation +end + +note over CI, HI: 3. Session verification and protocol negotiation +HC->>CC: host HELLO +note over CC: validate version, CA fingerprint +alt + CC-->>HC: controller ERROR +else + CC-->>HC: controller HELLO + note over CC, HC: update stored keys +end +deactivate CC + +note over CI, HI: 4. Session operation +loop + CI->>CC: command + CC->>HC: XRCP command + HC-->>CC: XRCP response + CC-->>CI: response +end diff --git a/protocol/diagrams/xrcp/session.svg b/protocol/diagrams/xrcp/session.svg new file mode 100644 index 000000000..136b56fc6 --- /dev/null +++ b/protocol/diagrams/xrcp/session.svg @@ -0,0 +1 @@ +Host UIHost CoreController CoreController UIHost UIHost CoreController CoreController UI1. Session invitationListen for TCP connection2. Establishing TLS connectionTLS handshakevalidate client X509 credentialsvalidate server X509 credentialspar​3. Session verification and protocol negotiationvalidate version, CA fingerprintupdate stored keysalt​4. Session operationloop​"Link a mobile"Session invitation URISession invitation URITCP connectsession code from tlsUniqueuser confirmationsession code from tlsUniqueuser confirmationhost HELLOcontroller ERRORcontroller HELLOcommandXRCP commandXRCP responseresponse \ No newline at end of file diff --git a/protocol/overview-tjr.md b/protocol/overview-tjr.md index 7f1e72768..d30f55235 100644 --- a/protocol/overview-tjr.md +++ b/protocol/overview-tjr.md @@ -1,4 +1,4 @@ -Revision 1, 2022-01-01 +Revision 2, 2024-06-22 Evgeny Poberezkin @@ -13,19 +13,23 @@ Evgeny Poberezkin - [Technical Details](#technical-details) - [Trust in Servers](#trust-in-servers) - [Client -> Server Communication](#client---server-communication) + - [2-hop Onion Message Routing](#2-hop-onion-message-routing) - [SimpleX Messaging Protocol](#simplex-messaging-protocol) - [SimpleX Agents](#simplex-agents) - [Encryption Primitives Used](#encryption-primitives-used) - [Threat model](#threat-model) - [Acknowledgements](#acknowledgements) + ## Introduction #### What is SimpleX SimpleX as a whole is a platform upon which applications can be built. [SimpleX Chat](https://github.com/simplex-chat/simplex-chat) is one such application that also serves as an example and reference application. - - [SimpleX Messaging Protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) (SMP) is a protocol to send messages in one direction to a recipient, relying on a server in-between. The messages are delivered via uni-directional queues created by recipients. + - [SimpleX Messaging Protocol](./simplex-messaging.md) (SMP) is a protocol to send messages in one direction to a recipient, relying on a server in-between. The messages are delivered via uni-directional queues created by recipients. + + - SMP protocol allows to send message via a SMP server playing proxy role using 2-hop onion routing (referred to as "private routing" in messaging clients) to protect transport information of the sender (IP address and session) from the server chosen (and possibly controlled) by the recipient. - SMP runs over a transport protocol (shown below as TLS) that provides integrity, server authentication, confidentiality, and transport channel binding. @@ -35,7 +39,9 @@ SimpleX as a whole is a platform upon which applications can be built. [SimpleX - SimpleX Client libraries speak SMP to SimpleX Servers and provide a low-level API not generally intended to be used by applications. - - SimpleX Agents interface with SimpleX Clients to provide a more high-level API intended to be used by applications. Typically they are embedded as libraries, but are designed so they can also be abstracted into local services. + - SimpleX Agents interface with SimpleX Clients to provide a more high-level API intended to be used by applications. Typically they are embedded as libraries, but can also be abstracted into local services. + + - SimpleX Agents communicate with other agents inside e2e encrypted envelopes provided by SMP protocol - the syntax and semantics of the messages exchanged by the agent are defined by [SMP agent protocol](./agent-protocol.md) *Diagram showing the SimpleX Chat app, with logical layers of the chat application interfacing with a SimpleX Agent library, which in turn interfaces with a SimpleX Client library. The Client library in turn speaks the Messaging Protocol to a SimpleX Server.* @@ -72,10 +78,11 @@ SimpleX as a whole is a platform upon which applications can be built. [SimpleX - Low latency: the delay introduced by the network should not be higher than 100ms-1s in addition to the underlying TCP network latency. -2. Provide better communication security and privacy than the alternative instant messaging solutions. In particular SimpleX provides better privacy of metadata (who talks to whom and when) and better security against active network attackers and malicious servers. +2. Provide better communication security and privacy than the alternative instant messaging solutions. In particular SimpleX provides better privacy of metadata (who talks to whom and when) and better security against active network attackers and malicious servers. 3. Balance user experience with privacy requirements, prioritizing experience of mobile device users. + #### In Comparison SimpleX network has a design similar to P2P networks, but unlike most P2P networks it consists of clients and servers without depending on any centralized component. @@ -91,53 +98,73 @@ In comparison to more traditional messaging applications (e.g. WhatsApp, Signal, - users can change servers with minimal disruption - even after an in-use server disappears, simply by changing the configuration on which servers the new queues are created. + ## Technical Details #### Trust in Servers Clients communicate directly with servers (but not with other clients) using SimpleX Messaging Protocol (SMP) running over some transport protocol that provides integrity, server authentication, confidentiality, and transport channel binding. By default, we assume this transport protocol is TLS. -Users use multiple servers, and choose where to receive their messages. Accordingly, they send messages to their communication partners' chosen servers. +Users use multiple servers, and choose where to receive their messages. Accordingly, they send messages to their communication partners' chosen servers either directly, if this is a known/trusted server, or via another SMP server providing proxy functionality to protect IP address and session of the sender. -Although end-to-end encryption is always present, users place a degree of trust in servers. This trust decision is very similar to a user's choice of email provider; however the trust placed in a SimpleX server is significantly less. Notably, there is no re-used identifier or credential between queues on the same (or different) servers. While a user *may* re-use a connection to fetch from multiple queues, or connect to a server from the same IP address, both are choices a user may opt into to break the promise of un-correlatable queues. +Although end-to-end encryption is always present, users place a degree of trust in servers they connect to. This trust decision is very similar to a user's choice of email provider; however the trust placed in a SimpleX server is significantly less. Notably, there is no re-used identifier or credential between queues on the same (or different) servers. While a user *may* re-use a transport connection to fetch messages from multiple queues, or connect to a server from the same IP address, both are choices a user may opt into to break the promise of un-correlatable queues. Users may trust a server because: -- They deploy and control the servers themselves from the available open-source code. This has the trade-offs of strong trust in the server but limited metadata obfuscation to a passive network observer. Techniques such as noise traffic, traffic mixing (incurring latency), and using an onion routing transport protocol can mitigate that latter. +- They deploy and control the servers themselves from the available open-source code. This has the trade-offs of strong trust in the server but limited metadata obfuscation to a passive network observer. Techniques such as noise traffic, traffic mixing (incurring latency), and using an onion routing transport protocol can mitigate that. - They use servers from a trusted commercial provider. The more clients the provider has, the less metadata about the communication times is leaked to the network observers. -- Users trust their contacts and the servers they chose. +By default, servers do not retain access logs, and permanently delete messages and queues when requested. Messages persist only in memory until they cross a threshold of time, typically on the order of days.[0] There is still a risk that a server maliciously records all queues and messages (even though encrypted) sent via the same transport connection to gain a partial knowledge of the user’s communications graph and other meta-data. -By default, servers do not retain access logs, and permanently delete messages and queues when requested. Messages persist only in memory until they cross a threshold of time, typically on the order of days.[0] There is still a risk that a server maliciously records all queues and messages (even though encrypted) sent via the same transport connection to gain a partial knowledge of the user’s communications graph and other meta-data. +SimpleX supports measures (managed transparently to the user at the agent level) to mitigate the trust placed in servers. These include rotating the queues in use between users, noise traffic, supporting overlay networks such as Tor, and isolating traffic to different queues to different transport connections (and Tor circuits, if Tor is used). -SimpleX supports measures (managed transparently to the user at the agent level) to mitigate the trust placed in servers. These include rotating the queues in use between users, noise traffic, and supporting overlay networks such as Tor. - -[0] While configurable by servers, a minimum value is enforced by the default software. SimpleX Agents provide redundant routing over queues to mitigate against message loss. +[0] While configurable by servers, a minimum value is enforced by the default software. SimpleX Agents can provide redundant routing over queues to mitigate against message loss. #### Client -> Server Communication Utilizing TLS grants the SimpleX Messaging Protocol (SMP) server authentication and metadata protection to a passive network observer. But SMP does not rely on the transport protocol for message confidentiality or client authentication. The SMP protocol itself provides end-to-end confidentiality, authentication, and integrity of messages between communicating parties. -Servers have long-lived, self-signed, offline certificates whose hash is pre-shared with clients over secure channels - either provided with the client library or provided in the secure introduction between clients. The offline certificate signs an online certificate used in the transport protocol handshake. [0] +Servers have long-lived, self-signed, offline certificates whose hash is pre-shared with clients over secure channels - either provided with the client library or provided in the secure introduction between clients, as part of the server address. The offline certificate signs an online certificate used in the transport protocol handshake. [0] If the transport protocol's confidentiality is broken, incoming and outgoing messages to the server cannot be correlated by message contents. Additionally, because of encryption at the SMP layer, impersonating the server is not sufficient to pass (and therefore correlate) a message from a sender to recipient - the only attack possible is to drop the messages. Only by additionally *compromising* the server can one pass and correlate messages. It's important to note that the SMP protocol does not do server authentication. Instead we rely upon the fact that an attacker who tricks the transport protocol into authenticating the server incorrectly cannot do anything with the SMP messages except drop them. -After the connection is established, the client sends blocks of a fixed size 16Kb, and the server replies with the blocks of the same size to reduce metadata observable to a network adversary. The protocol has been designed to make traffic correlation attacks difficult, adapting ideas from Tor, remailers, and more general onion and mix networks. It does not try to replace Tor though - SimpleX servers can be deployed as onion services and SimpleX clients can communicate with servers over Tor to further improve participants privacy. +After the connection is established, the client sends blocks of a fixed size 16KB, and the server replies with the blocks of the same size to reduce metadata observable to a network adversary. The protocol has been designed to make traffic correlation attacks difficult, adapting ideas from Tor, remailers, and more general onion and mix networks. It does not try to replace Tor though - SimpleX servers can be deployed as onion services and SimpleX clients can communicate with servers over Tor to further improve participants privacy. -By using fixed-size blocks, oversized for the expected content, the vast majority of traffic is uniform in nature. When enough traffic is transiting a server simultaneously, the server acts as a (very) low-latency mix node. We can't rely on this behavior to make a security claim, but we have engineered to take advantage of it when we can. As mentioned, this holds true even if the transport connection is compromised. +By using fixed-size blocks, oversized for the expected content, the vast majority of traffic is uniform in nature. When enough traffic is transiting a server simultaneously, the server acts as a low-latency mix node. We can't rely on this behavior to make a security claim, but we have engineered to take advantage of it when we can. As mentioned, this holds true even if the transport connection is compromised. -The protocol does not protect against attacks targeted at particular users with known identities - e.g., if the attacker wants to prove that two known users are communicating, they can achieve it. At the same time, it substantially complicates large-scale traffic correlation, making determining the real user identities much less effective. +The protocol does not protect against attacks targeted at particular users with known identities - e.g., if the attacker wants to prove that two known users are communicating, they can achieve it by observing their local traffic. At the same time, it substantially complicates large-scale traffic correlation, making determining the real user identities much less effective. [0] Future versions of SMP may add support for revocation lists of certificates, presently this risk is mitigated by the SMP protocol itself. +#### 2-hop Onion Message Routing + +As SimpleX Messaging Protocol servers providing messaging queues are chosen by the recipients, in case senders connect to these servers directly the server owners (who potentially can be the recipients themselves) can learn senders' IP addresses (if Tor is not used) and which other queues on the same server are accessed by the user in the same transport connection (even if Tor is used). + +While the clients support isolating the messages sent to different queues into different transport connections (and Tor circuits), this is not practical, as it consumes additional traffic and system resources. + +To mitigate this problem SimpleX Messaging Protocol servers support 2-hop onion message routing when the SMP server chosen by the sender forwards the messages to the servers chosen by the recipients, thus protecting both the senders IP addresses and sessions, even if connection isolation and Tor are not used. + +The design of 2-hop onion message routing prevents these potential attacks: + +- MITM by proxy (SMP server that forwards the messages). + +- Identification by the proxy which and how many queues the sender sends messages to (as messages are additionally e2e encrypted between the sender and the destination SMP server). + +- Correlation of messages sent to different queues via the same user session (as random correlation IDs and keys are used for each message). + +See more details about 2-hop onion message routing design in [SimpleX Messaging Protocol](./simplex-messaging.md#proxying-sender-commands) + +Also see [Threat model](#threat-model) + + #### SimpleX Messaging Protocol -SMP is initialized with an in-person or out-of-band introduction message, where Alice provides Bob with details of a server (including IP, port, and hash of the long-lived offline certificate), a queue ID, and Alice's public key for her receiving queue. These introductions are similar to the PANDA key-exchange, in that if observed, the adversary can race to establish the communication channel instead of the intended participant. [0] +SMP is initialized with an in-person or out-of-band introduction message, where Alice provides Bob with details of a server (including IP address or host name, port, and hash of the long-lived offline certificate), a queue ID, and Alice's public keys to agree e2e encryption. These introductions are similar to the PANDA key-exchange, in that if observed, the adversary can race to establish the communication channel instead of the intended participant. [0] Because queues are uni-directional, Bob provides an identically-formatted introduction message to Alice over Alice's now-established receiving queue. @@ -145,6 +172,7 @@ When setting up a queue, the server will create separate sender and recipient qu [0] Users can additionally create public 'contact queues' that are only used to receive connection requests. + #### SimpleX Agents SimpleX agents provide higher-level operations compared to SimpleX Clients, who are primarily concerned with creating queues and communicating with servers using SMP. Agent operations include: @@ -157,9 +185,10 @@ SimpleX agents provide higher-level operations compared to SimpleX Clients, who - Noise traffic + #### Encryption Primitives Used -- Ed448 to sign/verify commands to SMP servers (Ed25519 is also supported via client/server configuration). +- Ed25519 or Curve25519 to authorize/verify commands to SMP servers (authorization algorithm is set via client/server configuration). - Curve25519 for DH exchange to agree: - the shared secret between server and recipient (to encrypt message bodies - it avoids shared cipher-text in sender and recipient traffic) - the shared secret between sender and recipient (to encrypt messages end-to-end in each queue - it avoids shared cipher-text in redundant queues). @@ -170,42 +199,44 @@ SimpleX agents provide higher-level operations compared to SimpleX Clients, who - AES-GCM AEAD cipher, - SHA512-based HKDF for key derivation. + ## Threat Model #### Global Assumptions - - A user protects their local database and key material - - The user's application is authentic, and no local malware is running - - The cryptographic primitives in use are not broken + - A user protects their local database and key material. + - The user's application is authentic, and no local malware is running. + - The cryptographic primitives in use are not broken. - A user's choice of servers is not directly tied to their identity or otherwise represents distinguishing information about the user. + - The user's client uses 2-hop onion message routing. #### A passive adversary able to monitor the traffic of one user *can:* - - identify that and when a user is using SimpleX + - identify that and when a user is using SimpleX. - - block SimpleX traffic - - - determine which servers the user communicates with + - determine which servers the user receives the messages from. - observe how much traffic is being sent, and make guesses as to its purpose. *cannot:* - - see who sends messages to the user and who the user sends the messages to + - see who sends messages to the user and who the user sends the messages to. + + - determine the servers used by users' contacts. #### A passive adversary able to monitor a set of senders and recipients *can:* - - identify who and when is using SimpleX + - identify who and when is using SimpleX. - - learn which SimpleX Messaging Protocol servers are used as receive queues for which users + - learn which SimpleX Messaging Protocol servers are used as receive queues for which users. - - learn when messages are sent and received + - learn when messages are sent and received. - - perform traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers + - perform traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers. - observe how much traffic is being sent, and make guesses as to its purpose @@ -217,43 +248,83 @@ SimpleX agents provide higher-level operations compared to SimpleX Clients, who *can:* -- learn when a queue recipient or sender is online +- learn when a queue recipient is online -- know how many messages are sent via the queue (although some may be noise) +- know how many messages are sent via the queue (although some may be noise or not content messages). -- perform queue correlation (matching multiple queues to a single user) via either a re-used transport connection, user's IP Address, or connection timing regularities +- learn which messages would trigger notifications even if a user does not use [push notifications](./push-notifications.md). -- learn a user's IP address, track them through other IP addresses they use to access the same queue, and infer information (e.g. employer) based on the IP addresses, as long as Tor is not used. +- perform the correlation of the queue used to receive messages (matching multiple queues to a single user) via either a re-used transport connection, user's IP Address, or connection timing regularities. -- drop all future messages inserted into a queue, detectable only over other, redundant queues +- learn a recipient's IP address, track them through other IP addresses they use to access the same queue, and infer information (e.g. employer) based on the IP addresses, as long as Tor is not used. + +- drop all future messages inserted into a queue, detectable only over other, redundant queues. - lie about the state of a queue to the recipient and/or to the sender (e.g. suspended or deleted when it is not). -- spam a user with invalid messages +- spam a user with invalid messages. *cannot:* -- undetectably add, duplicate, or corrupt individual messages +- undetectably add, duplicate, or corrupt individual messages. -- undetectably drop individual messages, so long as a subsequent message is delivered +- undetectably drop individual messages, so long as a subsequent message is delivered. -- learn the contents of messages +- learn the contents or type of messages. -- distinguish noise messages from regular messages except via timing regularities +- distinguish noise messages from regular messages except via timing regularities. -- compromise the user's end-to-end encryption with an active attack +- compromise the users' end-to-end encryption with an active attack. + +- learn a sender's IP address, track them through other IP addresses they use to access the same queue, and infer information (e.g. employer) based on the IP addresses, even if Tor is not used (provided messages are sent via proxy SMP server). + +- perform senders' queue correlation (matching multiple queues to a single sender) via either a re-used transport connection, user's IP Address, or connection timing regularities, unless it has additional information from the proxy SMP server (provided messages are sent via proxy SMP server). + +#### SimpleX Messaging Protocol server that proxies the messages to another SMP server + +*can:* + +- learn a sender's IP address, as long as Tor is not used. + +- learn when a sender with a given IP address is online. + +- know how many messages are sent from a given IP address and to a given destination SMP server. + +- drop all messages from a given IP address or to a given destination server. + +- unless destination SMP server detects repeated public DH keys of senders, replay messages to a destination server within a single session, causing either duplicate message delivery (which will be detected and ignored by the receiving clients), or, when receiving client is not connected to SMP server, exhausting capacity of destination queues used within the session. + +*cannot:* + +- perform queue correlation (matching multiple queues to a single user), unless it has additional information from the destination SMP server. + +- undetectably add, duplicate, or corrupt individual messages. + +- undetectably drop individual messages, so long as a subsequent message is delivered. + +- learn the contents or type of messages. + +- learn which messages would trigger notifications. + +- learn the destination queues of messages. + +- distinguish noise messages from regular messages except via timing regularities. + +- compromise the user's end-to-end encryption with another user via an active attack. + +- compromise the user's end-to-end encryption with the destination SMP servers via an active attack. #### An attacker who obtained Alice's (decrypted) chat database *can:* -- see the history of all messages exchanged by Alice with her communication partners +- see the history of all messages exchanged by Alice with her communication partners. -- see shared profiles of contacts and groups +- see shared profiles of contacts and groups. -- surreptitiously receive new messages sent to Alice via existing queues; until communication queues are rotated or the Double-Ratchet advances forward +- surreptitiously receive new messages sent to Alice via existing queues; until communication queues are rotated or the Double-Ratchet advances forward. -- prevent Alice from receiving all new messages sent to her - either surreptitiously by emptying the queues regularly or overtly by deleting them +- prevent Alice from receiving all new messages sent to her - either surreptitiously by emptying the queues regularly or overtly by deleting them. - send messages from the user to their contacts; recipients will detect it as soon as the user sends the next message, because the previous message hash won’t match (and potentially won’t be able to decrypt them in case they don’t keep the previous ratchet keys). @@ -269,41 +340,41 @@ SimpleX agents provide higher-level operations compared to SimpleX Clients, who *can:* -- spam the user with messages +- spam the user with messages. -- forever retain messages from the user +- forever retain messages from the user. *cannot:* -- cryptographically prove to a third-party that a message came from a user (assuming the user’s device is not seized) +- cryptographically prove to a third-party that a message came from a user (assuming the user’s device is not seized). -- prove that two contacts they have is the same user +- prove that two contacts they have is the same user. -- cannot collaborate with another of the user's contacts to confirm they are communicating with the same user +- cannot collaborate with another of the user's contacts to confirm they are communicating with the same user. #### An attacker who observes Alice showing an introduction message to Bob *can:* - - Impersonate Bob to Alice + - Impersonate Bob to Alice. *cannot:* - - Impersonate Alice to Bob + - Impersonate Alice to Bob. #### An attacker with Internet access *can:* -- Denial of Service SimpleX messaging servers +- Denial of Service SimpleX messaging servers. -- spam a user's public “contact queue” with connection requests +- spam a user's public “contact queue” with connection requests. *cannot:* -- send messages to a user who they are not connected with +- send messages to a user who they are not connected with. -- enumerate queues on a SimpleX server +- enumerate queues on a SimpleX server. ## Acknowledgements diff --git a/protocol/pqdr.md b/protocol/pqdr.md new file mode 100644 index 000000000..27f7082c8 --- /dev/null +++ b/protocol/pqdr.md @@ -0,0 +1,222 @@ +Version 1, 2024-06-22 + +# Post-quantum resistant augmented double ratchet algorithm (PQDR) + +## Table of contents + +- [Overview](#overview) +- [Comparison with the other approaches](#comparison-with-the-other-approaches) + - [PQXDH for post-quantum key agreement](#pqxdh-for-post-quantum-key-agreement) (Signal) + - [Hybrid Signal protocol for post-quantum encryption](#hybrid-signal-protocol-for-post-quantum-encryption) (Tutanota) +- [Augmented double ratchet algorithm](#augmented-double-ratchet-algorithm) +- [Double ratchet with encrypted headers augmented with double PQ KEM](#double-ratchet-with-encrypted-headers-augmented-with-double-pq-kem) + - [Initialization](#initialization) + - [Encrypting messages](#encrypting-messages) + - [Decrypting messages](#decrypting-messages) +- [Implementation considerations](#implementation-considerations) +- [Chosen KEM algorithm](#chosen-kem-algorithm) +- [Summary](#summary) + +## Overview + +It is a reasonable assumption that "record-now-decrypt-later" attacks are ongoing, so the users want to use cryptographic schemes for end-to-end encryption that are augmented with some post-quantum algorithm that is believed to be resistant to quantum computers. + +SimpleX Chat uses [double-ratchet with header encryption](https://signal.org/docs/specifications/doubleratchet/#double-ratchet-with-header-encryption) to provide end-to-end encryption to messages and files. This document describes augmented algorithm with post-quantum key encapsulation mechanism (KEM) making it resistant to quantum computers. + +Double-ratchet algorithm is a state of the art solution for end to end encryption offering a set of qualities that is not present in any other algorithm: + +- perfect forward secrecy, i.e. compromise of session or long term keys does not lead to the ability to decrypt any of the past messages. +- deniability (also known as repudiation), i.e. the fact that the recipient of the message while having the proof of message authenticity, cannot prove to a third party that the sender actually sent this message. +- break-in recovery (also know as post-compromise security or future secrecy), i.e. the ability of the end-to-end encryption security to recover from the compromise of the long term keys. This is achieved by generating a new random key pair whenever a new DH key is received (DH ratchet step). + +It is desirable to preserve all these qualities when augmenting the algorithm with a post-quantum algorithm, and having these qualities resistant to both conventional and quantum computers. + +## Comparison with the other approaches + +### PQXDH for post-quantum key agreement + +[The solution](https://signal.org/docs/specifications/pqxdh/) recently [introduced by Signal](https://signal.org/blog/pqxdh/) augments the initial key agreement ([X3DH](https://signal.org/docs/specifications/x3dh/)) that is made prior to double ratchet algorithm. This is believed to provide protection from "record-now-decrypt-later" attack, but if the attacker at any point obtains long term keys from any of the devices, the break-in recovery will not be post-quantum resistant, and the attacker with quantum computer will be able to decrypt all the subsequent messages. + +### Hybrid Signal protocol for post-quantum encryption + +[The solution](https://eprint.iacr.org/2021/875.pdf) [proposed by Tutanota](https://tutanota.com/blog/posts/pqmail-update/) aims to preserve the break-in recovery property of double ratchet, but in doing so it: +- replaces rather than augments DH key agreement with post-quantum KEM mechanism, making it potentially vulnerable to conventional computers. +- adds signature to the DH ratchet step, to compensate for not keeping DH key agreement, but losing the deniability property for some of the messages. + +## Augmented double ratchet algorithm + +The double ratchet algorithm is augmented with post-quantum KEM mechanism, preserving all properties of the double ratchet algorithm. + +It is possible, because although double ratchet uses DH (which is a non-interactive key exchanges), it uses it "interactively", when the new DH keys are generated by both parties in turns. Parties of double-ratchet encrypted communication can run two post-quantum key encapsulation mechanisms in parallel with both DH and KEM key agreements in each DH ratchet step, making break-in recovery of double ratchet algorithm post-quantum resistant, without losing deniability or resistance to conventional computers. + +Specifically, [double ratchet with encrypted headers](https://signal.org/docs/specifications/doubleratchet/#double-ratchet-with-header-encryption) is augmented with some post-quantum key encapsulation mechanism (KEM) as described below. A possible algorithm for PQ KEM is [NTRU-prime](https://ntruprime.cr.yp.to), that is currently adopted in SSH and has available implementations. It is important though that the proposed scheme can be used with any PQ KEM algorithm. + +The downside of the scheme is its substantial size overhead, as the encapsulation key and encapsulated shared secret are added to the header of each message. For the algorithm described below NTRU-prime adds ~2-4kb to each message (depending on the key size and the chosen variant). See [this table](https://ntruprime.cr.yp.to/security.html) for key and ciphertext sizes and the assessment of the security level for various key sizes. + +It is possible to reduce size overhead by using only one KEM agreement and making only one of two ratchet steps providing post-quantum resistant break-in recovery. + +## Double ratchet with encrypted headers augmented with double PQ KEM + +Algorithm below assumes that in addition to shared secret from the initial key agreement, there will be an encapsulation key available from the party that published its keys (Bob). + +### Initialization + +The double ratchet initialization is defined in pseudo-code. This pseudo-code is identical to Signal algorithm specification except for that parts that add post-quantum key agreement. + +``` +// Alice obtained Bob's keys and initializes ratchet first +def RatchetInitAlicePQ2HE(state, SK, bob_dh_public_key, shared_hka, shared_nhkb, bob_pq_kem_encapsulation_key): + state.DHRs = GENERATE_DH() + state.DHRr = bob_dh_public_key + // below added for post-quantum KEM + state.PQRs = GENERATE_PQKEM() + state.PQRr = bob_pq_kem_encapsulation_key + state.PQRss = random // shared secret for KEM + state.PQRct = PQKEM-ENC(state.PQRr, state.PQRss) // encapsulated additional shared secret + // above added for KEM + // the next line augments DH key agreement with PQ shared secret + state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr) || state.PQRss) + state.CKr = None + state.Ns = 0 + state.Nr = 0 + state.PN = 0 + state.MKSKIPPED = {} + state.HKs = shared_hka + state.HKr = None + state.NHKr = shared_nhkb + +// Bob initializes ratchet second, having received Alice's connection request +def RatchetInitBobPQ2HE(state, SK, bob_dh_key_pair, shared_hka, shared_nhkb, bob_pq_kem_key_pair): + state.DHRs = bob_dh_key_pair + state.DHRr = None + // below added for KEM + state.PQRs = bob_pq_kem_key_pair + state.PQRr = None + state.PQRss = None + state.PQRct = None + // above added for KEM + state.RK = SK + state.CKs = None + state.CKr = None + state.Ns = 0 + state.Nr = 0 + state.PN = 0 + state.MKSKIPPED = {} + state.HKs = None + state.NHKs = shared_nhkb + state.HKr = None + state.NHKr = shared_hka +``` + +`GENERATE_PQKEM` generates decapsulation/encapsulation key pair. + +`PQKEM-ENC` is key encapsulation algorithm. + +Other than commented lines, the above adds parameters `bob_pq_kem_encapsulation_key` and `bob_pq_kem_key_pair` to the ratchet initialization. Otherwise it is identical to the original double ratchet initialization. + +### Encrypting messages + +``` +def RatchetEncryptPQ2HE(state, plaintext, AD): + state.CKs, mk = KDF_CK(state.CKs) + // encapsulation key from PQRs and encapsulated shared secret is added to header + header = HEADER_PQ2( + dh = state.DHRs.public, + kem = state.PQRs.public, // added for KEM #2 + ct = state.PQRct // added for KEM #1 + pn = state.PN, + n = state.Ns, + ) + enc_header = HENCRYPT(state.HKs, header) + state.Ns += 1 + return enc_header, ENCRYPT(mk, plaintext, CONCAT(AD, enc_header)) +``` + +Other than adding encapsulation key and encapsulated shared secret into the header, the above is identical to the original double ratchet message encryption step. + +### Decrypting messages + +``` +def RatchetDecryptPQ2HE(state, enc_header, ciphertext, AD): + plaintext = TrySkippedMessageKeysHE(state, enc_header, ciphertext, AD) + if plaintext != None: + return plaintext + header, dh_ratchet = DecryptHeader(state, enc_header) // DecryptHeader is the same as in double ratchet specification + if dh_ratchet: + SkipMessageKeysHE(state, header.pn) // SkipMessageKeysHE is the same as in double ratchet specification + DHRatchetPQ2HE(state, header) + SkipMessageKeysHE(state, header.n) + state.CKr, mk = KDF_CK(state.CKr) + state.Nr += 1 + return DECRYPT(mk, ciphertext, CONCAT(AD, enc_header)) + +// DecryptHeader is the same as in double ratchet specification +def DecryptHeader(state, enc_header): + header = HDECRYPT(state.HKr, enc_header) + if header != None: + return header, False + header = HDECRYPT(state.NHKr, enc_header) + if header != None: + return header, True + raise Error() + +def DHRatchetPQ2HE(state, header): + state.PN = state.Ns + state.Ns = 0 + state.Nr = 0 + state.HKs = state.NHKs + state.HKr = state.NHKr + state.DHRr = header.dh + // save new encapsulation key from header + state.PQRr = header.kem + // decapsulate shared secret from header - KEM #2 + ss = PQKEM-DEC(state.PQRs.private, header.ct) + // use decapsulated shared secret with receiving ratchet + state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || ss) + state.DHRs = GENERATE_DH() + // below is added for KEM + state.PQRs = GENERATE_PQKEM() // generate new PQ key pair + state.PQRss = random // shared secret for KEM + state.PQRct = PQKEM-ENC(state.PQRr, state.PQRss) // encapsulated additional shared secret KEM #1 + // above is added for KEM + // use new shared secret with sending ratchet + state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || state.PQRss) +``` + +`PQKEM-DEC` is key decapsulation algorithm. + +`DHRatchetPQ2HE` augments both DH agreements with decapsulated shared secret from the received header and with the new shared secret, respectively. The new shared secret together with the new encapsulation key are saved in the state and will be added to the header in the next sent message. + +Other than augmenting DH key agreements with the shared secrets from KEM, the above is identical to the original double ratchet DH ratchet step. + +It is worth noting that while DH agreements work as ping-pong, when the new received DH key is used for both DH agreements (and only the sent DH key is updated for the second DH key agreement), PQ KEM agreements in the proposed scheme work as a "parallel ping-pong", with two balls in play all the time (two KEM agreements run in parallel). + +## Implementation considerations for SimpleX Messaging Protocol + +As SimpleX Messaging Protocol pads messages to a fixed size, using 16kb transport blocks, the size increase introduced by this scheme can be compensated for by using ZSTD encryption of JSON bodies and image previews encoded as base64. While there may be some rare cases of random texts that would fail to compress, in all real scenarios it would not cause the message size reduction. + +Sharing the initial keys in case of SimpleX Chat it is equivalent to sharing the invitation link. As encapsulation key is large, it may be inconvenient to share it in the link in some contexts, e.g. when QR codes are used. + +It is possible to postpone sharing the encapsulation key until the first message from Alice (confirmation message in SMP protocol), the party sending connection request. The upside here is that the invitation link size would not increase. The downside is that the user profile shared in this confirmation will not be encrypted with PQ-resistant algorithm. + +Another consideration is pairwise ratchets in groups. Key generation in sntrup761 is quite slow - on slow devices it can be as slow as 10-20 keys per second, so using this primitive in groups larger than 10-20 members would result in slow performance. + +For backward compatibility the implementation must support adding PQ-resistant key agreement to the existing connections. + +It is also beneficial to support removing PQ-resistant key agreement from the connections that have them, e.g. as the group size grows. + +### Chosen KEM algorithm + +The implementation uses Streamlined NTRU-Prime 761 (sntrup761) that was also used for OpenSSH for a long time. + +It was chosen over ML-KEM (Kyber) standardized by NIST for several reasons: + +- sntrup761 was used in OpenSSH for a long period of time. +- ML-KEM standardization process raised [concerns](https://groups.google.com/a/list.nist.gov/g/pqc-forum/c/WFRDl8DqYQ4) [amongst](https://blog.cr.yp.to/20231003-countcorrectly.html) the experts. +- ML-KEM (if modified) is likely to have conflicts with the existing patents, unlike sntrup761. + +It was chosen over non-interactive CTIDH due to its slower implementation, and lack of optimized code for aarch64 CPUs used in mobile devices. + +## Summary + +If chosen PQ KEM proves secure against quantum computer attacks, then the proposed augmented double ratchet will also be secure against quantum computer attack, including break-in recovery property, while keeping deniability and forward secrecy, because the [same proof](https://eprint.iacr.org/2016/1013.pdf) as for double ratchet algorithm would hold here, provided chosen KEM is secure. diff --git a/protocol/push-notifications.md b/protocol/push-notifications.md new file mode 100644 index 000000000..6d5e1dea0 --- /dev/null +++ b/protocol/push-notifications.md @@ -0,0 +1,398 @@ +Version 2, 2024-06-22 + +# Overview of push notifications for SimpleX Messaging Servers + +## Table of contents + +- [Introduction](#introduction) +- [Participating servers](#participating-servers) +- [Register device token to receive push notifications](#register-device-token-to-receive-push-notifications) +- [Subscribe to connection notifications](#subscribe-to-connection-notifications) +- [SimpleX Notification Server protocol](#simplex-notification-server-protocol) + - [Register new notification token](#register-new-notification-token) + - [Verify notification token](#verify-notification-token) + - [Check notification token status](#check-notification-token-status) + - [Replace notification token](#replace-notification-token) + - [Delete notification token](#delete-notification-token) + - [Subscribe to periodic notifications](#subscribe-to-periodic-notifications) + - [Create SMP message notification subscription](#create-smp-message-notification-subscription) + - [Check notification subscription status](#check-notification-subscription-status) + - [Delete notification subscription](#delete-notification-subscription) + - [Error responses](#error-responses) +- [Threat model](#threat-model) + +## Introduction + +SimpleX Messaging servers already operate as push servers and deliver the messages to subscribed clients as soon as they are sent to the servers. + +The reason for push notifications is to support instant message notifications on iOS that does not allow background services. + +## Participating servers + +The diagram below shows which servers participate in message notification delivery. + +While push provider (e.g., APN) can learn how many notifications are delivered to the user, it cannot access message content, even encrypted, or any message metadata - the notifications are e2e encrypted between SimpleX Notification Server and the user's device. + +``` + User's iOS device Internet Servers +--------------------- . ------------------------ . ----------------------------- + . . + . . can be self-hosted now ++--------------+ . . +----------------+ +| SimpleX Chat | -------------- TLS --------------- | SimpleX | +| client |------> SimpleX Messaging Protocol (SMP) ------> | Messaging | ++--------------+ ---------------------------------- | Server | + ^ | . . +----------------+ + | | . . . . . | . . . + | | . . | V | + | | . . |SMP| TLS + | | . . | | | SimpleX + | | . . . . . V . . . NTF Server + | | . . +----------------------------------+ + | | . . | +---------------+ | + | | -------------- TLS --------------- | | SimpleX | can be | + | |-----------> Notification Server Protocol -----> | | Notifications | self-hosted | + | ---------------------------------- | | Subscriber | in the future | + | . . | +---------------+ | + | . . | | | + | . . | V | + | . . | +---------------+ | + | . . | | SimpleX | | + | . . | | Push | | + | . . | | Server | | + | . . | +---------------+ | + | . . +----------------------------------+ + | . . . . . | . . . + | . . | V | + | . . |SMP| TLS + | . . | | | + | . . . . . V . . . + | -------------- TLS --------------- +-----------------+ + |----------------- Notification delivery <-------| Apple PN server | + ---------------------------------- +-----------------+ + . . +``` + +## Register device token to receive push notifications + +This diagram shows the process of registering a device to receive PUSH notifications via Apple Push Notification (APN) servers. + +![Register device notification token](./diagrams/notifications/register-token.svg) + +## Subscribe to connection notifications + +This diagram shows the process of subscription to notifications, notification delivery and device token update. + +![Subscribe to notifications](./diagrams/notifications/subscription.svg) + +## SimpleX Notification Server protocol + +To manage notification subscriptions to SMP servers, SimpleX Notification Server provides an RPC protocol with a similar design to SimpleX Messaging Protocol server. + +This protocol sends requests and responses in a fixed size blocks of 512 bytes over TLS, uses the same [syntax of protocol transmissions](./simplex-messaging.md#smp-transmission-and-transport-block-structure) as SMP protocol, and has the same transport [handshake syntax](./simplex-messaging.md#transport-handshake) (except the server certificate is not included in the handshake). + +Protocol commands have this syntax: + +``` +ntfServerTransmission = +ntfServerCmd = newTokenCmd / verifyTokenCmd / checkTokenCmd / + replaceTokenCmd / deleteTokenCmd / cronCmd / + newSubCmd / checkSubCmd / deleteSubCmd +``` +### Register new notification token + +This command should be used after the client app obtains a token from push notifications provider to register the token with the server. + +Having received this command the server will deliver a test notification via the push provider to validate that the client has this token. + +The command syntax: + +```abnf +newTokenCmd = %s"TNEW" SP newToken +newToken = %s"T" deviceToken authPubKey clientDhPubKey +deviceToken = pushProvider tokenString +pushProvider = apnsDev / apnsProd / apnsNull +apnsDev = "AD" ; APNS token for development environment +apnsProd = "AP" ; APNS token for production environment +apnsNull = "AN" ; token that does not trigger any notification delivery - used for server testing +tokenString = shortString +authPubKey = length x509encoded ; Ed25519 key used to verify clients commands +clientDhPubKey = length x509encoded ; X25519 key to agree e2e encryption between the server and client +shortString = length *OCTET +length = 1*1 OCTET +``` + +The server response syntax: + +```abnf +tokenIdResp = %s"IDTKN" SP entityId serverDhPubKey +entityId = shortString +serverDhPubKey = length x509encoded ; X25519 key to agree e2e encryption between the server and client +``` + +### Verify notification token + +This command is used to verify the token after the device receives the test notification from the push provider. + +The command syntax: + +```abnf +verifyTokenCmd = %s"TVFY" SP regCode +regCode = shortString +``` + +The response to this command is `okResp` or `errorResp` + +```abnf +okResp = %s"OK" +``` + +### Check notification token status + +This command is used to check the token status: + +```abnf +checkTokenCmd = %s"TCHK" +``` + +The response to this command: + +```abnf +tokenStatusResp = %s"TKN" SP tokenStatus +tokenStatus = %s"NEW" / %s"REGISTERED" / %s"INVALID" / %s"CONFIRMED" / %s"ACTIVE" / %s"EXPIRED" +``` + +### Replace notification token + +This command should be used when push provider issues a new notification token. + +It happens when: +- the app data is migrated to another device. +- the app is re-installed on the same device. +- can happen periodically, at push provider discretion. + +This command allows to replace the token without re-registering and re-subscribing all notification subscriptions. + +Using this command triggers the same verification flow as registering a new token. + +The command syntax: + +```abnf +replaceTokenCmd = %s"TRPL" SP deviceToken +``` + +The response to this command is `okResp` or `errorResp`. + +### Delete notification token + +The command syntax: + +```abnf +deleteTokenCmd = %s"TDEL" +``` + +The response to this command is `okResp` or `errorResp`. + +After this command all message notification subscriptions will be removed and no more notifications will be sent. + +### Subscribe to periodic notifications + +This command enables or disables periodic notifications sent to the client device irrespective of message notifications. + +This is useful for two reasons: +- it provides better privacy from notification server, as while the server learns the device token, it doesn't learn anything else about user communications. +- it allows to receive messages when notifications were dropped by push provider, e.g. while the device was offline, or lost by notification server, e.g. while it was restarting. + +The command syntax: + +```abnf +cronCmd = %s"TCRN" SP interval +interval = 2*2 OCTET ; Word16, minutes +``` + +The interval for periodic notifications is set in minutes, with the minimum of 20 minutes. The client should pass `0` to disable periodic notifications. + +### Create SMP message notification subscription + +This command makes notification server subscribe to message notifications from SMP server and to deliver them to push provider: + +```abnf +newSubCmd = %s"SNEW" newSub +newSub = %s "S" tokenId smpServer notifierId notifierKey +tokenId = shortString ; returned in response to `TNEW` command +smpServer = smpServer = hosts port fingerprint +hosts = length 1*host +host = shortString +port = shortString +fingerprint = shortString +notifierId = shortString ; returned by SMP server in response to `NKEY` SMP command +notifierKey = length x509encoded ; private key used to authorize requests to subscribe to message notifications +``` + +The response syntax: + +```abnf +subIdResp = %s"IDSUB" SP entityId +``` + +### Check notification subscription status + +This command syntax: + +```abnf +checkSubCmd = %s"SCHK" +``` + +The response: + +```abnf +subStatusResp = %s"SUB" SP subStatus +subStatus = %s"NEW" / %s"PENDING" / ; e.g., after SMP server disconnect/timeout while ntf server is retrying to connect + %s"ACTIVE" / %s"INACTIVE" / %s"END" / ; if another server subscribed to notifications + %s"AUTH" / subErrStatus +subErrStatus = %s"ERR" SP shortString +``` + +### Delete notification subscription + +The command syntax: + +```abnf +deleteSubCmd = %s"SDEL" +``` + +The response to this command is `okResp` or `errorResp`. + +After this command no more message notifications will be sent from this queue. + +### Error responses + +All commands can return error response: + +```abnf +errorResp = %s"ERR" SP errorType +``` + +Where `errorType` has the same syntax as in [SimpleX Messaging Protocol](./simplex-messaging.md#error-responses) + +## Threat Model + +This threat model compliments SimpleX Messaging Protocol [threat model](./overview-tjr.md#threat-model) + +#### A passive adversary able to monitor the traffic of one user + +*can:* + + - identify that and a user is using SimpleX push notifications. + +*cannot:* + + - determine which servers a user subscribed to the notifications from. + +#### A passive adversary able to monitor a set of senders and recipients + + *can:* + + - perform more efficient traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers. + +#### SimpleX Messaging Protocol server + +*can:* + +- learn which messages trigger push notifications. + +- learn IP address of SimpleX notification servers used by the user. + +- drop message notifications. + +- spam a user with invalid notifications. + +*cannot:* + +- learn user device token for push notifications. + +- learn which queues belong to the same users with any additional efficiency compared with not using push notifications. + +#### SimpleX Notification Server subscribed to message notifications + +*can:* + +- learn a user device token. + +- learn how many messaging queues and servers a user receives messages from. + +- learn how many message notifications are delivered to the user from each queue. + +- undetectably drop notifications. + +- spam a user with background notifications. + +*cannot:* + +- learn queue addresses for receiving or sending messages. + +- learn the contents or type of messages (not even encrypted). + +- learn anything about messages sent without notification flag. + +- spam a user with visible notifications (provided the client app can filter push notifications). + +- add, duplicate, or corrupt individual messages that will be shown to the user. + +#### SimpleX Notification Server subscribed ONLY to periodic notifications + +*can:* + +- learn a user device token. + +- drop periodic notifications. + +- spam a user with background notifications. + +*cannot:* + +- learn how many messaging queues and servers a user receives messages from. + +- learn how many message notifications are delivered to the user from each queue. + +- learn queue addresses for receiving or sending messages. + +- learn the contents or type of messages (not even encrypted). + +- learn anything about messages sent without notification flag. + +- spam a user with visible notifications (provided the client app can filter push notifications). + +- add, duplicate, or corrupt individual messages that will be shown to the user. + +#### A user’s contact + +*cannot:* + +- determine if a user uses push notifications or not. + +#### Push notification provider (e.g., APN) + +*can:* + +- learn that a user uses SimpleX app. + +- learn how many notifications are delivered to user's device. + +- drop notifications (in fact, APN coalesces notifications delivered while user's device is offline, delivering only the last one). + +*cannot:* + +- learn which SimpleX Messaging Protocol servers are used by a user (notifications are e2e encrypted). + +- learn which or how many messaging queues a user receives notifications from. + +- learn the contents or type of messages (not even encrypted, notifications only contain encrypted metadata). + +#### An attacker with Internet access + +*cannot:* + +- register notification token not present on attacker's device. + +- enumerate tokens or subscriptions on a SimpleX Notification Server. diff --git a/protocol/simplex-messaging.md b/protocol/simplex-messaging.md index 48843cab3..16e4e6606 100644 --- a/protocol/simplex-messaging.md +++ b/protocol/simplex-messaging.md @@ -1,3 +1,5 @@ +Version 9, 2024-06-22 + # Simplex Messaging Protocol (SMP) ## Table of contents @@ -9,39 +11,51 @@ - [Simplex queue](#simplex-queue) - [SMP queue URI](#smp-queue-uri) - [SMP procedure](#smp-procedure) +- [Fast SMP procedure](#fast-smp-procedure) - [SMP qualities and features](#smp-qualities-and-features) - [Cryptographic algorithms](#cryptographic-algorithms) +- [Deniable client authentication scheme](#deniable-client-authentication-scheme) - [Simplex queue IDs](#simplex-queue-ids) - [Server security requirements](#server-security-requirements) - [Message delivery notifications](#message-delivery-notifications) -- [SMP Transmission structure](#smp-transmission-structure) +- [SMP Transmission and transport block structure](#smp-transmission-and-transport-block-structure) - [SMP commands](#smp-commands) - [Correlating responses with commands](#correlating-responses-with-commands) - - [Command authentication](#command-authentication) + - [Command verification](#command-verification) - [Keep-alive command](#keep-alive-command) - [Recipient commands](#recipient-commands) - [Create queue command](#create-queue-command) - [Subscribe to queue](#subscribe-to-queue) - - [Secure queue command](#secure-queue-command) + - [Secure queue by recipient](#secure-queue-by-recipient) - [Enable notifications command](#enable-notifications-command) - [Disable notifications command](#disable-notifications-command) + - [Get message command](#get-message-command) - [Acknowledge message delivery](#acknowledge-message-delivery) - [Suspend queue](#suspend-queue) - [Delete queue](#delete-queue) + - [Get queue state](#get-queue-state) - [Sender commands](#sender-commands) + - [Secure queue by sender](#secure-queue-by-sender) - [Send message](#send-message) + - [Proxying sender commands](#proxying-sender-commands) + - [Request proxied session](#request-proxied-session) + - [Send command via proxy](#send-command-via-proxy) + - [Forward command to destination server](#forward-command-to-destination-server) - [Notifier commands](#notifier-commands) - [Subscribe to queue notifications](#subscribe-to-queue-notifications) - [Server messages](#server-messages) - - [Queue IDs response](#queue-ids-response) - [Deliver queue message](#deliver-queue-message) - - [Notifier queue ID response](#notifier-queue-id-response) - [Deliver message notification](#deliver-message-notification) - [Subscription END notification](#subscription-end-notification) - [Error responses](#error-responses) - [OK response](#ok-response) -- [Appendices](#appendices) - - [Appendix A. Transport connection with the SMP server](#appendix-a) +- [Transport connection with the SMP server](#transport-connection-with-the-SMP-server) + - [General transport protocol considerations](#general-transport-protocol-considerations) + - [TLS transport encryption](#tls-transport-encryption) + - [Server certificate](#server-certificate) + - [ALPN to agree handshake version](#alpn-to-agree-handshake-version) + - [Transport handshake](#transport-handshake) + - [Additional transport privacy](#additional-transport-privacy) ## Abstract @@ -51,11 +65,11 @@ It's designed with the focus on communication security and integrity, under the It is designed as a low level protocol for other application protocols to solve the problem of secure and private message transmission, making [MITM attack][1] very difficult at any part of the message transmission system. -This document describes SMP protocol versions 3 and 4, the previous versions are discontinued. +This document describes SMP protocol versions 6 and 7, the previous versions are discontinued. ## Introduction -The objective of Simplex Messaging Protocol (SMP) is to facilitate the secure and private unidirectional transfer of messages from senders to recipients via persistent simplex queues managed by the message broker (server). +The objective of Simplex Messaging Protocol (SMP) is to facilitate the secure and private unidirectional transfer of messages from senders to recipients via persistent simplex queues managed by the message brokers (servers). SMP is independent of any particular transmission system and requires only a reliable ordered data stream channel. While this document describes transport over TCP, other transports are also possible. @@ -67,7 +81,7 @@ The protocol is designed with the focus on privacy and security, to some extent SMP does not use any form of participants' identities and provides [E2EE][2] without the possibility of [MITM attack][1] relying on two pre-requisites: -- the users can establish a secure encrypted transport connection with the SMP server. [Appendix A](#appendix-a) describes SMP transport protocol of such connection over TCP, but any other transport connection protocol can be used. +- the users can establish a secure encrypted transport connection with the SMP server. [Transport connection](#transport-connection-with-the-smp-server) section describes SMP transport protocol of such connection over TCP, but any other transport connection protocol can be used. - the recipient can pass a single message to the sender via a pre-existing secure and private communication channel (out-of-band message) - the information in this message is used to encrypt messages and to establish connection with SMP server. @@ -77,13 +91,13 @@ The SMP model has three communication participants: the recipient, the message b SMP server manages multiple "simplex queues" - data records on the server that identify communication channels from the senders to the recipients. The same communicating party that is the sender in one queue, can be the recipient in another - without exposing this fact to the server. -The queue record consists of 2 unique random IDs generated by the server, one for the recipient and another for the sender, and 2 keys to authenticate the recipient and the sender respectively, provided by the client. The users of SMP protocol must use a unique key for each queue, to avoid the possibility of aggregating and analyzing their queues in case SMP server is compromised. +The queue record consists of 2 unique random IDs generated by the server, one for the recipient and another for the sender, and 2 keys to verify the recipient's and the sender's commands, provided by the clients. The users of SMP protocol must use a unique ephemeral keys for each queue, to prevent aggregating their queues by keys in case SMP server is compromised. Creating and using the queue requires sending commands to the SMP server from the recipient and the sender - they are described in detail in [SMP commands](#smp-commands) section. ## Out-of-band messages -The out-of-band message with the queue information is sent via some trusted alternative channel from the recipient to the sender. This message is used to share one or several [queue URIs](#smp-queue-uri) that parties can use to establish the initial connection, the encryption scheme and, it can include the public key(s) for end-to-end encryption. +The out-of-band message with the queue information is sent via some trusted alternative channel from the recipient to the sender. This message is used to share one or several [queue URIs](#smp-queue-uri) that parties can use to establish the initial connection, the encryption scheme, including the public key(s) for end-to-end encryption. The approach to out-of-band message passing and their syntax should be defined in application-level protocols. @@ -91,9 +105,9 @@ The approach to out-of-band message passing and their syntax should be defined i The simplex queue is the main unit of SMP protocol. It is used by: -- Sender of the queue (who received out-of-band message) to send messages to the server using sender's queue ID, signed by sender's key. +- Sender of the queue (who received out-of-band message) to send messages to the server using sender's queue ID, authorized by sender's key. -- Recipient of the queue (who created the queue and sent out-of-band message) will use it to retrieve messages from the server, signing the commands by the recipient key. Recipient decrypts the messages with the key negotiated during the creation of the queue. +- Recipient of the queue (who created the queue and sent out-of-band message) will use it to retrieve messages from the server, authorizing the commands by the recipient key. Recipient decrypts the messages with the key negotiated during the creation of the queue. - Participant identities are not shared with the server - new unique keys and queue IDs are used for each queue. @@ -101,7 +115,7 @@ This simplex queue can serve as a building block for more complex communication This approach is based on the concept of [unidirectional networks][4] that are used for applications with high level of information security. -Access to each queue is controlled with unique (not shared with other queues) asymmetric key pairs, separate for the sender and the recipient. The sender and the receiver have private keys, and the server has associated public keys to authenticate participants' commands by verifying cryptographic signatures. +Access to each queue is controlled with unique (not shared with other queues) asymmetric key pairs, separate for the sender and the recipient. The sender and the receiver have private keys, and the server has associated public keys to authenticate participants' commands by verifying cryptographic authorizations. The messages sent over the queue are end-to-end encrypted using the DH secret agreed via out-of-band message and SMP confirmation. @@ -115,17 +129,21 @@ The protocol uses different IDs for sender and recipient in order to provide an ## SMP queue URI -The SMP queue URIs MUST include server identity, queue hostname, an optional port, sender queue ID and the public key that the clients must use to verify responses. Server identity is used to establish secure connection protected from MITM attack with SMP server (see [Appendix A](#appendix-a) for SMP transport protocol). +The SMP queue URIs MUST include server identity, queue hostname, an optional port, sender queue ID, and the recipient's public key to agree shared secret for e2e encryption, and an optional query string parameter `k=s` to indicate that the queue can be secured by the sender using `SKEY` command (see [Fast SMP procedure](#fast-smp-procedure) and [Secure queue by sender](#secure-queue-by-sender)). Server identity is used to establish secure connection protected from MITM attack with SMP server (see [Transport connection](#transport-connection-with-the-smp-server) for SMP transport protocol). The [ABNF][8] syntax of the queue URI is: ```abnf -queueURI = %s"smp://" smpServer "/" queueId "#" recipientDhPublicKey -smpServer = serverIdentity "@" srvHost [":" port] -srvHost = ; RFC1123, RFC5891 +queueURI = %s"smp://" smpServer "/" queueId "#/?" versionParam keyParam [sndSecureParam] +smpServer = serverIdentity "@" srvHosts [":" port] +srvHosts = ["," srvHosts] ; RFC1123, RFC5891 port = 1*DIGIT serverIdentity = base64url queueId = base64url +versionParam = %s"v=" versionRange +versionRange = 1*DIGIT / 1*DIGIT "-" 1*DIGIT +keyParam = %s"&dh=" recipientDhPublicKey +sndSecureParam = %s"&k=s" base64url = ; RFC4648, section 5 recipientDhPublicKey = x509UrlEncoded ; the recipient's Curve25519 key for DH exchange to derive the secret @@ -139,7 +157,7 @@ x509UrlEncoded = `port` is optional, the default TCP port for SMP protocol is 5223. -`serverIdentity` is a required hash of the server certificate SPKI block (without line breaks, header and footer) used by the client to validate server certificate during transport handshake (see [Appendix A](#appendix-a)) +`serverIdentity` is a required hash of the server certificate SPKI block (without line breaks, header and footer) used by the client to validate server certificate during transport handshake (see [Transport connection](#transport-connection-with-the-smp-server)) ## SMP procedure @@ -149,17 +167,17 @@ To create and start using a simplex queue Alice and Bob follow these steps: 1. Alice creates a simplex queue on the server: - 1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Appendix A](#appendix-a)). + 1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Transport connection](#transport-connection-with-the-smp-server)). - 2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before for Bob to encrypt the messages. + 2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before to agree a shared secret with Bob to encrypt the messages. - 3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to sign commands and to decrypt the transmissions received from the server. + 3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to authorize commands to the server. 4. Generates one more random key pair (recipient DH key - `RDHK`) to negotiate symmetric key that will be used by the server to encrypt message bodies delivered to Alice (to avoid shared cipher-text inside transport connection). - 5. Sends `"NEW"` command to the server to create a simplex queue (see `create` in [Create queue command](#create-queue-command)). This command contains previously generated unique "public" keys `RK` and `RDHK`. `RK` will be used to verify the following commands related to the same queue signed by its private counterpart, for example to subscribe to the messages received to this queue or to update the queue, e.g. by setting the key required to send the messages (initially Alice creates the queue that accepts unsigned messages, so anybody could send the message via this queue if they knew the queue sender's ID and server address). + 5. Sends `"NEW"` command to the server to create a simplex queue (see `create` in [Create queue command](#create-queue-command)). This command contains previously generated unique "public" keys `RK` and `RDHK`. `RK` will be used by the server to verify the subsequent commands related to the same queue authorized by its private counterpart, for example to subscribe to the messages received to this queue or to update the queue, e.g. by setting the key required to send the messages (initially Alice creates the queue that accepts unauthorized messages, so anybody could send the message via this queue if they knew the queue sender's ID and server address). - 6. The server sends `"IDS"` response with queue IDs (`queueIds`): + 6. The server sends `IDS` response with queue IDs (`queueIds`): - Recipient ID `RID` for Alice to manage the queue and to receive the messages. @@ -167,27 +185,29 @@ To create and start using a simplex queue Alice and Bob follow these steps: - Server public DH key (`SDHK`) to negotiate a shared secret for message body encryption, that Alice uses to derive a shared secret with the server `SS`. -2. Alice sends an out-of-band message to Bob via the alternative channel that both Alice and Bob trust (see [protocol abstract](#simplex-messaging-protocol-abstract)). The message must include: +2. Alice sends an out-of-band message to Bob via the alternative channel that both Alice and Bob trust (see [protocol abstract](#simplex-messaging-protocol-abstract)). The message must include [SMP queue URI](#smp-queue-uri) with: - - Unique "public" key (`EK`) that Bob must use for E2E key agreement. + - Unique "public" key (`EK`) that Bob must use to agree a shared secret for E2E encryption. - - SMP server hostname and information to open secure encrypted transport connection (see [Appendix A](#appendix-a)). + - SMP server hostname and information to open secure encrypted transport connection (see [Transport connection](#transport-connection-with-the-smp-server)). - Sender queue ID `SID` for Bob to use. 3. Bob, having received the out-of-band message from Alice, connects to the queue: - 1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to sign messages sent to Alice's server. + 1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to authorize messages sent to Alice's server and another key pair for e2e encryption agreement. 2. Prepares the confirmation message for Alice to secure the queue. This message includes: - - Previously generated "public" key `SK` that will be used by Alice's server to authenticate Bob's messages, once the queue is secured. + - Previously generated "public" key `SK` that will be used by Alice's server to verify Bob's messages, once the queue is secured. + + - Public key to agree a shared secret with Alice for e2e encryption. - Optionally, any additional information (application specific, e.g. Bob's profile name and details). - 3. Encrypts the confirmation body with the "public" key `EK` (that Alice provided via the out-of-band message). + 3. Encrypts the confirmation body with the shared secret agreed using public key `EK` (that Alice provided via the out-of-band message). - 4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be signed - signed messages will be rejected until Alice secures the queue (below). + 4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be authorized - authorized messages will be rejected until Alice secures the queue (below). 4. Alice receives Bob's message from the server using recipient queue ID `RID` (possibly, via the same transport connection she already has opened - see `message` in [Deliver queue message](#deliver-queue-message)): @@ -195,13 +215,13 @@ To create and start using a simplex queue Alice and Bob follow these steps: 2. She decrypts received message with [key agreed with sender using] "private" key `EK`. - 3. Even though anybody could have sent the message to the queue with ID `SID` before it is secured (e.g. if communication is compromised), Alice would ignore all messages until the decryption succeeds (i.e. the result contains the expected message format). Optionally, in the client application, she also may identify Bob using the information provided, but it is out of scope of SMP protocol. + 3. Anybody can send the message to the queue with ID `SID` before it is secured (e.g. if communication is compromised), so it's a "race" to secure the queue. Optionally, in the client application, Alice may identify Bob using the information provided, but it is out of scope of SMP protocol. 5. Alice secures the queue `RID` with `"KEY"` command so only Bob can send messages to it (see [Secure queue command](#secure-queue-command)): - 1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests signed by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob. + 1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests authorized by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob. - 2. From this moment the server will accept only signed commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has). + 2. From this moment the server will accept only authorized commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has). 3. Once queue is secured, Alice deletes `SID` and `SK` - even if Alice's client is compromised in the future, the attacker would not be able to send messages pretending to be Bob. @@ -217,19 +237,19 @@ Bob now can securely send messages to Alice: 1. Bob sends the message: - 1. He encrypts the message to Alice with "public" key `EK` (provided by Alice, only known to Bob, used only for one simplex queue). + 1. He encrypts the message to Alice with the agreed shared secret (using "public" key `EK` provided by Alice, only known to Bob, used only for one simplex queue). - 2. He signs `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue). + 2. He authorizes `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue). - 3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will authenticate using the "public" key `SK` (that Alice earlier received from Bob and provided to the server via `"KEY"` command). + 3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will verify using the "public" key `SK` (that Alice earlier received from Bob and provided to the server via `"KEY"` command). 2. Alice receives the message(s): - 1. She signs `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)). + 1. She authorizes `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)). - 2. The server, having authenticated Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)). + 2. The server, having verified Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)). - 3. She decrypts Bob's message(s) with the "private" key `EK` (that only she has). + 3. She decrypts Bob's message(s) with the shared secret agreed using "private" key `EK`. 4. She acknowledges the message reception to the server with `"ACK"` so that the server can delete the message and deliver the next messages. @@ -245,15 +265,27 @@ This flow is show on sequence diagram below. Sequence diagram does not show E2E encryption - server knows nothing about encryption between the sender and the receiver. -A higher level protocol application protocol should define the semantics that allow to use two simplex queues (or two sets of queues for redundancy) for the bi-directional or any other communication scenarios. +A higher level application protocol should define the semantics that allow to use two simplex queues (or two sets of queues for redundancy) for the bi-directional or any other communication scenarios. The SMP is intentionally unidirectional - it provides no answer to how Bob will know that the transmission succeeded, and whether Alice received any messages. There may be a scenario when Alice wants to securely receive the messages from Bob, but she does not want Bob to have any proof that she received any messages - this low-level protocol can be used in this scenario, as all Bob knows as a fact is that he was able to send one unsigned message to the server that Alice provided, and now he can only send messages signed with the key `SK` that he sent to the server - it does not prove that any message was received by Alice. -For practical purposes of bi-directional conversation, now that Bob can securely send encrypted messages to Alice, Bob can create the second simplex queue that will allow Alice to send messages to Bob in the same way, sending the second queue details via the first queue. If both Alice and Bob have their respective unique "public" keys (Alice's and Bob's `EK`s of two separate queues), or pass additional keys to sign the messages, the conversation can be both encrypted and signed. +For bi-directional conversation, now that Bob can securely send encrypted messages to Alice, Bob can create the second simplex queue that will allow Alice to send messages to Bob in the same way, sending the second queue details via the first queue. If both Alice and Bob have their respective unique "public" keys (Alice's and Bob's `EK`s of two separate queues), or pass additional keys to sign the messages, the conversation can be both encrypted and signed. The established queues can also be used to change the encryption keys providing [forward secrecy][5], or to negotiate using other SMP queue(s). -This protocol also can be used for off-the-record messaging, as Alice and Bob can use multiple queues between them and only information they pass to each other allows proving their identity, so if they want to share anything off-the-record they can initiate a new queue without linking it to any other information they exchanged. As a result, this protocol provides better anonymity and better protection from [MITM][1] than [OTR][6] protocol. +This protocol also can be used for off-the-record messaging, as Alice and Bob can use multiple queues between them and only information they pass to each other allows proving their identity, so if they want to share anything off-the-record they can initiate a new queue without linking it to any other information they exchanged. + +## Fast SMP procedure + +V9 of SMP protocol added support for creating messaging queue in fewer steps, with the sender being able to send the messages without waiting for the recipient to be online to secure the key. + +In step 1.5 of [SMP procedure](#smp-procedure) the client must use sndSecure parameter set to `T` (true) to allow sender securing the queue. + +In step 2, the [SMP queue URI](#smp-queue-uri) should include parameter indicating that the sender can secure the queue. + +In step 3.2, prior to sending the confirmation message Bob secures the queue using `SKEY` command. Confirmation message is now sent with sender authorization and Bob can continue sending the messages without Alice being online. This also allows faster negotiation of duplex connections. + +![Creating queue](./diagrams/simplex-messaging/simplex-creating-fast.svg) ## SMP qualities and features @@ -269,11 +301,11 @@ Simplex Messaging Protocol: - Multiple servers, that can be deployed by the system users, can be used to send and retrieve messages. - - Servers do not communicate with each other and do not "know" about other servers. + - Servers do not communicate with each other, except when used as proxy to forward commands to another server, and do not "know" about other servers. - Clients only communicate with servers (excluding the initial out-of-band message), so the message passing is asynchronous. - - For each queue, the message recipient defines the server through which the sender should send messages. + - For each queue, the message recipient defines the server through which the sender should send messages. To protect transport anonymity the sender can use their chosen server to forward commands to the server chosen by the recipient. - While multiple servers and multiple queues can be used to pass each message, it is in scope of application level protocol(s), and out of scope of this protocol. @@ -285,50 +317,56 @@ Simplex Messaging Protocol: - Each queue is created and managed by the queue recipient. - - Asymmetric encryption is used to sign and verify the requests to send and receive the messages. + - Asymmetric encryption is used to authorize and verify the requests to send and receive the messages. - - One unique "public" key is used by the servers to authenticate requests to send the messages into the queue, and another unique "public" key - to retrieve the messages from the queue. "Unique" here means that each "public" key is used only for one queue and is not used for any other context - effectively, this key is not public and does not represent any participant identity. + - One ephemeral public key is used by the servers to verify requests to send the messages into the queue, and another ephemeral public key - to verify requests to retrieve the messages from the queue. These ephemeral keys are used only for one queue, and are not used for any other context - this key does not represent any participant identity. - - Both recipient and sender "public" keys are provided to the server by the queue recipient. "Public" key `RK` is provided when the queue is created, public key `SK` is provided when the queue is secured. + - Both recipient and sender public keys are provided to the server by the queue recipient. "Public" key `RK` is provided when the queue is created, public key `SK` is provided when the queue is secured. V9 of SMP protocol allows senders to provide their key to the server directly or via proxy, to avoid waiting until the recipient is online to secure the queue. - - The "public" keys known to the server and used to authenticate commands from the participants are unrelated to the keys used to encrypt and decrypt the messages - the latter keys are also unique per each queue but they are only known to participants, not to the servers. + - The "public" keys known to the server and used to verify commands from the participants are unrelated to the keys used to encrypt and decrypt the messages - the latter keys are also unique per each queue but they are only known to participants, not to the servers. - Messaging graph can be asymmetric: Bob's ability to send messages to Alice does not automatically lead to the Alice's ability to send messages to Bob. ## Cryptographic algorithms -Simplex messaging clients and servers must cryptographically sign commands, responses and messages for the following operations: +Simplex messaging clients must cryptographically authorize commands for the following operations: - With the recipient's key `RK` (server to verify): - create the queue (`NEW`) - subscribe to queue (`SUB`) - secure the queue (`KEY`) - enable queue notifications (`NKEY`) + - disable queue notifications (`NDEL`) - acknowledge received messages (`ACK`) - suspend the queue (`OFF`) - delete the queue (`DEL`) - With the sender's key `SK` (server to verify): + - secure queue (`SKEY`) - send messages (`SEND`) - With the optional notifier's key: - subscribe to message notifications (`NSUB`) -- With the server's key (for recipient and sender to verify) - - queue IDs response (`IDS`) - - notifier queue ID response (`NID`) - - delivered messages (`MSG`) - - `OK` and `ERR` responses (excluding error responses not related to a queue) -To sign/verify transmissions clients and servers MUST use Ed25519 or Ed448 algorithm defined in [RFC8709][15]. +To authorize/verify transmissions clients and servers MUST use either signature algorithm Ed25519 algorithm defined in [RFC8709][15] or [deniable authentication scheme](#deniable-client-authentication-scheme) based on NaCL crypto_box. -To encrypt/decrypt message bodies delivered to the recipients, servers/clients MUST use x25519 or x448 algorithm defined in [RFC8709][15] to derive the shared secret (TODO encryption scheme). +It is recommended that clients use signature algorithm for the recipient commands and deniable authentication scheme for sender commands (to have non-repudiation quality in the whole protocol stack). -Clients MUST encrypt message bodies sent via SMP servers - the protocol for this end-to-end encryption should be chosen by the clients using SMP protocol. +To encrypt/decrypt message bodies delivered to the recipients, servers/clients MUST use NaCL crypto_box. -The reasons to use these algorithms: +Clients MUST encrypt message bodies sent via SMP servers using use NaCL crypto_box. -- Faster operation than RSA algorithms. -- DH key exchange provides forward secrecy. +## Deniable client authentication scheme -Future versions of the protocol may allow different cryptographic algorithms. +While e2e encryption algorithms used in the client applications have repudiation quality, which is the desirable default, using signature algorithm for command authorization has non-repudiation quality. + +SMP protocol supports repudiable authenticators to authorize client commands. These authenticators use NaCl crypto_box that proves authentication and third party unforgeability and, unlike signature, provides repudiation guarantee. See [crypto_box docs](https://nacl.cr.yp.to/box.html). + +When queue is created or secured, the recipient would provide a DH key (X25519) to the server (either their own or received from the sender, in case of KEY command), and the server would provide its own random X25519 key per session in the handshake header. The authenticator is computed in this way: + +```abnf +transmission = authenticator authorized +authenticator = crypto_box(sha512(authorized), secret = dh(client long term queue key, server session key), nonce = correlation ID) +authorized = sessionIdentifier corrId queueId protocol_command ; same as the currently signed part of the transmission +``` ## Simplex queue IDs @@ -351,7 +389,7 @@ Simplex messaging server implementations MUST NOT create, store or send to any o ## Message delivery notifications -Supporting message delivery while the client mobile app is not running requires sending push notifications with the device token. All alternative mechanisms for background message delivery are unreliable, particularly on iOS platform. Obviously, supporting push notification delivery by simply subscribing to messages would reduce meta-data privacy as it allows to see all queues that a given device uses. +Supporting message delivery while the client mobile app is not running requires sending push notifications with the device token. All alternative mechanisms for background message delivery are unreliable, particularly on iOS platform. To protect the privacy of the recipients, there are several commands in SMP protocol that allow enabling and subscribing to message notifications from SMP queues, using separate set of "notifier keys" and via separate queue IDs - as long as SMP server is not compromised, these notifier queue IDs cannot be correlated with recipient or sender queue IDs. @@ -362,14 +400,14 @@ The clients can optionally instruct a dedicated push notification server to subs - `subscribeNotifications` (`"NSUB"`) - see [Subscribe to queue notifications](#subscribe-to-queue-notifications). - `messageNotification` (`"NMSG"`) - see [Deliver message notification](#deliver-message-notification). -[`SEND` command](#send-message) includes the notification flag to instruct SMP server whether to send the notification - this flag is forwarded to the recepient inside encrypted envelope, together with the timestamp and the message body, so even if TLS is compromised this flag cannot be used for traffic correlation. +[`SEND` command](#send-message) includes the notification flag to instruct SMP server whether to send the notification - this flag is forwarded to the recipient inside encrypted envelope, together with the timestamp and the message body, so even if TLS is compromised this flag cannot be used for traffic correlation. ## SMP Transmission and transport block structure Each transport block has a fixed size of 16384 bytes for traffic uniformity. -From SMP version 4 each block can contain multiple transmissions, version 3 blocks have 1 transmission. -Some parts of SMP transmission are padded to a fixed size; this padding is uniformly added as a word16 encoded in network byte order - see `paddedString` syntax. +Each block can contain multiple transmissions. +Some parts of SMP transmission are padded to a fixed size; the size of the unpadded string is prepended as a word16 encoded in network byte order - see `paddedString` syntax. In places where some part of the transmission should be padded, the syntax for `paddedNotation` is used: @@ -383,26 +421,7 @@ paddedNotation = ; paddedLength - required length after padding, including 2 bytes for originalLength ``` -Each transmission/block for SMP v3 between the client and the server must have this format/syntax: - -```abnf -paddedTransmission = -transmission = signature signed -signed = sessionIdentifier corrId queueId smpCommand -; corrId is required in client commands and server responses, -; it is empty in server notifications. -corrId = length *OCTET -queueId = length *OCTET -; empty queue ID is used with "create" command and in some server responses -signature = length *OCTET -; empty signature can be used with "send" before the queue is secured with secure command -; signature is always empty with "ping" and "serverMsg" -length = 1*1 OCTET -``` - -`base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9] - -Transport block for SMP v4 has this syntax: +Transport block for SMP transmission between the client and the server must have this syntax: ```abnf paddedTransportBlock = @@ -410,6 +429,24 @@ transportBlock = transmissionCount transmissions transmissionCount = 1*1 OCTET ; equal or greater than 1 transmissions = transmissionLength transmission [transmissions] transmissionLength = 2*2 OCTET ; word16 encoded in network byte order + +transmission = authorization authorized +authorized = sessionIdentifier corrId entityId smpCommand +corrId = %x18 24*24 OCTET / %x0 "" + ; corrId is required in client commands and server responses, + ; it is empty (0-length) in server notifications. + ; %x18 is 24 - the random correlation ID must be 24 bytes as it is used as a nonce for NaCL crypto_box in some contexts. +entityId = shortString ; queueId or proxySessionId + ; empty entityId ID is used with "create" command and in some server responses +authorization = shortString ; signature or authenticator + ; empty authorization can be used with "send" before the queue is secured with secure command + ; authorization is always empty with "ping" and server responses +sessionIdentifier = "" ; +sessionIdentifierForAuth = shortString + ; sessionIdentifierForAuth MUST be included in authorized transmission body. + ; From v7 of SMP protocol but it is no longer used in the transmission to save space and fit more transmissions in the transport block. +shortString = length *OCTET ; length prefixed bytearray 0-255 bytes +length = 1*1 OCTET ``` ## SMP commands @@ -417,11 +454,16 @@ transmissionLength = 2*2 OCTET ; word16 encoded in network byte order Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a]. ```abnf -smpCommand = ping / recipientCmd / send / subscribeNotifications / serverMsg -recipientCmd = create / subscribe / secure / enableNotifications / disableNotifications / - acknowledge / suspend / delete +smpCommand = ping / recipientCmd / senderCommand / + proxyCommand / subscribeNotifications / serverMsg +recipientCmd = create / subscribe / rcvSecure / + enableNotifications / disableNotifications / getMessage + acknowledge / suspend / delete / getQueueInfo +senderCommand = send / sndSecure +proxyCommand = proxySession / proxyCommand / relayCommand serverMsg = queueIds / message / notifierId / messageNotification / - unsubscribed / ok / error + proxySessionKey / proxyResponse / relayResponse + unsubscribed / queueInfo/ ok / error ``` The syntax of specific commands and responses is defined below. @@ -432,9 +474,9 @@ The server should send `queueIds`, `error` and `ok` responses in the same order If the transport connection is closed before some responses are sent, these responses should be discarded. -### Command authentication +### Command verification -SMP servers must authenticate all transmissions (excluding `ping` and initial `send` commands) by verifying the client signatures. Command signature should be generated by applying the algorithm specified for the queue to the `signed` block of the transmission, using the key associated with the queue ID (recipient's, sender's or notifier's, depending on which queue ID is used). +SMP servers must verify all transmissions (excluding `ping` and initial `send` commands) by verifying the client authorizations. Command authorization should be generated by applying the algorithm specified for the queue to the `signed` block of the transmission, using the key associated with the queue ID (recipient's, sender's or notifier's, depending on which queue ID is used). ### Keep-alive command @@ -452,37 +494,42 @@ Sending any of the commands in this section (other than `create`, that is sent w #### Create queue command -This command is sent by the recipient to the SMP server to create a new queue. The syntax is: +This command is sent by the recipient to the SMP server to create a new queue. + +Servers SHOULD support basic auth with this command, to allow only server owners and trusted users to create queues on the destiation servers. + +The syntax is: ```abnf -create = %s"NEW " recipientSignaturePublicKey recipientDhPublicKey -recipientSignaturePublicKey = length x509encoded -; the recipient's Ed25519 or Ed448 public key to verify commands for this queue - +create = %s"NEW " recipientAuthPublicKey recipientDhPublicKey basicAuth subscribe sndSecure +recipientAuthPublicKey = length x509encoded +; the recipient's Ed25519 or X25519 public key to verify commands for this queue recipientDhPublicKey = length x509encoded ; the recipient's Curve25519 key for DH exchange to derive the secret ; that the server will use to encrypt delivered message bodies ; using [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305). +basicAuth = "0" / "1" shortString ; server password +subscribeMode = %s"S" / %s"C" ; S - create and subscribe, C - only create +sndSecure = %s"T" / %s"F" ; T - sender can secure the queue, from v9 x509encoded = - length = 1*1 OCTET ``` -If the queue is created successfully, the server must send `queueIds` response with the recipient's and sender's queue IDs and public keys to sign all responses and messages and to encrypt delivered message bodies: +If the queue is created successfully, the server must send `queueIds` response with the recipient's and sender's queue IDs and public key to encrypt delivered message bodies: ```abnf -queueIds = %s"IDS " recipientId senderId srvDhPublicKey +queueIds = %s"IDS " recipientId senderId srvDhPublicKey sndSecure serverDhPublicKey = length x509encoded ; the server's Curve25519 key for DH exchange to derive the secret ; that the server will use to encrypt delivered message bodies to the recipient -recipientId = length *OCTET ; 16-24 bytes -senderId = length *OCTET ; 16-24 bytes +recipientId = shortString ; 16-24 bytes +senderId = shortString ; 16-24 bytes ``` -Once the queue is created, the recipient gets automatically subscribed to receive the messages from that queue, until the transport connection is closed. The `subscribe` command is needed only to start receiving the messages from the existing queue when the new transport connection is opened. +Once the queue is created, depending on `subscribeMode` parameter of `NEW` command the recipient gets automatically subscribed to receive the messages from that queue, until the transport connection is closed. To start receiving the messages from the existing queue when the new transport connection is opened the client must use `subscribe` command. -`NEW` transmission MUST be signed using the private part of the `recipientSignaturePublicKey` – this verifies that the client has the private key that will be used to sign subsequent commands for this queue. +`NEW` transmission MUST be authorized using the private part of the `recipientAuthPublicKey` – this verifies that the client has the private key that will be used to authorize subsequent commands for this queue. `IDS` response transmission MUST be sent with empty queue ID (the third part of the transmission). @@ -500,19 +547,23 @@ The first message will be delivered either immediately or as soon as it is avail This transmission and its response MUST be signed. -#### Secure queue command +#### Secure queue by recipient + +This command is only used until v8 of SMP protocol. V9 uses [SKEY](#secure-queue-by-sender). This command is sent by the recipient to the server to add sender's key to the queue: ```abnf -secure = %s"KEY " senderSignaturePublicKey -senderSignaturePublicKey = length x509encoded -; the sender's Ed25519 or Ed448 key to verify SEND commands for this queue +rcvSecure = %s"KEY " senderAuthPublicKey +senderAuthPublicKey = length x509encoded +; the sender's Ed25519 or X25519 key to verify SEND commands for this queue ``` `senderKey` is received from the sender as part of the first message - see [Send Message](#send-message) command. -Once the queue is secured only signed messages can be sent to it. +Once the queue is secured only authorized messages can be sent to it. + +This command MUST be used in transmission with recipient queue ID. #### Enable notifications command @@ -521,7 +572,7 @@ This command is sent by the recipient to the server to add notifier's key to the ```abnf enableNotifications = %s"NKEY " notifierKey recipientNotificationDhPublicKey notifierKey = length x509encoded -; the notifier's Ed25519 or Ed448 public key public key to verify NSUB command for this queue +; the notifier's Ed25519 or X25519 public key to verify NSUB command for this queue recipientNotificationDhPublicKey = length x509encoded ; the recipient's Curve25519 key for DH exchange to derive the secret @@ -533,7 +584,7 @@ The server will respond with `notifierId` response if notifications were enabled ```abnf notifierId = %s"NID " notifierId srvNotificationDhPublicKey -notifierId = length *OCTET ; 16-24 bytes +notifierId = shortString ; 16-24 bytes srvNotificationDhPublicKey = length x509encoded ; the server's Curve25519 key for DH exchange to derive the secret ; that the server will use to encrypt notification metadata to the recipient (encryptedNMsgMeta in NMSG) @@ -555,17 +606,30 @@ The server must respond `ok` to this command if it was successful. Once notifier's credentials are removed server will no longer send "NMSG" for this queue to notifier. +#### Get message command + +The client can use this command to receive one message without subscribing to the queue. This command is used when processing push notifications. + +The client MUST NOT use `SUB` and `GET` command on the same queue in the same transport connection - doing so would create an error. + +```abnf +getMessage = %s"GET" +``` + #### Acknowledge message delivery The recipient should send the acknowledgement of message delivery once the message was stored in the client, to notify the server that the message should be deleted: ```abnf -acknowledge = %s"ACK" +acknowledge = %s"ACK" SP msgId +msgId = shortString ``` -Even if acknowledgement is not sent by the recipient, the server should limit the time of message storage, whether it was delivered to the recipient or not. +Client must send message ID to acknowledge a particular message - to prevent double acknowledgement (e.g., when command response times out) resulting in message being lost. If the message was not delivered or if the ID of the message does not match the last delivered message, the server SHOULD respond with `ERR NO_MSG` error. -Having received the acknowledgement, SMP server should immediately delete the message and then send the next available message or respond with `ok` if there are no more messages available in this simplex queue. +The server should limit the time the message is stored, even if the message was not delivered or if acknowledgement is not sent by the recipient. + +Having received the acknowledgement, SMP server should delete the message and then send the next available message or respond with `ok` if there are no more messages available in this simplex queue. #### Suspend queue @@ -593,10 +657,67 @@ All undelivered messages must be deleted as soon as this command is received, be delete = %s"DEL" ``` +#### Get queue state + +This command is used by the queue recipient to get the debugging information about the current state of the queue. + +The response to that command is `INFO`. + +```abnf +getQueueInfo = %s"QUE" +queueInfo = %s"INFO " info +info = +``` + +The format of queue information is implementation specific, and is not part of the specification. For information, [JTD schema][17] for queue information returned by the reference implementation of SMP server is: + +```json +{ + "properties": { + "qiSnd": {"type": "boolean"}, + "qiNtf": {"type": "boolean"}, + "qiSize": {"type": "uint16"} + }, + "optionalProperties": { + "qiSub": { + "properties": { + "qSubThread": {"enum": ["noSub", "subPending", "subThread", "prohibitSub"]} + }, + "optionalProperties": { + "qDelivered": {"type": "string", "metadata": {"description": "message ID"}} + } + }, + "qiMsg": { + "properties": { + "msgId": {"type": "string"}, + "msgTs": {"type": "timestamp"}, + "msgType": {"enum": ["message", "quota"]} + } + } + } +} +``` + ### Sender commands Currently SMP defines only one command that can be used by senders - `send` message. This command must be used with sender's ID, if recipient's ID is used the server must respond with `"ERR AUTH"` response (see [Error responses](#error-responses)). +#### Secure queue by sender + +This command is used from v8 of SMP protocol. V8 and earlier uses [KEY](#secure-queue-by-recipient). + +This command is sent by the sender to the server to add sender's key to the queue: + +```abnf +sndSecure = %s"SKEY " senderAuthPublicKey +senderAuthPublicKey = length x509encoded +; the sender's Ed25519 or X25519 key to verify SEND commands for this queue +``` + +Once the queue is secured only authorized messages can be sent to it. + +This command MUST be used in transmission with sender queue ID. + #### Send message This command is sent to the server by the sender both to confirm the queue after the sender received out-of-band message from the recipient and to send messages after the queue is secured: @@ -605,64 +726,79 @@ This command is sent to the server by the sender both to confirm the queue after send = %s"SEND " msgFlags SP smpEncMessage msgFlags = notificationFlag reserved notificationFlag = %s"T" / %s"F" -smpEncMessage = smpPubHeader sentMsgBody ; message up to 16088 bytes -smpPubHeader = smpClientVersion ("1" senderPublicDhKey / "0") -smpClientVersion = word16 +smpEncMessage = smpEncClientMessage / smpEncConfirmation ; message up to 16064 bytes + +smpEncClientMessage = smpPubHeaderNoKey msgNonce sentClientMsgBody ; message up to 16064 bytes +smpPubHeaderNoKey = smpClientVersion "0" +sentClientMsgBody = 16016*16016 OCTET + +smpEncConfirmation = smpPubHeaderWithKey msgNonce sentConfirmationBody +smpPubHeaderWithKey = smpClientVersion "1" senderPublicDhKey + ; sender's Curve25519 public key to agree DH secret for E2E encryption in this queue + ; it is only sent in confirmation message +sentConfirmationBody = 15920*15920 OCTET ; E2E-encrypted smpClientMessage padded to 16016 bytes before encryption senderPublicDhKey = length x509encoded -; sender's Curve25519 public key to agree DH secret for E2E encryption in this queue -; it is only sent in confirmation message + +smpClientVersion = word16 x509encoded = -sentMsgBody = 16032*16032 OCTET -; E2E-encrypted smpClientMessage padded to 16032 bytes before encryption +msgNonce = 24*24 OCTET word16 = 2*2 OCTET ``` -The first message is sent to confirm the queue - it should contain sender's server key (see decrypted message syntax below) - this first message must be sent without signature. +The first message is sent to confirm the queue - it should contain sender's server key (see decrypted message syntax below) - this first message may be sent without authorization. -Once the queue is secured (see [Secure queue command](#secure-queue-command)), the following send commands must be sent with the signature. +Once the queue is secured (see [Secure queue by sender](#secure-queue-by-sender)), the subsequent `SEND` commands must be sent with the authorization. The server must respond with `"ERR AUTH"` response in the following cases: - the queue does not exist or is suspended -- the queue is secured but the transmission does NOT have a signature -- the queue is NOT secured but the transmission has a signature +- the queue is secured but the transmission does NOT have a authorization +- the queue is NOT secured but the transmission has a authorization -Until the queue is secured, the server should accept any number of unsigned messages - it both enables the legitimate sender to resend the confirmation in case of failure and also allows the simplex messaging client to ignore any confirmation messages that may be sent by the attackers (assuming they could have intercepted the queue ID in the server response, but do not have a correct encryption key passed to sender in out-of-band message). +The server must respond with `"ERR QUOTA"` response when queue capacity is exceeded. The number of messages that the server can hold is defined by the server configuration. When sender reaches queue capacity the server will not accept any further messages until the recipient receives ALL messages from the queue. After the last message is delivered, the server will deliver an additional special message indicating that the queue capacity was reached. See [Deliver queue message](#deliver-queue-message) -The body should be encrypted with the recipient's "public" key (`EK`); once decrypted it must have this format: +Until the queue is secured, the server should accept any number of unsigned messages (up to queue capacity) - it allows the sender to resend the confirmation in case of failure. + +The body should be encrypted with the shared secret based on recipient's "public" key (`EK`); once decrypted it must have this format: ```abnf -sentMsgBody = -smpClientMessage = smpPrivHeader clientMsgBody -smpPrivHeader = emptyHeader / smpConfirmationHeader -emptyHeader = " " -smpConfirmationHeader = %s"K" senderKey +sentClientMsgBody = +smpClientMessage = emptyHeader clientMsgBody +emptyHeader = "_" +clientMsgBody = *OCTET ; up to 16016 - 2 + +sentConfirmationBody = +smpConfirmation = smpConfirmationHeader confirmationBody +smpConfirmationHeader = emptyHeader / %s"K" senderKey + ; emptyHeader is used when queue is already secured by sender +confirmationBody = *OCTET ; up to 15920 - 2 senderKey = length x509encoded -; the sender's Ed25519 or Ed448 public key to sign SEND commands for this queue -clientMsgBody = *OCTET ; up to 16016 in case of emptyHeader + ; the sender's Ed25519 or X25519 public key to authorize SEND commands for this queue ``` `clientHeader` in the initial unsigned message is used to transmit sender's server key and can be used in the future revisions of SMP protocol for other purposes. -SMP transmission structure for sent messages: +SMP transmission structure for directly sent messages: ``` -------- transmission (= 16384 bytes) +------- transmissions (= 16384 bytes) + 1 | transmission count (= 1) 2 | originalLength - 276- | signature sessionId corrId queueId %s"SEND" SP (1+114 + 1+32? + 1+32 + 1+24 + 4+1 = 210) - ....... smpEncMessage (= 16088 bytes = 16384 - 296 bytes) + 299- | authorization sessionId corrId queueId %s"SEND" SP (1+114 + 1+32? + 1+24 + 1+24 + 4+1 = 203) + ....... smpEncMessage (= 16064 bytes = 16384 - 320 bytes) 8- | smpPubHeader (for messages it is only version and '0' to mean "no DH key" = 3 bytes) 24 | nonce for smpClientMessage 16 | auth tag for smpClientMessage - ------- smpClientMessage (E2E encrypted, = 16032 bytes = 16088 - 48) + ------- smpClientMessage (E2E encrypted, = 16016 bytes = 16064 - 48) 2 | originalLength - 12- | smpPrivHeader + 2- | smpPrivHeader ....... - | clientMsgBody (<= 16016 bytes = 16032 - 14) + | clientMsgBody (<= 16012 bytes = 16016 - 4) ....... 0+ | smpClientMessage pad ------- smpClientMessage end | + 0+ | message pad ....... smpEncMessage end 18+ | transmission pad ------- transmission end @@ -671,20 +807,23 @@ SMP transmission structure for sent messages: SMP transmission structure for received messages: ``` -------- transmission (= 16384 bytes) +------- transmissions (= 16384 bytes) + 1 | transmission count (= 1) 2 | originalLength - 276- | signature sessionId corrId queueId %s"MSG" SP msgId timestamp (1+114 + 1+32? + 1+32 + 1+24 + 3+1 + 24+1 + 8 = 243) + 283- | authorization sessionId corrId queueId %s"MSG" SP msgId (1+114 + 1+32? + 1+24 + 1+24 + 3+1 + 1+24 = 227) 16 | auth tag (msgId is used as nonce) - ------- serverEncryptedMsg (= 16090 bytes = 16384 - 294 bytes) + ------- serverEncryptedMsg (= 16082 bytes = 16384 - 302 bytes) 2 | originalLength - ....... smpEncMessage (= 16088 bytes = 16090 - 2 bytes) - 16- | smpPubHeader (empty header for the message) + 8 | timestamp + 8- | message flags + ....... smpEncMessage (= 16064 bytes = 16082 - 18 bytes) + 8- | smpPubHeader (empty header for the message) 24 | nonce for smpClientMessage 16 | auth tag for smpClientMessage - ------- smpClientMessage (E2E encrypted, = 16032 bytes = 16088 - 56 bytes) + ------- smpClientMessage (E2E encrypted, = 16016 bytes = 16064 - 48 bytes) 2 | originalLength - 16- | smpPrivHeader (empty header for the message) - ....... clientMsgBody (<= 16016 bytes = 16032 - 16) + 2- | smpPrivHeader (empty header for the message) + ....... clientMsgBody (<= 16012 bytes = 16016 - 4) -- TODO move internal structure (below) to agent protocol 20- | agentPublicHeader (the size is for user messages post handshake, without E2E X3DH keys - it is version and 'M' for the messages - 3 bytes in total) ....... E2E double-ratchet encrypted (<= 15996 bytes = 16016 - 20) @@ -719,6 +858,149 @@ SMP transmission structure for received messages: ------- transmission end ``` +### Proxying sender commands + +To protect transport (IP address and session) anonymity of the sender from the server chosen (and, potentially, controlled) by the recipient SMP v8 added support for proxying sender's command to the recipient's server via the server chosen by the sender. + +Sequence diagram for sending the message and `SKEY` commands via SMP proxy: + +``` +------------- ------------- ------------- ------------- +| sending | | SMP | | SMP | | receiving | +| client | | proxy | | server | | client | +------------- ------------- ------------- ------------- + | `PRXY` | | | + | -------------------------> | | | + | | ------------------------------> | | + | | SMP handshake | | + | | <------------------------------ | | + | `PKEY` | | | + | <------------------------- | | | + | | | | + | `PFWD` (s2r) | | | + | -------------------------> | | | + | | `RFWD` (p2r) | | + | | ------------------------------> | | + | | `RRES` (p2r) | | + | | <------------------------------ | | + | `PRES` (s2r) | | `MSG` | + | <------------------------- | | -----------------------> | + | | | `ACK` | + | | | <----------------------- | + | | | | + | | | | +``` + +1. The client requests (`PRXY` command) the chosen server to connect to the destination SMP server and receives (`PKEY` response) the session information, including server certificate and the session key signed by this certificate. To protect client session anonymity the proxy MUST re-use the same session with all clients that request connection with any given destination server. + +2. The client encrypts the transmission (`SKEY` or `SEND`) to the destination server using the shared secret computed from per-command random key and server's session key and sends it to proxying server in `PFWD` command. + +3. Proxy additionally encrypts the body to prevent correlation by ciphertext (in case TLS is compromised) and forwards it to proxy in `RFWD` command. + +4. Proxy receives the double-encrypted response from the destination server, removes one encryption layer and forwards it to the client. + +The diagram below shows the encryption layers for `PFWD`/`RFWD` commands and `RRES`/`PRES` responses: + +- s2r - encryption between client and SMP relay, with relay key returned in relay handshake, with MITM by proxy mitigated by verifying the certificate fingerprint included in the relay address. This encryption prevents proxy server from observing commands and responses - proxy does not know how many different queues a connected client sends messages and commands to. +- e2e - end-to-end encryption per SMP queue, with additional client encryption inside it. +- p2r - additional encryption between proxy and SMP relay with the shared secret agreed in the handshake, to mitigate traffic correlation inside TLS. +- r2c - additional encryption between SMP relay and client to prevent traffic correlation inside TLS. + +``` +----------------- ----------------- -- TLS -- ----------------- ----------------- +| | -- TLS -- | | -- p2r -- | | -- TLS -- | | +| | -- s2r -- | | -- s2r -- | | -- r2c -- | | +| sending | -- e2e -- | | -- e2e -- | | -- e2e -- | receiving | +| client | MSG | SMP proxy | MSG | SMP server | MSG | client | +| | -- e2e -- | | -- e2e -- | | -- e2e -- | | +| | -- s2r -- | | -- s2r -- | | -- r2c -- | | +| | -- TLS -- | | -- p2r -- | | -- TLS -- | | +----------------- ----------------- -- TLS -- ----------------- ----------------- +``` + +SMP proxy is not another type of the server, it is a role that any SMP server can play when forwarding the commands. + +#### Request proxied session + +The sender uses this command to request the session with the destination proxy. + +Servers SHOULD support basic auth with this command, to allow only server owners and trusted users to proxy commands to the destination servers. + +```abnf +proxySession = %s"PRXY" SP smpServer basicAuth +smpServer = hosts port fingerprint +hosts = length 1*host +host = shortString +port = shortString +fingerprint = shortString +basicAuth = "0" / "1" shortString ; server password +``` + +```abnf +proxySessionKey = %s"PKEY" SP sessionId smpVersionRange certChain signedKey +sessionId = shortString + ; Session ID (tlsunique) of the proxy with the destination server. + ; This session ID should be used as entity ID in transmission with `PFWD` command +certChain = length 1*cert +cert = originalLength x509encoded +signedKey = originalLength x509encoded ; key signed with certificate +originalLength = 2*2 OCTET +``` + +When the client receives PKEY response it MUST validate that: +- the fingerprint of the received certificate matches fingerprint in the server address - it mitigates MITM attack by proxy. +- the server session key is correctly signed with the received certificate. + +The proxy server may respond with error response in case the destination server is not available or in case it has an earlier version that does not support proxied commands. + +#### Send command via proxy + +Sender can send `SKEY` and `SEND` commands via proxy after obtaining the session ID with `PRXY` command (see [Request proxied session](#request-proxied-session)). + +Transmission sent to proxy server should use session ID as entity ID and use a random correlation ID of 24 bytes as a nonce for crypto_box encryption of transmission to the destination server. The random ephemeral X25519 key to encrypt transmission should be unique per command, and it should be combined with the key sent by the server in the handshake header to proxy and to the client in `PKEY` command. + +Encrypted transmission should use the received session ID from the connection between proxy server and destination server in the authorized body. + +```abnf +proxyCommand = %s"PFWD" SP smpVersion commandKey +smpVersion = 2*2 OCTET +commandKey = length x509encoded +``` + +The proxy server will forward the encrypted transmission in `RFWD` command (see below). + +Having received the `RRES` response from the destination server, proxy server will forward `PRES` response to the client. `PRES` response should use the same correlation ID as `PFWD` command. The destination server will use this correlation ID increased by 1 as a nonce for encryption of the response. + +```abnf +proxyResponse = %s"PRES" SP +``` + +#### Forward command to destination server + +Having received `PFWD` command from the client, the server should additionally encrypt it (without padding, as the received transmission is already encrypted by the client and padded to a fixed size) together with the correlation ID, sender command key, and protocol version, and forward it to the destination server as `RFWD` command: + +Transmission forwarded to relay uses empty entity ID and its unique random correlation ID is used as a nonce to encrypt forwarded transmission. Correlation ID increased by 1 is used by the destination server as a nonce to encrypt responses. + +```abnf +relayCommand = %s"RFWD" SP +forwardedTransmission = fwdCorrId fwdSmpVersion fwdCommandKey transmission +fwdCorrId = length 24*24 OCTET + ; `fwdCorrId` - correlation ID used in `PFWD` command transmission - it is used as a nonce for client encryption, + ; and `fwdCorrId + 1` is used as a nonce for the destination server response encryption. +fwdSmpVersion = 2*2 OCTET +fwdCommandKey = length x509encoded +transmission = *OCTET ; note that it is not prefixed with the length +``` + +The destination server having received this command decrypts both encryption layers (proxy and client), verifies client authorization as usual, processes it, and send the double encrypted `RRES` response to proxy. + +The shared secret for encrypting transmission bodies between proxy server and destination server is agreed from proxy and destination server keys exchanged in handshake headers - proxy and server use the same shared secret during the session for the encryption between them. + + +```abnf +relayResponse = %s"RRES" SP +``` + ### Notifier commands #### Subscribe to queue notifications @@ -735,45 +1017,40 @@ The first message notification will be delivered either immediately or as soon a ### Server messages -#### Queue IDs response +This section includes server events and generic command responses used for several commands. -Server must respond with this message when the new queue is created. - -See its syntax in [Create queue command](#create-queue-command) +The syntax for command-specific responses is shown together with the commands. #### Deliver queue message -The server must deliver messages to all subscribed simplex queues on the currently open transport connection. The syntax for the message delivery is: - -```abnf -message = %s"MSG " msgId encryptedRcvMsgBody -encryptedMsgBody = ; server-encrypted padded sent msgBody -paddedSentMsgBody = ; maxMessageLength = 16088 -encryptedRcvMsgBody = ; server-encrypted meta-data and padded sent msgBody -rcvMsgBody = timestamp msgFlags SP paddedSentMsgBody -msgId = length 24*24OCTET -timestamp = 8*8OCTET -``` - -`msgId` - unique message ID generated by the server based on cryptographically strong random bytes. It should be used by the clients to detect messages that were delivered more than once (in case the transport connection was interrupted and the server did not receive the message delivery acknowledgement). Message ID is used as a nonce for server/recipient encryption of message bodies. - -`timestamp` - system time when the server received the message from the sender as **a number of seconds** since Unix epoch (1970-01-01) encoded as 64-bit integer in network byte order. If a client system/language does not support 64-bit integers, until 2106 it is safe to simply skip the first 4 zero bytes and decode 32-bit unsigned integer (or as signed integer until 2038). - -`paddedSentMsgBody` - see syntax in [Send message](#send-message) - When server delivers the messages to the recipient, message body should be encrypted with the secret derived from DH exchange using the keys passed during the queue creation and returned with `queueIds` response. This is done to prevent the possibility of correlation of incoming and outgoing traffic of SMP server inside transport protocol. -#### Notifier queue ID response +The server must deliver messages to all subscribed simplex queues on the currently open transport connection. The syntax for the message delivery is: -Server must respond with this message when queue notifications are enabled. +```abnf +message = %s"MSG" SP msgId encryptedRcvMsgBody +encryptedRcvMsgBody = + ; server-encrypted padded sent msgBody + ; maxMessageLength = 16064 +rcvMsgBody = timestamp msgFlags SP sentMsgBody / msgQuotaExceeded +msgQuotaExceeded = %s"QUOTA" SP timestamp +msgId = length 24*24OCTET +timestamp = 8*8OCTET +``` -See its syntax in [Enable notifications command](#enable-notifications-command) +If the sender exceeded queue capacity the recipient will receive a special message indicating the quota was exceeded. This can be used in the higher level protocol to notify sender client that it can continue sending messages. + +`msgId` - unique message ID generated by the server based on cryptographically strong random bytes. It should be used by the clients to detect messages that were delivered more than once (in case the transport connection was interrupted and the server did not receive the message delivery acknowledgement). Message ID is used as a nonce for server/recipient encryption of message bodies. + +`timestamp` - system time when the server received the message from the sender as **a number of seconds** since Unix epoch (1970-01-01) encoded as 64-bit integer in network byte order. If a client system/language does not support 64-bit integers, until 2106 it is safe to simply skip the first 4 zero bytes and decode 32-bit unsigned integer (or as signed integer until 2038). + +`sentMsgBody` - message sent by `SEND` command. See [Send message](#send-message). #### Deliver message notification -The server must deliver message notifications to all simplex queues that were subscribed with `subscribeNotifications` command ("NSUB") on the currently open transport connection. The syntax for the message notification delivery is: +The server must deliver message notifications to all simplex queues that were subscribed with `subscribeNotifications` command (`NSUB`) on the currently open transport connection. The syntax for the message notification delivery is: ```abnf messageNotification = %s"NMSG " nmsgNonce encryptedNMsgMeta @@ -802,28 +1079,60 @@ No further messages should be delivered to unsubscribed transport connection. #### Error responses -- incorrect block format, encoding or signature size (`BLOCK`). +- incorrect block format, encoding or authorization size (`BLOCK`). - missing or different session ID - tls-unique binding of TLS transport (`SESSION`) - command errors (`CMD`): - - error parsing command (`SYNTAX`) - - prohibited command (`PROHIBITED`) - any server response sent from client or `ACK` sent without active subscription or without message delivery. - - transmission has no required signature or queue ID (`NO_AUTH`) + - unknown command (`UNKNOWN`). + - error parsing command (`SYNTAX`). + - prohibited command (`PROHIBITED`): + - `ACK` sent without active subscription or without message delivery. + - `GET` and `SUB` used in the same transport connection with the same queue. + - transmission has no required authorization or queue ID (`NO_AUTH`) - transmission has unexpected credentials (`HAS_AUTH`) - - transmission has no required queue ID (`NO_QUEUE`) -- authentication error (`AUTH`) - incorrect signature, unknown (or suspended) queue, sender's ID is used in place of recipient's and vice versa, and some other cases (see [Send message](#send-message) command). + - transmission has no required queue ID (`NO_ENTITY`) +- proxy server errors (`PROXY`): + - `PROTOCOL` - any error. + - `BASIC_AUTH` - incorrect basic auth. + - `NO_SESSION` - no destination server session with passed ID. + - `BROKER` - destination server error: + - `RESPONSE` - invalid server response (failed to parse). + - `UNEXPECTED` - unexpected response. + - `NETWORK` - network error. + - `TIMEOUT` - command response timeout. + - `HOST` - no compatible server host (e.g. onion when public is required, or vice versa) + - `TRANSPORT` - handshake or other transport error: + - `BLOCK` - error parsing transport block. + - `VERSION` - incompatible client or server version. + - `LARGE_MSG` - message too large. + - `SESSION` - incorrect session ID. + - `NO_AUTH` - absent server key - when the server did not provide a DH key to authorize commands for the queue that should be authorized with a DH key. + - `HANDSHAKE` - transport handshake error: + - `PARSE` - handshake syntax (parsing) error. + - `IDENTITY` - incorrect server identity (certificate fingerprint does not match server address). + - `BAD_AUTH` - incorrect or missing server credentials in handshake. +- authentication error (`AUTH`) - incorrect authorization, unknown (or suspended) queue, sender's ID is used in place of recipient's and vice versa, and some other cases (see [Send message](#send-message) command). - message queue quota exceeded error (`QUOTA`) - too many messages were sent to the message queue. Further messages can only be sent after the recipient retrieves the messages. -- sent message is too large (> 16088) to be delivered (`LARGE_MSG`). +- sent message is too large (> 16064) to be delivered (`LARGE_MSG`). - internal server error (`INTERNAL`). The syntax for error responses: ```abnf error = %s"ERR " errorType -errorType = %s"BLOCK" / %s"SESSION" / %s"CMD " cmdError / %s"AUTH" / %s"LARGE_MSG" /%s"INTERNAL" +errorType = %s"BLOCK" / %s"SESSION" / %s"CMD" SP cmdError / %s"PROXY" proxyError / + %s"AUTH" / %s"QUOTA" / %s"LARGE_MSG" / %s"INTERNAL" cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_ENTITY" +proxyError = %s"PROTOCOL" SP errorType / %s"BROKER" SP brokerError / + %s"BASIC_AUTH" / %s"NO_SESSION" +brokerError = %s"RESPONSE" SP shortString / %s"UNEXPECTED" SP shortString / + %s"NETWORK" / %s"TIMEOUT" / %s"HOST" / + %s"TRANSPORT" SP transportError +transportError = %s"BLOCK" / %s"VERSION" / %s"LARGE_MSG" / %s"SESSION" / %s"NO_AUTH" / + %s"HANDSHAKE" SP handshakeError +handshakeError = %s"PARSE" / %s"IDENTITY" / %s"BAD_AUTH" ``` -Server implementations must aim to respond within the same time for each command in all cases when `"ERR AUTH"` response is required to prevent timing attacks (e.g., the server should perform signature verification even when the queue does not exist on the server or the signature of different size is sent, using any RSA key with the same size as the signature size). +Server implementations must aim to respond within the same time for each command in all cases when `"ERR AUTH"` response is required to prevent timing attacks (e.g., the server should verify authorization even when the queue does not exist on the server or the authorization of different type is sent, using any dummy key compatible with the used authorization). ### OK response @@ -833,22 +1142,12 @@ When the command is successfully executed by the server, it should respond with ok = %s"OK" ``` -## Appendices +## Transport connection with the SMP server -### Appendix A. - -**SMP transport protocol.** +### General transport protocol considerations Both the recipient and the sender can use TCP or some other, possibly higher level, transport protocol to communicate with the server. The default TCP port for SMP server is 5223. -For scenarios when meta-data privacy is critical, it is recommended that clients: - -- communicating over Tor network, -- establish a separate connection for each SMP queue, -- send noise traffic (using PING command). - -In addition to that, the servers can be deployed as Tor onion services. - The transport protocol should provide the following: - server authentication (by matching server certificate hash with `serverIdentity`), @@ -856,40 +1155,110 @@ The transport protocol should provide the following: - integrity (preventing data modification by the attacker without detection), - unique channel binding (`sessionIdentifier`) to include in the signed part of SMP transmissions. -By default, the client and server communicate using [TLS 1.3 protocol][13] restricted to: +### TLS transport encryption + +The client and server communicate using [TLS 1.3 protocol][13] restricted to: - TLS_CHACHA20_POLY1305_SHA256 cipher suite (for better performance on mobile devices), -- ed25519 and ed448 EdDSA algorithms for signatures, -- x25519 and x448 ECDHE groups for key exchange. -- servers must send the chain of exactly 2 self-signed certificates in the handshake, with the first (offline) certificate one signing the second (online) certificate. Offline certificate fingerprint is used as a server identity - it is a part of SMP server address. +- ed25519 EdDSA algorithms for signatures, +- x25519 ECDHE groups for key exchange. +- servers must send the chain of 2, 3 or 4 self-signed certificates in the handshake (see [Server certificate](#server-certificate)), with the first (offline) certificate one signing the second (online) certificate. Offline certificate fingerprint is used as a server identity - it is a part of SMP server address. - The clients must abort the connection in case a different number of certificates is sent. - server and client TLS configuration should not allow resuming the sessions. During TLS handshake the client must validate that the fingerprint of the online server certificate is equal to the `serverIdentity` the client received as part of SMP server address; if the server identity does not match the client must abort the connection. +### Server certificate + +Servers use self-signed certificates that the clients validate by comparing the fingerprint of one of the certificates in the chain with the certificate fingerprint present in the server address. + +Clients SHOULD support the chains of 2, 3 and 4 server certificates: + +**2 certificates**: +1. offline server certificate: + - its fingerprint is present in the server address. + - its private key is not stored on the server. +2. online server certificate: + - it must be signed by offline certificate. + - its private key is stored on the server and is used in TLS session. + +**3 certificates**: +1. offline server certificate - same as with 2 certificates. +2. online server certificate: + - it must be signed by offline certificate. + - its private key is stored on the server. +3. session certificate: + - generated automatically on every server start and/or on schedule. + - signed by online server certificate. + - its private key is used in TLS session. + +**4 certificates**: +0. offline operator identity certificate: + - used for all servers operated by the same entity. + - its private key is not stored on the server. +1. offline server certificate: + - signed by offline operator certificate. + - same as with 2 certificates. +2. online server certificate - same as with 3 certificates. +3. session certificate - same as with 3 certificates. + +### ALPN to agree handshake version + +Client and server use [ALPN extension][18] of TLS to agree handshake version. + +Server SHOULD send `smp/1` protocol name and the client should confirm this name in order to use the current protocol version. This is added to allow support of older clients without breaking backward compatibility and to extend or modify handshake syntax. + +If the client does not confirm this protocol name, the server would fall back to v6 of SMP protocol. + +### Transport handshake + Once TLS handshake is complete, client and server will exchange blocks of fixed size (16384 bytes). -The first block sent by the server should be `serverHello` and the client should respond with `clientHello` - these blocks are used to agree SMP protocol version: +The first block sent by the server should be `paddedServerHello` and the client should respond with `paddedClientHello` - these blocks are used to agree SMP protocol version: ```abnf -serverHello = minSmpVersion maxSmpVersion sessionIdentifier pad +paddedServerHello = +serverHello = smpVersionRange sessionIdentifier [serverCert signedServerKey] ignoredPart +smpVersionRange = minSmpVersion maxSmpVersion minSmpVersion = smpVersion maxSmpVersion = smpVersion -sessionIdentifier = length *OCTET +sessionIdentifier = shortString ; unique session identifier derived from transport connection handshake -; it should be included in all SMP transmissions sent in this transport connection. +; it should be included in authorized part of all SMP transmissions sent in this transport connection, +; but it must not be sent as part of the transmission in the current protocol version. +serverCert = originalLength x509encoded +signedServerKey = originalLength x509encoded ; signed by server certificate -clientHello = smpVersion pad +paddedClientHello = +clientHello = smpVersion [clientKey] ignoredPart ; chosen SMP protocol version - it must be the maximum supported version ; within the range offered by the server +clientKey = length x509encoded smpVersion = 2*2OCTET ; Word16 version number - +originalLength = 2*2OCTET +ignoredPart = *OCTET pad = *OCTET ``` +`signedServerKey` is used to compute a shared secret to authorize client transmission - it is combined with the per-queue key that was used when the queue was created. + +`clientKey` is used only by SMP proxy server when it connects to the destination server to agree shared secret for the additional encryption layer, end user clients do not use this key. + +`ignoredPart` in handshake allows to add additional parameters in handshake without changing protocol version - the client and servers must ignore any extra bytes within the original block length. + For TLS transport client should assert that `sessionIdentifier` is equal to `tls-unique` channel binding defined in [RFC 5929][14] (TLS Finished message struct); we pass it in `serverHello` block to allow communication over some other transport protocol (possibly, with another channel binding). +### Additional transport privacy + +For scenarios when meta-data privacy is critical, it is recommended that clients: + +- communicating over Tor network, +- establish a separate connection for each SMP queue, +- send noise traffic (using PING command). + +In addition to that, the servers can be deployed as Tor onion services. + [1]: https://en.wikipedia.org/wiki/Man-in-the-middle_attack [2]: https://en.wikipedia.org/wiki/End-to-end_encryption [3]: https://en.wikipedia.org/wiki/QR_code @@ -906,3 +1275,5 @@ For TLS transport client should assert that `sessionIdentifier` is equal to `tls [14]: https://datatracker.ietf.org/doc/html/rfc5929#section-3 [15]: https://www.rfc-editor.org/rfc/rfc8709.html [16]: https://nacl.cr.yp.to/box.html +[17]: https://datatracker.ietf.org/doc/html/rfc8927 +[18]: https://datatracker.ietf.org/doc/html/rfc7301 diff --git a/protocol/xftp.md b/protocol/xftp.md new file mode 100644 index 000000000..d6d271837 --- /dev/null +++ b/protocol/xftp.md @@ -0,0 +1,632 @@ +Version 2, 2024-06-22 + +# SimpleX File Transfer Protocol + +## Table of contents + +- [Abstract](#abstract) +- [Introduction](#introduction) +- [XFTP Model](#xftp-model) +- [Persistence model](#persistence-model) +- [XFTP procedure](#xftp-procedure) +- [File description](#file-description) +- [URIs syntax](#uris-syntax) + - [XFTP server URI](#xftp-server-uri) + - [File description URI](#file-description-URI) +- [XFTP qualities and features](#xftp-qualities-and-features) +- [Cryptographic algorithms](#cryptographic-algorithms) +- [File chunk IDs](#file-chunk-ids) +- [Server security requirements](#server-security-requirements) +- [Transport protocol](#transport-protocol) + - [TLS ALPN](#tls-alpn) + - [Connection handshake](#connection-handshake) + - [Requests and responses](#requests-and-responses) +- [XFTP commands](#xftp-commands) + - [Correlating responses with commands](#correlating-responses-with-commands) + - [Command authentication](#command-authentication) + - [Keep-alive command](#keep-alive-command) + - [File sender commands](#file-sender-commands) + - [Register new file chunk](#register-new-file-chunk) + - [Add file chunk recipients](#add-file-chunk-recipients) + - [Upload file chunk](#upload-file-chunk) + - [Delete file chunk](#delete-file-chunk) + - [File recipient commands](#file-recipient-commands) + - [Download file chunk](#download-file-chunk) + - [Acknowledge file chunk download](#acknowledge-file-chunk-download) +- [Threat model](#threat-model) + +## Abstract + +SimpleX File Transfer Protocol is a client-server protocol for asynchronous unidirectional file transmission. + +It's designed with the focus on communication security, integrity and meta-data privacy, under the assumption that any part of the message transmission network can be compromised. + +It is designed as a application level protocol to solve the problem of secure and private file transmission, making [MITM attacks][1] very difficult at any part of the file transmission system, and preserving meta-data privacy of the sent files. + +## Introduction + +The objective of SimpleX File Transfer Protocol (XFTP) is to facilitate the secure and private unidirectional transfer of files from senders to recipients via persistent file chunks stored by the xftp server. + +XFTP is implemented as an application level protocol on top of HTTP2 and TLS. + +The protocol describes the set of commands that senders and recipients can send to XFTP servers to create, upload, download and delete file chunks of several pre-defined sizes. XFTP servers SHOULD support chunks of 4 sizes: 64KB, 256KB, 1MB and 4MB (1KB = 1024 bytes, 1MB = 1024KB). + +The protocol is designed with the focus on meta-data privacy and security. While using TLS, the protocol does not rely on TLS security by using additional encryption to achieve that there are no identifiers or ciphertext in common in received and sent server traffic, frustrating traffic correlation even if TLS is compromised. + +XFTP does not use any form of participants' identities. It relies on out-of-band passing of "file description" - a human-readable YAML document with the list of file chunk locations, hashes and necessary cryptographic keys. + +## XFTP Model + +The XFTP model has three communication participants: the recipient, the file server (XFTP server) that is chosen and, possibly, controlled by the sender, and the sender. + +XFTP server allows uploading fixed size file chunks, with or without basic authentication. The same party that can be the sender of one file chunk can be the recipient of another, without exposing it to the server. + +Each file chunk allows multiple recipients, each recipient can download the same chunk multiple times. It allows depending on the threat model use the same recipient credentials for multiple parties, thus reducing server ability to understand the number of intended recipients (but server can still track IP addresses to determine it), or use one unique set of credentials for each recipient, frustrating traffic correlation on the assumption of compromised TLS. In the latter case, senders can create a larger number of recipient credentials to hide the actual number of intended recipients from the servers (which is what SimpleX clients do). + +``` + Sender Internet XFTP relays Internet Recipient +---------------------------- | ----------------- | ------------------- | ------------ | ---------- + | | | | + | | (can be self-hosted) | | + | | +---------+ | | + chunk 1 ----- HTTP2 over TLS ------ | XFTP | ---- HTTP2 / TLS ----- chunk 1 + |---> SimpleX File Transfer Protocol (XFTP) --> | Relay | ---> XFTP ------------->| + | --------------------------- +---------+ ---------------------- | + | | | | | | + | | | | | v + +----------+ | | +---------+ | | +-------------+ + | Sending | ch. 2 ------- HTTP2 / TLS ------- | XFTP | ---- HTTP2 / TLS ---- ch. 2 | Receiving | +file ---> | XFTP | ------> XFTP ----> | Relay | ---> XFTP ------> | XFTP | ---> file + | Client | --------------------------- +---------+ ---------------------- | Client | + +----------+ | | | | +-------------+ + | | | | | ^ + | | | +---------+ | | | + | ------- HTTP2 / TLS ------- | XFTP | ---- HTTP2 / TLS ---- | + |-------------> XFTP ----> | Relay | ---> XFTP ------------->| + chunk N --------------------------- +---------+ --------------------- chunk N + | | (store file chunks) | | + | | | | + | | | | +``` + +When sender client uploads a file chunk, it has to register it first with one sender ID and multiple recipient IDs, and one random unique key per ID to authenticate sender and recipients, and also provide its size and hash that will be validated when chunk is uploaded. + +To send the actual file, the sender client MUST pad it and encrypt it with a random symmetric key and distribute chunks of fixed sized across multiple XFTP servers. Information about chunk locations, keys, hashes and required keys is passed to the recipients as "[file description](#file-description)" out-of-band. + +Creating, uploading, downloading and deleting file chunks requires sending commands to the XFTP server - they are described in detail in [XFTP commands](#xftp-commands) section. + +## Persistence model + +Server stores file chunk records in memory, with optional adding to append-only log, to allow restoring them on server restart. File chunk bodies can be stored as files or as objects in any object store (e.g. S3). + +## XFTP procedure + +1. Sending the file. + +To send the file, the sender will: + +1) Prepare file + - compute its SHA512 digest. + - prepend header with the name and pad the file to match the whole number of chunks in size. It is RECOMMENDED to use 2 of 4 allowed chunk sizes, to balance upload size and metadata privacy. + - encrypt it with a randomly chosen symmetric key and IV (e.g., using NaCL secret_box). + - split into allowed size chunks. + - generate per-recipient keys. It is recommended that the sending client generates more per-recipient keys than the actual number of recipients, rounding up to a power of 2, to conceal the actual number of intended recipients. + +2) Upload file chunks + - register each chunk record with randomly chosen one or more (for redundancy) XFTP server(s). + - optionally request additional recipient IDs, if required number of recipient keys didn't fit into register request. + - upload each chunk to chosen server(s). + +3) Prepare file descriptions, one per recipient. + +The sending client combines addresses of all chunks and other information into "file description", different for each file recipient, that will include: + +- an encryption key used to encrypt/decrypt the full file (the same for all recipients). +- file SHA512 digest to validate download. +- list of chunk descriptions; information for each chunk: + - private Ed25519 key to sign commands for file transfer server. + - chunk address (server host and chunk ID). + - chunk sha512 digest. + +To reduce the size of file description, chunks are grouped by the server host. + +4) Send file description(s) to the recipient(s) out-of-band, via pre-existing secure and authenticated channel. E.g., SimpleX clients send it as messages via SMP protocol, but it can be done via any other channel. + +![Sending file](./diagrams/xftp/xftp-sending-file.svg) + +2. Receiving the file. + +Having received the description, the recipient will: + +1) Download all chunks. + +The receiving client can fall back to secondary servers, if necessary: +- if the server is not available. +- if the chunk is not present on the server (ERR AUTH response). +- if the hash of the downloaded file chunk does not match the description. + +Optionally recipient can acknowledge file chunk reception to delete file ID from server for this recipient. + +2) Combine the chunks into a file. + +3) Decrypt the file using the key in file description. + +4) Extract file name and unpad the file. + +5) Validate file digest with the file description. + +![Receiving file](./diagrams/xftp/xftp-receiving-file.svg) + +## File description + +"File description" is a human-readable YAML document that is sent via secure and authenticated channel. + +It includes these fields: +- `party` - "sender" or "recipient". Sender's file description is required to delete the file. +- `size` - padded file size equal to total size of all chunks, see `fileSize` syntax below. +- `digest` - SHA512 hash of encrypted file, base64url encoded string. +- `key` - symmetric encryption key to decrypt the file, base64url encoded string. +- `nonce` - nonce to decrypt the file, base64url encoded string. +- `chunkSize` - default chunk size, see `fileSize` syntax below. +- `replicas` - the array of file chunk replicas descriptions. +- `redirect` - optional property for redirect information indicating that the file is itself a description to another file, allowing to use file description as a short URI. + +Each replica description is an object with 2 fields: + +- `chunks` - and array of chunk replica descriptions stored on one server. +- `server` - [server address](#xftp-server-uri) where the chunks can be downloaded from. + +Each server replica description is a string with this syntax: + +```abnf +chunkReplica = chunkNo ":" replicaId ":" replicaKey [":" chunkDigest [":" chunkSize]] +chunkNo = 1*DIGIT + ; a sequential 1-based chunk number in the original file. +replicaId = base64url + ; server-assigned random chunk replica ID. +replicaKey = base64url + ; sender-generated random key to receive (or to delete, in case of sender's file description) the chunk replica. +chunkDigest = base64url + ; chunk digest that MUST be specified for the first replica of each chunk, + ; and SHOULD be omitted (or be the same) on the subsequent replicas +chunkSize = fileSize +fileSize = sizeInBytes / sizeInUnits + ; chunk size SHOULD only be specified on the first replica and only if it is different from default chunk size +sizeInBytes = 1*DIGIT +sizeInUnits = 1*DIGIT sizeUnit +sizeUnit = %s"kb" / %s"mb" / %s"gb" +base64url = ; RFC4648, section 5 +``` + +Optional redirect information has two fields: +- `size` - the size of the original encrypted file to which file description downloaded via the current file description will lead to, see `fileSize` syntax below. +- `digest` - SHA512 hash of the original file, base64url encoded string. + +## URIs syntax + +### XFTP server URI + +The XFTP server address is a URI with the following syntax: + +```abnf +xftpServerURI = %s"xftp://" xftpServer +xftpServer = serverIdentity [":" basicAuth] "@" srvHost [":" port] +srvHost = ; RFC1123, RFC5891 +port = 1*DIGIT +serverIdentity = base64url +basicAuth = base64url +``` + +### File description URI + +This file description URI can be generated by the client application to share a small file description as a QR code or as a link. Practically, to be able to scan a QR code it should be under 1000 characters, so only file descriptions with 1-2 chunks can be used in this case. This is supported with `redirect` property when file description leads to a file which in itself is a larger file description to another file - akin to URL shortener. + +File description URI syntax: + +```abnf +fileDescriptionURI = serviceScheme "/file" "#/?desc=" description [ "&data=" userData ] +serviceScheme = (%s"https://" clientAppServer) | %s"simplex:" +clientAppServer = hostname [ ":" port ] +; client app server, e.g. simplex.chat +description = +userData = +``` + +clientAppServer is not a server the client connects to - it is a server that shows the instruction on how to download the client app that will connect using this connection request. This server can also host a mobile or desktop app manifest so that this link is opened directly in the app if it is installed on the device. + +"simplex" URI scheme in serviceScheme can be used instead of client app server. Client apps MUST support this URI scheme. + +## XFTP qualities and features + +XFTP stands for SimpleX File Transfer Protocol. Its design is based on the same ideas and has some of the qualities of SimpleX Messaging Protocol: + +- recipient cannot see sender's IP address, as the file fragments (chunks) are temporarily stored on multiple XFTP relays. +- file can be sent asynchronously, without requiring the sender to be online for file to be received. +- there is no network of peers that can observe this transfer - sender chooses which XFTP relays to use, and can self-host their own. +- XFTP relays do not have any file metadata - they only see individual chunks, with access to each chunk authorized with anonymous credentials (using Edwards curve cryptographic signature) that are random per chunk. +- chunks have one of the sizes allowed by the servers - 64KB, 256KB, 1MB and 4MB chunks, so sending a large file looks indistinguishable from sending many small files to XFTP server. If the same transport connection is reused, server would only know that chunks are sent by the same user. +- each chunk can be downloaded by multiple recipients, but each recipient uses their own key and chunk ID to authorize access, and the chunk is encrypted by a different key agreed via ephemeral DH keys (NaCl crypto_box (SalsaX20Poly1305 authenticated encryption scheme ) with shared secret derived from Curve25519 key exchange) on the way from the server to each recipient. XFTP protocol as a result has the same quality as SMP protocol - there are no identifiers and ciphertext in common between sent and received traffic inside TLS connection, so even if TLS is compromised, it complicates traffic correlation attacks. +- XFTP protocol supports redundancy - each file chunk can be sent via multiple relays, and the recipient can choose the one that is available. Current implementation of XFTP protocol in SimpleX Chat does not support redundancy though. +- the file as a whole is encrypted with a random symmetric key using NaCl secret_box. + +## Cryptographic algorithms + +Clients must cryptographically authorize XFTP commands, see [Command authentication](#command-authentication). + +To authorize/verify transmissions clients and servers MUST use either signature algorithm Ed25519 algorithm defined in RFC8709 or using deniable authentication scheme based on NaCL crypto_box (see Simplex Messaging Protocol). + +To encrypt/decrypt file chunk bodies delivered to the recipients, servers/clients MUST use NaCL crypto_box. + +Clients MUST encrypt file chunk bodies sent via XFTP servers using use NaCL crypto_box. + +## File chunk IDs + +XFTP servers MUST generate a separate new set of IDs for each new chunk - for the sender (that uploads the chunk) and for each intended recipient. It is REQUIRED that: + +- These IDs are different and unique within the server. +- Based on random bytes generated with cryptographically strong pseudo-random number generator. + +## Server security requirements + +XFTP server implementations MUST NOT create, store or send to any other servers: + +- Logs of the client commands and transport connections in the production environment. + +- History of retrieved files. + +- Snapshots of the database they use to store file chunks (instead clients can manage redundancy by creating chunk replicas using more than one XFTP server). In-memory persistence is recommended for file chunks records. + +- Any other information that may compromise privacy or [forward secrecy][4] of communication between clients using XFTP servers. + +## Transport protocol + +- binary-encoded commands sent as fixed-size padded block in the body of HTTP2 POST request, similar to SMP and notifications server protocol transmission encodings. +- HTTP2 POST with a fixed size padded block body for file upload and download. + +Block size - 4096 bytes (it would fit ~120 Ed25519 recipient keys). + +The reasons to use HTTP2: + +- avoid the need to have two hostnames (or two different ports) for commands and file uploads. +- compatibility with the existing HTTP2 client libraries. + +The reason not to use JSON bodies: + +- bigger request size, so fewer recipient keys would fit in a single request +- signature over command has to be outside of JSON anyway. + +The reason not to use URI segments / HTTP verbs / REST semantics is to have consistent request size. + +### ALPN to agree handshake version + +Client and server use [ALPN extension][18] of TLS to agree handshake version. + +Server SHOULD send `xftp/1` protocol name and the client should confirm this name in order to use the current protocol version. This is added to allow support of older clients without breaking backward compatibility and to extend or modify handshake syntax. + +If the client does not confirm this protocol name, the server would fall back to v1 of XFTP protocol. + +### Transport handshake + +When a client and a server agree on handshake version using ALPN extension, they should proceed with XFTP handshake. + +As with SMP, a client doesn't reveal its version range to avoid version fingerprinting. Unlike SMP, XFTP runs a HTTP2 protocol over TLS and the server can't just send its handshake right away. So a session handshake is driven by client-sent requests: + +1. To pass initiative to the server, the client sends a request with empty body. +2. Server responds with its `paddedServerHello` block. +3. Clients sends a request containing `paddedClientHello` block, +4. Server sends an empty response, finalizing the handshake. + +Once TLS handshake is complete, client and server will exchange blocks of fixed size (16384 bytes). + +```abnf +paddedServerHello = +serverHello = xftpVersionRange sessionIdentifier serverCert signedServerKey ignoredPart +xftpVersionRange = minXftpVersion maxXftpVersion +minXftpVersion = xftpVersion +maxXftpVersion = xftpVersion +sessionIdentifier = shortString +; unique session identifier derived from transport connection handshake +serverCert = originalLength +signedServerKey = originalLength ; signed by server certificate + +paddedClientHello = +clientHello = xftpVersion keyHash ignoredPart +; chosen XFTP protocol version - must be the maximum supported version +; within the range offered by the server + +xftpVersion = 2*2OCTET ; Word16 version number +keyHash = shortString +shortString = length length*OCTET +length = 1*1OCTET +originalLength = 2*2OCTET +ignoredPart = *OCTET +``` + +In XFTP v2 the handshake is only used for version negotiation, but `serverCert` and `signedServerKey` must be validated by the client. + +`keyHash` is the CA fingerprint used by client to validate TLS certificate chain and is checked by a server against its own key. + +`ignoredPart` in handshake allows to add additional parameters in handshake without changing protocol version - the client and servers must ignore any extra bytes within the original block length. + +For TLS transport client should assert that `sessionIdentifier` is equal to `tls-unique` channel binding defined in [RFC 5929][14] (TLS Finished message struct); we pass it in `serverHello` block to allow communication over some other transport protocol (possibly, with another channel binding). + +### Requests and responses + +- File sender: + - create file chunk record. + - Parameters: + - Ed25519 key for subsequent sender commands and Ed25519 keys for commands of each recipient. + - chunk size. + - Response: + - chunk ID for the sender and different IDs for all recipients. + - add recipients to file chunk + - Parameters: + - sender's chunk ID + - Ed25519 keys for commands of each recipient. + - Response: + - chunk IDs for new recipients. + - upload file chunk. + - delete file chunk (invalidates all recipient IDs). +- File recipient: + - download file chunk: + - chunk ID + - DH key for additional encryption of the chunk. + - command should be signed with the key passed by the sender when creating chunk record. + - delete file chunk ID (only for one recipient): signed with the same key. + +## XFTP commands + +Commands syntax below is provided using ABNF with case-sensitive strings extension. + +```abnf +xftpCommand = ping / senderCommand / recipientCmd / serverMsg +senderCommand = register / add / put / delete +recipientCmd = get / ack +serverMsg = pong / sndIds / rcvIds / ok / file +``` + +The syntax of specific commands and responses is defined below. + +### Correlating responses with commands + +Commands are made via HTTP2 requests, responses to commands are correlated as HTTP2 responses. + +### Command authentication + +XFTP servers must authenticate all transmissions (excluding `ping`) by verifying the client signatures. Command signature should be generated by applying the algorithm specified for the file to the `signed` block of the transmission, using the key associated with the file chunk ID (recipient's or sender's depending on which file chunk ID is used). + +### Keep-alive command + +To keep the transport connection alive and to generate noise traffic the clients should use `ping` command to which the server responds with `pong` response. This command should be sent unsigned and without file chunk ID. + +```abnf +ping = %s"PING" +``` + +This command is always sent unsigned. + + data FileResponse = ... | FRPong | ... + +```abnf +pong = %s"PONG" +``` + +### File sender commands + +Sending any of the commands in this section (other than `register`, that is sent without file chunk ID) is only allowed with sender's ID. + +#### Register new file chunk + +This command is sent by the sender to the XFTP server to register a new file chunk. + +Servers SHOULD support basic auth with this command, to allow only server owners and trusted users to create file chunks on the servers. + +The syntax is: + +```abnf +register = %s"FNEW " fileInfo rcvPublicAuthKeys basicAuth +fileInfo = sndKey size digest +sndKey = length x509encoded +size = 1*DIGIT +digest = length *OCTET +rcvPublicAuthKeys = length 1*rcvPublicAuthKey +rcvPublicAuthKey = length x509encoded +basicAuth = "0" / "1" length *OCTET + +x509encoded = + +length = 1*1 OCTET +``` + +If the file chunk is registered successfully, the server must send `sndIds` response with the sender's and recipients' file chunk IDs: + +```abnf +sndIds = %s"SIDS " senderId recipientIds +senderId = length *OCTET +recipientIds = length 1*recipientId +recipientId = length *OCTET +``` + +#### Add file chunk recipients + +This command is sent by the sender to the XFTP server to add additional recipient keys to the file chunk record, in case number of keys requested by client didn't fit into `register` command. The syntax is: + +```abnf +add = %s"FADD " rcvPublicAuthKeys +rcvPublicAuthKeys = length 1*rcvPublicAuthKey +rcvPublicAuthKey = length x509encoded +``` + +If additional keys were added successfully, the server must send `rcvIds` response with the added recipients' file chunk IDs: + +```abnf +rcvIds = %s"RIDS " recipientIds +recipientIds = length 1*recipientId +recipientId = length *OCTET +``` + +#### Upload file chunk + +This command is sent by the sender to the XFTP server to upload file chunk body to server. The syntax is: + +```abnf +put = %s"FPUT" +``` + +Chunk body is streamed via HTTP2 request. + +If file chunk body was successfully received, the server must send `ok` response. + +```abnf +ok = %s"OK" +``` + +#### Delete file chunk + +This command is sent by the sender to the XFTP server to delete file chunk from the server. The syntax is: + +```abnf +delete = %s"FDEL" +``` + +Server should delete file chunk record, invalidating all recipient IDs, and delete file body from file storage. If file chunk was successfully deleted, the server must send `ok` response. + +### File recipient commands + +Sending any of the commands in this section is only allowed with recipient's ID. + +#### Download file chunk + +This command is sent by the recipient to the XFTP server to download file chunk body from the server. The syntax is: + +```abnf +get = %s"FGET " rDhKey +rDhKey = length x509encoded +``` + +If requested file is successfully located, the server must send `file` response. File chunk body is sent as HTTP2 response body. + +```abnf +file = %s"FILE " sDhKey cbNonce +sDhKey = length x509encoded +cbNonce = +``` + +Chunk is additionally encrypted on the way from the server to the recipient using a key agreed via ephemeral DH keys `rDhKey` and `sDhKey`, so there is no ciphertext in common between sent and received traffic inside TLS connection, in order to complicate traffic correlation attacks, if TLS is compromised. + +#### Acknowledge file chunk download + +This command is sent by the recipient to the XFTP server to acknowledge file reception, deleting file ID from server for this recipient. The syntax is: + +```abnf +ack = %s"FACK" +``` + +If file recipient ID is successfully deleted, the server must send `ok` response. + +In current implementation of XFTP protocol in SimpleX Chat clients don't use FACK command. Files are automatically expired on servers after configured time interval. + +## Threat model + +#### Global Assumptions + + - A user protects their local database and key material. + - The user's application is authentic, and no local malware is running. + - The cryptographic primitives in use are not broken. + - A user's choice of servers is not directly tied to their identity or otherwise represents distinguishing information about the user. + +#### A passive adversary able to monitor the traffic of one user + +*can:* + + - identify that and when a user is sending files over XFTP protocol. + + - determine which servers the user sends/receives files to/from. + + - observe how much traffic is being sent, and make guesses as to its purpose. + +*cannot:* + + - see who sends files to the user and who the user sends the files to. + +#### A passive adversary able to monitor a set of file senders and recipients + + *can:* + + - learn which XFTP servers are used to send and receive files for which users. + + - learn when files are sent and received. + + - perform traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers. + + - observe how much traffic is being sent, and make guesses as to its purpose + +*cannot, even in case of a compromised transport protocol:* + + - perform traffic correlation attacks with any increase in efficiency over a non-compromised transport protocol + +#### XFTP server + +*can:* + +- learn when file senders and recipients are online. + +- know how many file chunks and chunk sizes are sent via the server. + +- perform the correlation of the file chunks as belonging to one file via either a re-used transport connection, user's IP address, or connection timing regularities. + +- learn file senders' and recipients' IP addresses, and infer information (e.g. employer) based on the IP addresses, as long as Tor is not used. + +- delete file chunks, preventing file delivery, as long as redundant delivery is not used. + +- lie about the state of a file chunk to the recipient and/or to the sender (e.g. deleted when it is not). + +- refuse deleting the file when instructed by the sender. + +*cannot:* + +- undetectably corrupt file chunks. + +- learn the contents, name or the exact size of sent files. + +- learn approximate size of sent files, as long as more than one server is used to send file chunks. + +- compromise the users' end-to-end encryption of files with an active attack. + +#### An attacker who obtained Alice's (decrypted) chat database + +*can:* + +- see the history of all files exchanged by Alice with her communication partners, as long as files were not deleted from the database. + +- receive all files sent and received by Alice that did not expire yet, as long as information about these files was not removed from the database. + +- prevent Alice's contacts from receiving the files she sent by deleting all or some of the file chunks from XFTP servers. + +#### A user's contact + +*can:* + +- spam the user with files. + +- forever retain files from the user. + +*cannot:* + +- cryptographically prove to a third-party that a file came from a user (assuming the user's device is not seized). + +- prove that two contacts they have is the same user. + +- cannot collaborate with another of the user's contacts to confirm they are communicating with the same user, even if they receive the same file. + +#### An attacker with Internet access + +*can:* + +- Denial of Service XFTP servers. + +*cannot:* + +- send files to a user who they are not connected with. + +- enumerate file chunks on an XFTP server. diff --git a/protocol/xrcp.md b/protocol/xrcp.md new file mode 100644 index 000000000..9f7187e66 --- /dev/null +++ b/protocol/xrcp.md @@ -0,0 +1,330 @@ +Version 1, 2024-06-22 + +# SimpleX Remote Control Protocol + +## Table of contents + +- [Abstract](#abstract) +- [XRCP model](#xrcp-model) +- [Transport protocol](#transport-protocol) + - [Session invitation](#session-invitation) + - [Establishing TLS connection](#establishing-tls-connection) + - [Session verification and protocol negotiation](#session-verification-and-protocol-negotiation) + - [Controller/host session operation](#сontrollerhost-session-operation) +- [Key agreement for announcement packet and for session](#key-agreement-for-announcement-packet-and-for-session) +- [Threat model](#threat-model) + +## Abstract + +The SimpleX Remote Control Protocol is a client-server protocol designed to transform application UIs into thin clients, enabling remote control from another device. This approach allows users to remotely access and utilize chat profiles without the complexities of master-master replication for end-to-end encryption states. + +Like SMP and XFTP, XRCP leverages out-of-band invitations to mitigate MITM attacks and employs multiple cryptographic layers to safeguard application data. + +## XRCP model + +XRCP assumes two application roles: host (that contain the application data) and controller that gains limited access to host data. +Applications are also split into two components: UI and core. + +When an XRCP session is established a host UI is locked out and a controller UI uses its core to proxy commands to the host core, getting back responses and events. + +``` + + +------+ +------+ xrcp +------+ +------+ + | Ctrl | commands | Ctrl | commands | Host | | Host | +user ---> | UI | -----------> | Core | -----------> | Core | | UI | + +------+ +------+ +------+ +------+ + ^ responses | ^ xrcp responses | ^ + |<------------------| |<-----------------| | +-------------+ + | events | | | Application |-+ + |<------------------| |----> | protocol | | + | servers | | + +-------------+ | + +--------------+ +``` + +## Transport protocol + +Protocol consists of four phases: +- controller session invitation +- establishing session TLS connection +- session verification and protocol negotiation +- session operation + +![Session sequence](./diagrams/xrcp/session.svg) + +### Session invitation + +The invitation to the first session between host and controller pair MUST be shared out-of-band, to establish a long term identity keys/certificates of the controller to host device. + +The subsequent sessions can be announced via an application-defined site-local multicast group, e.g. `224.0.0.251` (also used in mDNS/bonjour) and an application-defined port (SimpleX Chat uses 5227). + +The session invitation contains this data: +- supported version range for remote control protocol. +- application-specific information, e.g. device name, application name and supported version range, settings, etc. +- session start time in seconds since epoch. +- if multicast is used, counter of announce packets sent by controller. +- network address (ipv4 address and port) of the controller. +- CA TLS certificate fingerprint of the controller - this is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements. +- Session Ed25519 public key used to verify the announcement and commands - this mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first. +- Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity. +- Session X25519 DH key and SNTRUP761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. DH public key and KEM encapsulation key are sent unencrypted. NaCL crypto_box is used for encryption. + +Host application decrypts (except the first session) and validates the invitation: +- Session signature is valid. +- Timestamp is within some window from the current time. +- Long-term key signature is valid. +- Long-term CA and signature key are the same as in the first session. +- Some version in the offered range is supported. + +OOB session invitation is a URI with this syntax: + +```abnf +sessionAddressUri = "xrcp:/" encodedCAFingerprint "@" host ":" port "#/?" qsParams +encodedCAFingerprint = base64url +host = ; in textual form, RFC4001 +port = 1*DIGIT ; uint16 +qsParams = param *("&" param) +param = versionRangeParam / appInfoParam / sessionTsParam / + sessPubKeyParam / idPubKeyParam / dhPubKeyParam / + sessSignatureParam / idSignatureParam +versionRangeParam = "v=" (versionParam / (versionParam "-" versionParam)) +versionParam = 1*DIGIT +appInfoParam = "app=" escapedJSON +sessionTsParam = "ts=" 1*DIGIT +sessPubKeyParam = "skey=" base64url +idPubKeyParam = "idkey=" base64url +dhPubKeyParam = "dh=" base64url +sessSignatureParam = "ssig=" base64url ; signs the URI with this and idSignatureParam param removed +idSignatureParam = "idsig=" base64url ; signs the URI with this param removed +base64url = ; 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 TLS connection + +Both controller and host use 2-element certificate chains with unique self-signed CA root representing long-term identities. Leaf certificates aren't stored and instead generated on each session start. + +A controller runs a TCP server to avoid opening listening socket on a host, which might create an attack vector. A controller keeps no sensitive data to be exposed this way. + +During TLS handshake, parties validate certificate chains against previously known (from invitation or storage) CA fingerprints. The fingerprints MUST be the same as in the invitation and in the subsequent connections. + +### Session verification and protocol negotiation + +Once TLS session is established, both the host and controller devices present a "session security code" to the user who must match them (e.g., visually or via QR code scan) and confirm on the host device. The session security code must be a digest of tlsunique channel binding. As it is computed as a digest of the TLS handshake for both the controller and the host, it will validate that the same TLS certificates are used on both sides, and that the same TLS session is established, mitigating the possibility of MITM attack in the connection. + +Once the session is confirmed by the user, the host sends HELLO block to the controller. + +XRCP blocks inside TLS are padded to 16384 bytes. + +Host HELLO block must contain: +- new session DH key - used to compute new shared secret with the controller keys from the announcement. +- encrypted part of HELLO block (JSON object), containing: + - chosen protocol version. + - host CA TLS certificate fingerprint - part of host long term identity - must match the one presented in TLS handshake and the previous sessions, otherwise the connection is terminated. + - KEM encapsulation key - used to compute new shared secret for the session. + - additional application specific parameters, e.g host device name, application version, host settings or JSON encoding format. + +Host HELLO block syntax: + +```abnf +hostHello = %s"HELLO " dhPubKey nonce encrypted(unpaddedSize hostHelloJSON helloPad) pad +unpaddedSize = largeLength +dhPubKey = length x509encoded +pad = +helloPad = +largeLength = 2*2 OCTET +``` + +The controller decrypts (including the first session) and validates the received HELLO block: +- Chosen versions are supported (must be within offered ranges). +- CA fingerprint matches the one presented in TLS handshake and the previous sessions - in subsequent sessions TLS connection should be rejected if the fingerprint is different. + +[JTD schema](https://www.rfc-editor.org/rfc/rfc8927) for the encrypted part of host HELLO block `hostHelloJSON`: + +```json +{ + "definitions": { + "version": { + "type": "string", + "metadata": { + "format": "[0-9]+" + } + }, + "base64url": { + "type": "string", + "metadata": { + "format": "base64url" + } + } + }, + "properties": { + "v": {"ref": "version"}, + "ca": {"ref": "base64url"}, + "kem": {"ref": "base64url"} + }, + "optionalProperties": { + "app": {"properties": {}, "additionalProperties": true} + }, + "additionalProperties": true +} +``` + +The controller should reply with with `ctrlHello` or `ctrlError` response: + +```abnf +ctrlHello = %s"HELLO " kemCiphertext nonce encrypted(unpaddedSize ctrlHelloJSON helloPad) pad +; ctrlHelloJSON is encrypted with the hybrid secret, +; including both previously agreed DH secret and KEM secret from kemCiphertext +unpaddedSize = largeLength +kemCiphertext = largeLength *OCTET +pad = +helloPad = +largeLength = 2*2 OCTET + +ctrlError = %s"ERROR " nonce encrypted(unpaddedSize ctrlErrorMessage helloPad) pad +ctrlErrorMessage = ; encrypted using previously agreed DH secret. +``` + +JTD schema for the encrypted part of controller HELLO block `ctrlHelloJSON`: + +```json +{ + "properties": {}, + "additionalProperties": true +} +``` + +Once the controller replies HELLO to the valid host HELLO block, it should stop accepting new TCP connections. + +### Controller/host session operation + +The protocol for communication during the session is out of scope of this protocol. + +SimpleX Chat uses HTTP2 encoding, where host device acts as a server and controller acts as a client (these roles are reversed compared with TLS connection, restoring client-server semantics in HTTP). + +Payloads in the protocol must be encrypted using NaCL secret_box using the hybrid shared secret agreed during session establishment. + +Commands of the controller must be signed after the encryption using the controller's session and long term Ed25519 keys. + +tlsunique channel binding from TLS session MUST be included in commands (included in the signed body). + +The syntax for encrypted command and response body encoding: + +```abnf +commandBody = encBody sessSignature idSignature [attachment] +responseBody = encBody [attachment] ; counter must match command +encBody = nonce encLength32 encrypted(tlsunique counter body) +attachment = %x01 nonce encLength32 encrypted(attachment) +noAttachment = %x00 +tlsunique = length 1*OCTET +counter = 8*8 OCTET ; int64 +encLength32 = 4*4 OCTET ; uint32, includes authTag +``` + +If the command or response includes attachment, its hash must be included in command/response and validated. + +## Key agreement for announcement packet and for session + +Initial announcement is shared out-of-band (URI with xrcp scheme), and it is not encrypted. + +This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will contain DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA256 over concatenated DH shared secret and KEM encapsulated secret) both for controller HELLO response (that contains KEM ciphertext in plaintext part) and subsequent session commands and responses. + +During the next session the announcement is sent via encrypted multicast block. The shared key for this announcement and for host HELLO block is determined using the KEM shared secret from the previous session and DH shared secret computed using the host DH key from the previous session and the new controller DH key from the announcement. + +For the session, the shared secret is computed again using the KEM shared secret encapsulated by the controller using the new KEM key from the host HELLO block and DH shared secret computed using the host DH key from HELLO block and the new controller DH key from the announcement. + +In pseudo-code: + +``` +// session 1 +hostHelloSecret(1) = dhSecret(1) +sessionSecret(1) = sha256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello +dhSecret(1) = dh(hostHelloDhKey(1), controllerInvitationDhKey(1)) +kemCiphertext(1) = enc(kemSecret(1), kemEncKey(1)) +// kemEncKey is included in host HELLO, kemCiphertext - in controller HELLO +kemSecret(1) = dec(kemCiphertext(1), kemDecKey(1)) + +// multicast announcement for session n +announcementSecret(n) = sha256(dhSecret(n')) +dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerDhKey(n)) + +// session n +hostHelloSecret(n) = dhSecret(n) +sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello +dhSecret(n) = dh(hostHelloDhKey(n), controllerDhKey(n)) +// controllerDhKey(n) is either from invitation or from multicast announcement +kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n)) +kemSecret(n) = dec(kemCiphertext(n), kemDecKey(n)) +``` + +If controller fails to store the new host DH key after receiving HELLO block, the encryption will become out of sync and the host won't be able to decrypt the next announcement. To mitigate it, the host should keep the last session DH key and also previous session DH key to try to decrypt the next announcement computing shared secret using both keys (first the new one, and in case it fails - the previous). + +To decrypt a multicast announcement, the host should try to decrypt it using the keys of all known (paired) remote controllers. + +## Threat model + +#### A passive network adversary able to monitor the site-local traffic: + +*can:* +- observe session times, duration and volume of the transmitted data between host and controller. + +*cannot:* +- observe the content of the transmitted data. +- substitute the transmitted commands or responses. +- replay transmitted commands or events from the hosts. + +#### An active network adversary able to intercept and substitute the site-local traffic: + +*can:* +- prevent host and controller devices from establishing the session + +*cannot:* +- same as passive adversary, provided that user visually verified session code out-of-band. + +#### An active adversary with the access to the network: + +*can:* +- spam controller device. + +*cannot:* +- compromise host or controller devices. + +#### An active adversary with the access to the network who also observed OOB announcement: + +*can:* +- connect to controller instead of the host. +- present incorrect data to the controller. + +*cannot:* +- connect to the host or make host connect to itself. + +#### Compromised controller device: + +*can:* +- observe the content of the transmitted data. +- access any data of the controlled host application, within the capabilities of the provided API. + +*cannot:* +- access other data on the host device. +- compromise host device. + +#### Compromised host device: + +*can:* +- present incorrect data to the controller. +- incorrectly interpret controller commands. + +*cannot:* +- access controller data, even related to this host device. diff --git a/rfcs/2024-03-20-server-metadata.md b/rfcs/2024-03-20-server-metadata.md index f8795f130..22b163c05 100644 --- a/rfcs/2024-03-20-server-metadata.md +++ b/rfcs/2024-03-20-server-metadata.md @@ -52,8 +52,8 @@ source_code: https://github.com/simplex-chat/simplexmq # We should split this document to the model one, where specific parameters will be external to the document, # and specific to us, so that relay operators can adopt our recommended policy and publish any amendments separately. -conditions: https://github.com/simplex-chat/simplex-chat/blob/_archived-ep/ios-file-provider/PRIVACY.md -# conditions_amendments: link +usage_conditions: https://github.com/simplex-chat/simplex-chat/blob/_archived-ep/ios-file-provider/PRIVACY.md +# condition_amendments: link server_country: SE operator: SimpleX Chat Ltd. @@ -62,9 +62,9 @@ website: https://simplex.chat admin_simplex: administrative SimpleX address admin_email: chat@simplex.chat admin_pgp: PGP key -feedback_simplex: SimpleX address for feedback, comments and complaints -feedback_email: complaints@simplex.chat -feedback_pgp: PGP key +complaints_simplex: SimpleX address for feedback, comments and complaints +complaints_email: complaints@simplex.chat +complaints_pgp: PGP key hosting: Linode / Akamai Inc. hosting_country: US ``` @@ -89,20 +89,27 @@ data ServerHandshake = ServerHandshake } data ServerInformation = ServerInformation - { -- below is based on the existing server configuration - persistence :: SMPServerPersistenceMode, + { config :: ServerPublicConfig, + info :: ServerPublicInfo + } + +-- based on server configuration +data ServerPublicConfig = ServerPublicConfig + { persistence :: SMPServerPersistenceMode, messageExpiration :: Int, statsEnabled :: Bool, newQueuesAllowed :: Bool, - basicAuthEnabled :: Bool, -- server is private if enabled - -- below is based on INFORMATION section of INI file - sourceCode :: Text, -- note that this property is not optional, in line with AGPLv3 license - -- all below properties are optional, except entity name MUST be present if any entity country is present + basicAuthEnabled :: Bool -- server is private if enabled + } + +-- based on INFORMATION section of INI file +data ServerPublicInfo = ServerPublicInfo + { sourceCode :: Text, -- note that this property is not optional, in line with AGPLv3 license conditions :: Maybe ServerConditions, operator :: Maybe Entity, website :: Maybe Text, - admin :: Maybe ServerContactAddress, - feedback :: Maybe ServerContactAddress, + adminContacts :: Maybe ServerContactAddress, + complaintsContacts :: Maybe ServerContactAddress, hosting :: Maybe Entity, serverCountry :: Maybe Text } diff --git a/rfcs/2024-06-01-agent-protocol.md b/rfcs/2024-06-01-agent-protocol.md new file mode 100644 index 000000000..616aed33f --- /dev/null +++ b/rfcs/2024-06-01-agent-protocol.md @@ -0,0 +1,19 @@ +# Evolving agent API + +## Problem + +Historically, agent API started as a TCP protocol with encoding. We do not use the actual protocol and maintaining the encoding complicates the evolution of the API. + +Currently, I was trying to add ERRS event to combine multiple subscription errors into one to prevent overloading the UI with processing multiple subscription errors (e.g.): + +```haskell +ERRS :: (ConnId, AgentErrorType) -> ACommand Agent AEConn +``` + +This constructor is not possible to encode/parse in a sensible way other than including lengths of errors. + +## Proposal + +Remove commands type and encodings for commands and events. + +Only keep encodings for the commands that are saved to the database: NEW, JOIN, LET, ACK, SWCH, DEL (this one is no longer used but needs to be supported for backwards compatibility). diff --git a/rfcs/2024-06-14-fast-connection.md b/rfcs/2024-06-14-fast-connection.md new file mode 100644 index 000000000..000f0ef10 --- /dev/null +++ b/rfcs/2024-06-14-fast-connection.md @@ -0,0 +1,42 @@ +# Faster connection establishment + +## Problem + +SMP protocol is unidirectional, and to create a connection users have to agree two messaging queues. + +V1 of handshake protocol required 5 messages and multiple HELLO sent between the users, which consumed a lot of traffic. + +V2 of handshake protocol was optimized to remove multiple HELLO and also REPLY message, thanks to including queue address together with the key to secure this queue into the confirmation message. + +This eliminated unnecessary traffic from repeated HELLOs, but still requires 4 messages in total and 2 times of each client being online. It is perceived by the users as "it didn't work" (because they see "connecting" after using the link) or "we have to be online at the same time" (and even in this case it is slow on bad network). This hurts usability and creates churn of the new users, as unless people are onboarded by the friends who know how the app works, they cannot figure out how to connect. + +Ideally, we want to have handshake protocol design when an accepting user can send messages straight after using the link (their client says "connected") and the initiating client can send messages as soon as it received confirmation message with the profile. + +This RFC proposes modifications to SMP and SMP Agent protocols to reduce the number of required messages to 2 and allows accepting client to send messages straight after using the link (and sending the confirmation), before receiving the profile of the initiating client in the second message, and the initiating client can send the messages straight after processing the confirmation and sending its own confirmation. + +## Solution + +The current protocol design allows additional confirmation step where the initiating client can confirm the connection having received the profile of the sender. We don't use it in the UI - this confirmation is done automatically and unconditionally. + +Instead of requiring the initiating client to secure its queue with sender's key, we can allow the accepting client to secure it with the additional SKEY command. This would avoid "connecting" state but would introduce "Profile unknown" state where the accepting client does not yet have the profile of the initiating client. In this case we could also use the non-optional alias created during the connection (or have something like "Add alias to be able to send messages immediately" and show warning if the user proceeds without it). + +The additional advantage here is that if the queue of the initiating client was removed, the connection will not procede to create additional queue, failing faster. + +These are the proposed changes: + +1. Modify NEW command to add flag allowing sender to secure the queue (it should not be allowed if queue is created for the contact address). +2. Include flag into the invitation link URI and in reply address encoding that queue(s) can be secured by the sender (to avoid coupling with the protocol version and preserve the possibility of the longer handshakes). +3. Add SKEY command to SMP protocol to allow the sender securing the message queue. +4. This command has to be supported by SMP proxy as well, so that the sender does not connect to the recipient's server directly. +5. Accepting client will secure the messaging queue before sending the confirmation to it. +6. Initiating client will secure the messaging queue before sending the confirmation. + +See [this sequence diagram](../protocol/diagrams/duplex-messaging/duplex-creating-v6.mmd) for the updated handshake protocol. + +Changes to threat model: the attacker who compromised TLS and knows the queue address can block the connection, as the protocol no longer requires the recipient to decrypt the confirmation to secure the queue. + +Possibly, "fast connection" should be an option in Privacy & security settings. + +## Implementation questions + +Currently we store received confirmations in the database, so that the client can confirm them. This becomes unnecessary. diff --git a/rfcs/2022-12-26-simplex-file-transfer.md b/rfcs/done/2022-12-26-simplex-file-transfer.md similarity index 100% rename from rfcs/2022-12-26-simplex-file-transfer.md rename to rfcs/done/2022-12-26-simplex-file-transfer.md diff --git a/rfcs/2022-12-27-queue-quota.md b/rfcs/done/2022-12-27-queue-quota.md similarity index 100% rename from rfcs/2022-12-27-queue-quota.md rename to rfcs/done/2022-12-27-queue-quota.md diff --git a/rfcs/2023-05-02-resync-ratchets.md b/rfcs/done/2023-05-02-resync-ratchets.md similarity index 100% rename from rfcs/2023-05-02-resync-ratchets.md rename to rfcs/done/2023-05-02-resync-ratchets.md diff --git a/rfcs/2023-05-03-delivery-receipts.md b/rfcs/done/2023-05-03-delivery-receipts.md similarity index 100% rename from rfcs/2023-05-03-delivery-receipts.md rename to rfcs/done/2023-05-03-delivery-receipts.md diff --git a/rfcs/2023-05-24-smp-delivery-proxy.md b/rfcs/done/2023-05-24-smp-delivery-proxy.md similarity index 100% rename from rfcs/2023-05-24-smp-delivery-proxy.md rename to rfcs/done/2023-05-24-smp-delivery-proxy.md diff --git a/rfcs/2023-06-08-resync-ratchets.md b/rfcs/done/2023-06-08-resync-ratchets.md similarity index 100% rename from rfcs/2023-06-08-resync-ratchets.md rename to rfcs/done/2023-06-08-resync-ratchets.md diff --git a/rfcs/2023-09-12-second-relays.md b/rfcs/done/2023-09-12-second-relays.md similarity index 59% rename from rfcs/2023-09-12-second-relays.md rename to rfcs/done/2023-09-12-second-relays.md index 3721ee721..cad6c4a92 100644 --- a/rfcs/2023-09-12-second-relays.md +++ b/rfcs/done/2023-09-12-second-relays.md @@ -2,9 +2,9 @@ ## Problem -SMP protocol relays are chosen and can be controlled by the message recipients. It means that the recipients can find out IP addresses of message senders by modifying SMP relay code (or by using proxies and timing correlation), unless the senders use VPN or some overlay network. Tor is an audequate solution in most cases to mitigate it, but it requires additional technical knowledge to install and configure (even installing Orbot on Android is seen as "complex" by many users), and reduces usability because of higher latency. +SMP protocol relays are chosen and can be controlled by the message recipients. It means that the recipients can find out IP addresses of message senders by modifying SMP relay code (or by using proxies and timing correlation), unless the senders use VPN or some overlay network. Tor is an adequate solution in most cases to mitigate it, but it requires additional technical knowledge to install and configure (even installing Orbot on Android is seen as "complex" by many users), and reduces usability because of higher latency. -The lack of in-built IP address protection is the main concern of many users, particularly given that most people do not realise that it is lacking by default - without transport protection SimpleX is not perceived as a "whole product". +The lack of in-built IP address protection is the main concern of many users, particularly given that most people do not realize that it is lacking by default - without transport protection SimpleX is not perceived as a "whole product". Similarly, XFTP protocol relays are chosen by senders, and they can be used to detect file recipients' IP addresses. @@ -43,7 +43,7 @@ Overall, this is not a viable or even appropriate option for the current stage. 3. SMP / XFTP proxy. -Introduce SMP and XFTP protocol extenstions to allow message senders and file recipients to delegate the tasks of sending messages and receiving files to the proxies, so that peer-chosen relays can only observe IP addresses of the proxies and not of the users. +Introduce SMP and XFTP protocol extensions to allow message senders and file recipients to delegate the tasks of sending messages and receiving files to the proxies, so that peer-chosen relays can only observe IP addresses of the proxies and not of the users. Pros: - no dependency on and lower latency than via Tor @@ -68,7 +68,7 @@ Below considers this design. 2. SMP proxy should not be able to observe queue addresses and their count on the destination relays. This requirement is not needed for XFTP proxies, as each file chunk is downloaded only once, so there is no need to hide its address. -3. There must be no identifiers and cyphertext in common in outgoing and incoming traffic inside TLS (the current designs have this quality). +3. There must be no identifiers and ciphertext in common in outgoing and incoming traffic inside TLS (the current designs have this quality). 4. Traffic between the client and destination relays must be e2e encrypted, with MITM-by-proxy mitigated, relying on the relay identity (certificate fingerprint), ideally without any additional fingerprint in relay address. @@ -97,11 +97,11 @@ This would also reduce the difference in how the traffic looks to the observer - The flow of the messages will be: -1. Client requests proxy to create session with the relay by sending `server` command with the SMP relay address and optional proxy basic AUTH (below). It should be possible to batch multiple session requests into one block, to reduce traffic. +1. Client requests proxy to create session with the relay by sending `PRXY` command with the SMP relay address and optional proxy basic AUTH (below). It should be possible to batch multiple session requests into one block, to reduce traffic. -2. Proxy connects to SMP relay, negotiating a shared secret in the handshake that will be used to encrypt all sender blocks inside TLS (proxy-relay encryption). SMP relay also returns in handshake its temporary DH key to agree e2e encryption with the client (sender-relay encryption, to hide metadata sent to the destination relay from proxy). +2. Proxy connects to SMP relay, negotiating a shared secret via a handshake headers - it will be used to encrypt all sender blocks inside TLS (proxy-relay encryption). DH key returned by SMP relay in handshake will also be used to encrypt client commands, combining it with random per-command keys (sender-relay encryption, to hide metadata sent to the destination relay from proxy). -3. Proxy replies with `server_id` command including relay session ID to identify it in further requests, relay DH key for e2e encryption with the client - this key is signed with the TLS online private key associated with the certificate (its fingerprint is included in the relay address), and the TLS session ID between proxy and relay (this session ID must be used in transmissions, to mitigate replay attacks as before). +3. Proxy replies to sender with `PKEY` message using "entityId" transmission field to indicate session ID for using in further requests, relay DH key for _s2r_ encryption with the client - this key is signed with the TLS online private key associated with the certificate (its fingerprint is included in the relay address), and the TLS session ID between proxy and relay (this session ID must be used in transmissions, to mitigate replay attacks as before). A possible attack here is that proxy can use this TLS session to replay commands received from the client. Possibly, it could be mitigated with a bloom filter per proxy/SMP relay connection that would reject the repeated DH keys (that need to be used for replay), and also with DH key expiration (this mitigation should allow some acceptable rate of false positives from the bloom filter). @@ -113,11 +113,11 @@ It is important that the same public key from destination relay is returned to a *Unrelated cosideration for SMP protocol privacy improvement*: instead of signing commands to the destination relay, the sender could have a ratchet per queue agreed with the destination relay that would simply use authenticated encryption with per-message symmetric key to encrypt the message on the way to relay, and this encryption would be used as a proof of sender. -4. Now the client sends `forward` to proxy, which it then forwards to SMP relay, applying additional encryption layer. +4. Now the client sends `PFWD` to proxy, which it then forwards to SMP relay as `RFWD`, applying _p2r_ encryption layer. -5. SMP relay sends `response` to proxy applying additional encryption layer, which it then forwards to the client removing the additional encryption layer. +5. SMP relay sends `RRES` to proxy applying _p2r_ encryption layer, which it then forwards to the client as `PRES`, removing the _p2r_ encryption layer. -Effectively it works as a simplified two-hop onion routing with the first relay (proxy) chosen by the sending client and the second relay chosen by the recipient, not only protecting senders' IP addresses from the recipients' relays, but also preventing recipients relays from correlating senders' traffic to different queues, as TLS session is owned by the proxy now and it mixes the traffic from multiple senders. To correlate traffic to users, proxy and relay would have to combine their information. SMP relays are still able to correlate traffic to receiving users via transport session. +Effectively it works as a simplified two-hop onion routing with the first relay (proxy) chosen by the sending client and the second relay chosen by the recipient, not only protecting senders' IP addresses from the recipients' relays, but also preventing recipients' relays from correlating senders' traffic to different queues, as TLS session is owned by the proxy now and it mixes the traffic from multiple senders. To correlate traffic to users, proxy and relay would have to combine their information. SMP relays are still able to correlate traffic to receiving users via transport session. Sequence diagram for sending the message via SMP proxy: @@ -126,33 +126,33 @@ Sequence diagram for sending the message via SMP proxy: | sending | | SMP | | SMP | | receiving | | client | | proxy | | relay | | client | ------------- ------------- ------------- ------------- - | `server` | | | - | -------------------------> | create TLS session, get keys | | + | `PRXY` | | | + | -------------------------> | | | | | ------------------------------> | | - | `server_id` | (if doesn't exist) | | + | | SMP handshake | | + | | <------------------------------ | | + | `PKEY` | | | | <------------------------- | | | | | | | - | TLS(F:s2r(SEND(e2e(msg)))) | | | - | -------------------------> | TLS(F:p2r(s2r(SEND(e2e(msg))))) | | + | `PFWD` (s2r) | | | + | -------------------------> | | | + | | `RFWD` (p2r) | | | | ------------------------------> | | - | | | | - | | TLS(R:p2r(s2r(OK/ERR))) | | - | TLS(R:s2r(OK/ERR)) | <------------------------------ | | - | <------------------------- | | TLS(MSG(r2c(e2e(msg)))) | - | | | -----------------------> | - | | | | - | | | TLS(ACK) | + | | `RRES` (p2r) | | + | | <------------------------------ | | + | `PRES` (s2r) | | `MSG` | + | <------------------------- | | -----------------------> | + | | | `ACK` | | | | <----------------------- | | | | | | | | | - ``` -Below diagram shows the encrypttion layers for `forward` and `response` commands: +Below diagram shows the encrypttion layers for `PFWD`/`RFWD` commands and `RRES`/`PRES` responses: -- s2r (added) - encryption between client and SMP relay, with relay key returned in server_id command, with MITM by proxy mitigated by verifying the certificate fingerprint included in the relay address. +- s2r (added) - encryption between client and SMP relay, with relay key returned in relay handshake, with MITM by proxy mitigated by verifying the certificate fingerprint included in the relay address. - e2e (exists now) - end-to-end encryption per SMP queue, with double ratchet e2e encryption inside it. -- p2r (added) - additional encryption between proxy and SMP relay with key agreed in the handshake, to mitigate traffic correlation inside TLS. This key could also be signed by the same certificate, if we don't want to rely on TLS security. +- p2r (added) - additional encryption between proxy and SMP relay with the shared secret agreed in the handshake, to mitigate traffic correlation inside TLS. - r2c (exists now) additional encryption between SMP relay and client to prevent traffic correlation inside TLS. ``` @@ -167,30 +167,85 @@ Below diagram shows the encrypttion layers for `forward` and `response` commands ----------------- ----------------- -- TLS -- ----------------- ----------------- ``` -When proxy connects to SMP relay it would indicate in the handshake that it will use proxy protocol and the SMP relay would expect the same `forward` commands and reply with `response`s. +Question: should proxy declare its role in handshake? When proxy connects to SMP relay it would indicate in the handshake that it will act as a proxy and the SMP relay would expect the same `forward` commands and reply with `response`s. -Below syntax aims to fit in 16kb block using spare capacity in SMP protocol. +Common SMP transmission format (v4), for reference: ```abnf -proxy_block = padded(proxy_transmission, 16384) -proxy_transmission = corr_id relay_session_id proxy_command -corr_id = length *8 OCTET -proxy_command = server / server_id / forward / response / error -server = "S" address [relay_basic_auth] ; creates transport session between proxy and relay -server_id = "I" relay_session_id tls_session_id signed_relay_key ; - ; session_id is the TLS session ID between proxy and relay, it has to be included inside encrypted block to prevent replay attacks -forward = %s"F" random_dh_pub_key encrypted_block ; it's important that a new key is used for each command, to prevent any correlation by proxy or by destination relay -response = %s"R" encrypted_block; response received from the destination SMP relay -relay_session_id = length *8 OCTET -error = %s"E" error +paddedTransmission = +transmission = signature signed +signature = 0 ; empty signatures here +signed = sessionIdentifier corrId entityId (smpCommand / brokerMsg) ``` -The overhead is: 1+8 (corrId) + 1+8 (relay_session_id) + 1 (command) + 1+32 (random_dh_pub_key) + 2 (original length) + 16 (auth tag for e2e encryption) + 16 (auth tag for proxy to relay encryption) = 86 bytes. The reserve for sent messages in SMP is ~84 bytes, so it should about fit with some reduced bytes somewhere. +- `corrId` is fully random each time and used as a nonce for encrypted blocks. +- `entityId` carries tlsUniq from the current proxy-to-relay connection. +- `smpCommand` gets extended with `s2p_command / p2r_command`. +- `brokerMsg` gets extended with `r_key / r_response`. -Another possible design is to allow mixing sent messages and normal SMP commands in the same transport connection, but it can make fitting in the block a bit harder, additional overhead would be: 1 (transmission count) + 2 (transmission size) + 1 (empty signature) = 4 bytes. +```abnf +s2p_command = proxy / forward +p2r_command = p_handshake ; forward is +proxy = %s"PRXY" SP relayUri SP basicAuth +relayUri = length %s"smp://" serverIdentity "@" srvHost [":" port] +forward = %s"PFWD" SP dhPublic SP encryptedBlock +r_key = %s"PKEY" SP dhPublic +r_response = %s"RRES" SP encryptedBlock +dhPublic = length x509encoded +``` The above assumes that the client can only send one message to an SMP relay and then has to wait for response before sending the next message. Missing the response would cause re-delivery (further improvement is possible when proxy detects these redelieveries and not send them to relays but simply reply with the same response). +### Implementation considerations for the client + +While client/server protocol is rather straightforward to implement, and it is already working, there are some decisions to make about how the client makes decisions about. + +1. When to use proxy and when to connect directly to the destination relay. + +While from the perspective of threat model improvement it may be beneficial to always use the proxy, choosing the proxy that is different from other relays in the connection, initially we need to make it opt-in, with an option to only use it for unknown destination relays, to minimize any unexpected adverse effect on the delivery latency. + +Proxy mode will be passed from the client via NetworkConfig. + +2. Which proxying relays to use. + +Ability to request access to the session with the destination relay (and to create such session) is protected with the same basic auth approach as creating queues - the logic here is that opening private servers to all users as proxies would increase the scenarios for DoS attacks (which is the case with the public servers). + +The open question is whether the client should choose proxies from: +- all configured relays. +- there should be a subset of configured relays. +- there should be a separate list. + +E.g., there could be a second toggle in the relay configuration to allow using relay as proxy, in addition to the current toggle that allows creating queues. + +For simplicity, initially we will just use all enabled relays as potential proxies. + +3. How many proxying relays should be used during one session. + +This is not a simple question, and it creates a contradiction between two risks: +- collusion between proxies and destination relays simplifies correlating sending clients by session - from the point of view of this risk, clients should follow the same policy for creating connections with proxies, that is to create a new connection for each user profile, and if transport isolation is set to "per connection" - for each destination queue. +- traffic correlation by observable traffic sessions (particularly if an attacker can observe user's ISP traffic or multiple proxies) - from this point of view, it would be beneficial to use fewer proxies and fewer connections with proxies and see the risk of proxy colluding with the destination relay as lower than the risk of traffic observation that in the case of multiple sessions would allow to correlate traffic to rarely used destination relays (any private self-hosted relays) and the traffic of the user to a given proxy, to prove the fact of user communicating with the destination relay via the proxy. + +While we can transfer this choice on the users, it seems a complex decision to make, and overall the second risk (traffic correlation) seems more important to address than the first. + +In any case possible options are: +1. Extreme option 1: Create a new proxy session, with the new random proxy, for each potential transport session that would exist if the user were to be connected to destination relays directly. That is, never to mix access to multiple relays from multiple user profiles (and in case of per-connection isolation, to multiple queues) into a one client session with proxy. This is a rather radical option that nullifies any advantages of having fewer sessions with proxies than there would have been with the destination relays and removes any benefits of batching destination server session requests (PRXY comands). +2. Extreme option 2: Use only one proxy session at the time, mixing traffic from all user profiles and to all destination servers (and for all queues) into a session with one proxy. This minimizes the risks of traffic correlation in case of non-colluding proxy, but maximises the risk in case it colludes with the destination relays. +3. Balanced option: Use one proxy session per user profile, but mix traffic to multiple queues irrespective of connection isolation option and to all destination servers. Given that connection isolation is an experimental option, this makes the most sense, but it would have to be disclosed. +4. Less balanced option: take connection isolation option into account and create a new proxy connection for each destination queue. This feels worse than option 3. + +If option 3 is chosen, then the transport session key with the proxy would be different from the transport session key with the relay - proxy session will only use UserId as the key, and the relay session uses (UserId, Server, Maybe EntityId) as the key. + +If option 4 is chosen, the keys would also be different, as the proxy would then use (UserId, Maybe (Server, EntityId)) as the key. + +We could potentially key proxy sessions (and create proxy connections) per each destination relay, in the same way as we key relays themselves, but it seems to have the least sense, as we neither achieve isolation by queue in case proxy and destination relay collude, nor we sufficiently protect from traffic correlation by any observers. + +The implemented design is this: +- for each destination relay a random proxy is chosen and used to send all messages - all requests from a client coalesce to a single session. +- transport isolation mode is taken into account, that is if per-connection isolation is enabled, then a separate proxy connection will be created for each messaging queue. +- supported modes when proxy is used: always, for unknown relays, for unknown relays when IP address is not protected, never. + +This decision is made because the argument for protection against collusion between proxy and relay and more balanced traffic distribution is stronger than the argument for protection against traffic correlation, because even mixing all messages to one proxy connection does not provide protection against traffic correlation by time, so in any case it requires adding delays. + ### Threat model for SMP proxy and changes to threat model for SMP #### SMP proxy diff --git a/rfcs/2023-10-25-remote-control.md b/rfcs/done/2023-10-25-remote-control.md similarity index 100% rename from rfcs/2023-10-25-remote-control.md rename to rfcs/done/2023-10-25-remote-control.md diff --git a/rfcs/2024-01-26-file-links.md b/rfcs/done/2024-01-26-file-links.md similarity index 100% rename from rfcs/2024-01-26-file-links.md rename to rfcs/done/2024-01-26-file-links.md diff --git a/rfcs/2024-02-03-deniability.md b/rfcs/done/2024-02-03-deniability.md similarity index 100% rename from rfcs/2024-02-03-deniability.md rename to rfcs/done/2024-02-03-deniability.md diff --git a/rfcs/2024-03-28-xftp-version.md b/rfcs/done/2024-03-28-xftp-version.md similarity index 100% rename from rfcs/2024-03-28-xftp-version.md rename to rfcs/done/2024-03-28-xftp-version.md diff --git a/rfcs/2021-02-28-streams.md b/rfcs/rejected/2021-02-28-streams.md similarity index 100% rename from rfcs/2021-02-28-streams.md rename to rfcs/rejected/2021-02-28-streams.md diff --git a/simplexmq.cabal b/simplexmq.cabal index 1bdd67c0b..0bfd62ce3 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplexmq -version: 5.7.0.4 +version: 6.0.0.1 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and @@ -28,6 +28,33 @@ extra-source-files: CHANGELOG.md cbits/sha512.h cbits/sntrup761.h + apps/smp-server/static/index.html + apps/smp-server/static/link.html + apps/smp-server/static/media/apk_icon.png + apps/smp-server/static/media/apple_store.svg + apps/smp-server/static/media/contact.js + apps/smp-server/static/media/contact_page_mobile.png + apps/smp-server/static/media/f_droid.svg + apps/smp-server/static/media/favicon.ico + apps/smp-server/static/media/GilroyBold.woff2 + apps/smp-server/static/media/GilroyLight.woff2 + apps/smp-server/static/media/GilroyMedium.woff2 + apps/smp-server/static/media/GilroyRegular.woff2 + apps/smp-server/static/media/GilroyRegularItalic.woff2 + apps/smp-server/static/media/google_play.svg + apps/smp-server/static/media/logo-dark.png + apps/smp-server/static/media/logo-light.png + apps/smp-server/static/media/logo-symbol-dark.svg + apps/smp-server/static/media/logo-symbol-light.svg + apps/smp-server/static/media/moon.svg + apps/smp-server/static/media/qrcode.js + apps/smp-server/static/media/script.js + apps/smp-server/static/media/style.css + apps/smp-server/static/media/sun.svg + apps/smp-server/static/media/swiper-bundle.min.css + apps/smp-server/static/media/swiper-bundle.min.js + apps/smp-server/static/media/tailwind.css + apps/smp-server/static/media/testflight.png flag swift description: Enable swift JSON format @@ -68,7 +95,7 @@ library Simplex.Messaging.Agent.Protocol Simplex.Messaging.Agent.QueryString Simplex.Messaging.Agent.RetryInterval - Simplex.Messaging.Agent.Server + Simplex.Messaging.Agent.Stats Simplex.Messaging.Agent.Store Simplex.Messaging.Agent.Store.SQLite Simplex.Messaging.Agent.Store.SQLite.Common @@ -105,6 +132,9 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client Simplex.Messaging.Client.Agent @@ -139,10 +169,12 @@ library Simplex.Messaging.Server.Control Simplex.Messaging.Server.Env.STM Simplex.Messaging.Server.Expiration + Simplex.Messaging.Server.Information Simplex.Messaging.Server.Main Simplex.Messaging.Server.MsgStore Simplex.Messaging.Server.MsgStore.STM Simplex.Messaging.Server.QueueStore + Simplex.Messaging.Server.QueueStore.QueueInfo Simplex.Messaging.Server.QueueStore.STM Simplex.Messaging.Server.Stats Simplex.Messaging.Server.StoreLog @@ -174,7 +206,7 @@ library src default-extensions: StrictData - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 include-dirs: cbits c-sources: @@ -255,82 +287,7 @@ executable ntf-server apps/ntf-server default-extensions: StrictData - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts - build-depends: - aeson ==2.2.* - , ansi-terminal >=0.10 && <0.12 - , asn1-encoding ==0.9.* - , asn1-types ==0.3.* - , async ==2.2.* - , attoparsec ==0.14.* - , base >=4.14 && <5 - , base64-bytestring >=1.0 && <1.3 - , case-insensitive ==1.2.* - , composition ==1.0.* - , constraints >=0.12 && <0.14 - , containers ==0.6.* - , crypton ==0.34.* - , crypton-x509 ==1.7.* - , crypton-x509-store ==1.6.* - , crypton-x509-validation ==1.6.* - , cryptostore ==0.3.* - , data-default ==0.7.* - , direct-sqlcipher ==2.3.* - , directory ==1.3.* - , filepath ==1.4.* - , hourglass ==0.2.* - , http-types ==0.12.* - , http2 >=4.2.2 && <4.3 - , ini ==0.4.1 - , iproute ==1.7.* - , iso8601-time ==0.1.* - , memory ==0.18.* - , mtl >=2.3.1 && <3.0 - , network >=3.1.2.7 && <3.2 - , network-info ==0.2.* - , network-transport ==0.5.6 - , network-udp ==0.0.* - , optparse-applicative >=0.15 && <0.17 - , process ==1.6.* - , random >=1.1 && <1.3 - , simple-logger ==0.1.* - , simplexmq - , socks ==0.6.* - , sqlcipher-simple ==0.4.* - , stm ==2.5.* - , temporary ==1.3.* - , time ==1.12.* - , time-manager ==0.0.* - , tls >=1.7.0 && <1.8 - , transformers ==0.6.* - , unliftio ==0.2.* - , unliftio-core ==0.2.* - , websockets ==0.12.* - , yaml ==0.11.* - , zstd ==0.1.3.* - default-language: Haskell2010 - if flag(swift) - cpp-options: -DswiftJSON - if impl(ghc >= 9.6.2) - build-depends: - bytestring ==0.11.* - , template-haskell ==2.20.* - , text >=2.0.1 && <2.2 - if impl(ghc < 9.6.2) - build-depends: - bytestring ==0.10.* - , template-haskell ==2.16.* - , text >=1.2.3.0 && <1.3 - -executable smp-agent - main-is: Main.hs - other-modules: - Paths_simplexmq - hs-source-dirs: - apps/smp-agent - default-extensions: - StrictData - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -400,12 +357,15 @@ executable smp-agent executable smp-server main-is: Main.hs other-modules: + Static + Static.Embedded Paths_simplexmq hs-source-dirs: apps/smp-server + apps/smp-server/web default-extensions: StrictData - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -427,6 +387,7 @@ executable smp-server , data-default ==0.7.* , direct-sqlcipher ==2.3.* , directory ==1.3.* + , file-embed , filepath ==1.4.* , hourglass ==0.2.* , http-types ==0.12.* @@ -455,6 +416,9 @@ executable smp-server , transformers ==0.6.* , unliftio ==0.2.* , unliftio-core ==0.2.* + , wai-app-static + , warp + , warp-tls , websockets ==0.12.* , yaml ==0.11.* , zstd ==0.1.3.* @@ -480,7 +444,7 @@ executable xftp apps/xftp default-extensions: StrictData - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -555,7 +519,7 @@ executable xftp-server apps/xftp-server default-extensions: StrictData - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -640,7 +604,6 @@ test-suite simplexmq-test CoreTests.CryptoFileTests CoreTests.CryptoTests CoreTests.EncodingTests - CoreTests.ProtocolErrorTests CoreTests.RetryIntervalTests CoreTests.TRcvQueuesTests CoreTests.UtilTests @@ -652,6 +615,7 @@ test-suite simplexmq-test ServerTests SMPAgentClient SMPClient + SMPProxyTests Util XFTPAgent XFTPCLI @@ -662,7 +626,7 @@ test-suite simplexmq-test tests default-extensions: StrictData - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1 + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1 build-depends: HUnit ==1.6.* , QuickCheck ==2.14.* diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index d04117942..4683143c5 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -32,12 +32,13 @@ import Control.Logger.Simple (logError) import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Control.Monad.Trans.Except import Data.Bifunctor (first) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Coerce (coerce) import Data.Composition ((.:)) -import Data.Either (rights) +import Data.Either (partitionEithers, rights) import Data.Int (Int64) import Data.List (foldl', partition, sortOn) import qualified Data.List.NonEmpty as L @@ -48,6 +49,7 @@ import qualified Data.Set as S import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Data.Time.Format (defaultTimeLocale, formatTime) +import Simplex.FileTransfer.Chunks (toKB) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Client.Main import Simplex.FileTransfer.Crypto @@ -56,11 +58,13 @@ import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types +import qualified Simplex.FileTransfer.Types as FT import Simplex.FileTransfer.Util (removePath, uniqueCombine) import Simplex.Messaging.Agent.Client import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval +import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C @@ -69,7 +73,8 @@ import qualified Simplex.Messaging.Crypto.File as CF import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String (strDecode, strEncode) -import Simplex.Messaging.Protocol (EntityId, XFTPServer) +import Simplex.Messaging.Protocol (EntityId, ProtocolServer, ProtocolType (..), XFTPServer) +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (catchAll_, liftError, tshow, unlessM, whenM) import System.FilePath (takeFileName, ()) import UnliftIO @@ -112,8 +117,8 @@ closeXFTPAgent a = do where stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker) -xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> AM RcvFileId -xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs = do +xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AM RcvFileId +xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs approvedRelays = do g <- asks random prefixPath <- lift $ getPrefixPath "rcv.xftp" createDirectory prefixPath @@ -124,7 +129,7 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi lift $ createEmptyFile =<< toFSFilePath relSavePath let saveFile = CryptoFile relSavePath cfArgs fId <- case redirect of - Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile + Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile approvedRelays Just _ -> do -- prepare description paths let relTmpPathRedirect = relPrefixPath "xftp.redirect-encrypted" @@ -134,14 +139,14 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi cfArgsRedirect <- atomically $ CF.randomArgs g let saveFileRedirect = CryptoFile relSavePathRedirect $ Just cfArgsRedirect -- create download tasks - withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile + withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile approvedRelays forM_ chunks (downloadChunk c) pure fId downloadChunk :: AgentClient -> FileChunk -> AM () downloadChunk c FileChunk {replicas = (FileChunkReplica {server} : _)} = do lift . void $ getXFTPRcvWorker True c (Just server) -downloadChunk _ _ = throwError $ INTERNAL "no replicas" +downloadChunk _ _ = throwE $ INTERNAL "no replicas" getPrefixPath :: String -> AM' FilePath getPrefixPath suffix = do @@ -174,29 +179,36 @@ runXFTPRcvWorker c srv Worker {doWork} = do runXFTPOperation cfg where runXFTPOperation :: AgentConfig -> AM () - runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} = + runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpConsecutiveRetries} = withWork c doWork (\db -> getNextRcvChunkToDownload db srv rcvFilesTTL) $ \case - RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas" - fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _} -> do + (RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _) -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (INTERNAL "chunk has no replicas") + (fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays) -> do let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do - lift $ waitForUserNetwork c - downloadFileChunk fc replica + liftIO $ waitForUserNetwork c + atomically $ incXFTPServerStat c userId srv downloadAttempts + downloadFileChunk fc replica approvedRelays `catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e where retryLoop loop e replicaDelay = do flip catchAgentError (\_ -> pure ()) $ do - when notifyOnRetry $ notify c rcvFileEntityId $ RFERR e + when (serverHostError e) $ notify c rcvFileEntityId $ RFWARN e liftIO $ closeXFTPServerClient c userId server digest withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay atomically $ assertAgentForeground c loop - retryDone e = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (show e) - downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> AM () - downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica = do + retryDone e = do + atomically . incXFTPServerStat c userId srv $ case e of + XFTP _ XFTP.AUTH -> downloadAuthErrs + _ -> downloadErrs + rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) e + downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> Bool -> AM () + downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica approvedRelays = do + unlessM ((approvedRelays ||) <$> ipAddressProtected') $ throwE $ FILE NOT_APPROVED fsFileTmpPath <- lift $ toFSFilePath fileTmpPath chunkPath <- uniqueCombine fsFileTmpPath $ show chunkNo - let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest) + let chSize = unFileSize chunkSize + chunkSpec = XFTPRcvChunkSpec chunkPath chSize (unFileDigest digest) relChunkPath = fileTmpPath takeFileName chunkPath agentXFTPDownloadChunk c userId digest replica chunkSpec atomically $ waitUntilForeground c @@ -210,10 +222,16 @@ runXFTPRcvWorker c srv Worker {doWork} = do Just RcvFileRedirect {redirectFileInfo = RedirectFileInfo {size = FileSize finalSize}, redirectEntityId} -> (redirectEntityId, finalSize) liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived pure (entityId, complete, RFPROG rcvd total) + atomically $ incXFTPServerStat c userId srv downloads + atomically $ incXFTPServerSizeStat c userId srv downloadsSize (fromIntegral $ toKB chSize) notify c entityId progress when complete . lift . void $ getXFTPRcvWorker True c Nothing where + ipAddressProtected' :: AM Bool + ipAddressProtected' = do + cfg <- liftIO $ getNetworkConfig' c + pure $ ipAddressProtected cfg srv receivedSize :: [RcvFileChunk] -> Int64 receivedSize = foldl' (\sz ch -> sz + receivedChunkSize ch) 0 receivedChunkSize ch@RcvFileChunk {chunkSize = s} @@ -230,15 +248,15 @@ withRetryIntervalLimit maxN ri action = retryOnError :: Text -> AM a -> AM a -> AgentErrorType -> AM a retryOnError name loop done e = do logError $ name <> " error: " <> tshow e - if temporaryAgentError e + if temporaryOrHostError e then loop else done -rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> String -> AM () -rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do +rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> AgentErrorType -> AM () +rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath err = do lift $ forM_ tmpPath (removePath <=< toFSFilePath) - withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr - notify c rcvFileEntityId $ RFERR $ INTERNAL internalErrStr + withStore' c $ \db -> updateRcvFileError db rcvFileId (show err) + notify c rcvFileEntityId $ RFERR err runXFTPRcvLocalWorker :: AgentClient -> Worker -> AM () runXFTPRcvLocalWorker c Worker {doWork} = do @@ -252,7 +270,7 @@ runXFTPRcvLocalWorker c Worker {doWork} = do runXFTPOperation AgentConfig {rcvFilesTTL} = withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $ \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} -> - decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show) + decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath decryptFile :: RcvFile -> AM () decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do let CryptoFile savePath cfArgs = saveFile @@ -262,11 +280,11 @@ runXFTPRcvLocalWorker c Worker {doWork} = do withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting chunkPaths <- getChunkPaths chunks encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths - when (FileSize encSize /= size) $ throwError $ XFTP XFTP.SIZE + when (FileSize encSize /= size) $ throwE $ XFTP "" XFTP.SIZE encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths - when (FileDigest encDigest /= digest) $ throwError $ XFTP XFTP.DIGEST + when (FileDigest encDigest /= digest) $ throwE $ XFTP "" XFTP.DIGEST let destFile = CryptoFile fsSavePath cfArgs - void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure destFile + void $ liftError (FILE . FILE_IO . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure destFile case redirect of Nothing -> do notify c rcvFileEntityId $ RFDONE fsSavePath @@ -279,12 +297,13 @@ runXFTPRcvLocalWorker c Worker {doWork} = do atomically $ waitUntilForeground c withStore' c (`updateRcvFileComplete` rcvFileId) -- proceed with redirect - yaml <- liftError (INTERNAL . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `agentFinally` (lift $ toFSFilePath fsSavePath >>= removePath) + yaml <- liftError (FILE . FILE_IO . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `agentFinally` (lift $ toFSFilePath fsSavePath >>= removePath) next@FileDescription {chunks = nextChunks} <- case strDecode (LB.toStrict yaml) of - Left _ -> throwError . XFTP $ XFTP.REDIRECT "decode error" + -- TODO switch to another error constructor + Left _ -> throwE . FILE $ REDIRECT "decode error" Right (ValidFileDescription fd@FileDescription {size = dstSize, digest = dstDigest}) - | dstSize /= redirectSize -> throwError . XFTP $ XFTP.REDIRECT "size mismatch" - | dstDigest /= redirectDigest -> throwError . XFTP $ XFTP.REDIRECT "digest mismatch" + | dstSize /= redirectSize -> throwE . FILE $ REDIRECT "size mismatch" + | dstDigest /= redirectDigest -> throwE . FILE $ REDIRECT "digest mismatch" | otherwise -> pure fd -- register and download chunks from the actual file withStore c $ \db -> updateRcvFileRedirect db redirectDbId next @@ -297,7 +316,7 @@ runXFTPRcvLocalWorker c Worker {doWork} = do fsPath <- lift $ toFSFilePath path pure $ fsPath : ps getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) = - throwError $ INTERNAL "no chunk path" + throwE $ INTERNAL "no chunk path" xftpDeleteRcvFile' :: AgentClient -> RcvFileId -> AM' () xftpDeleteRcvFile' c rcvFileEntityId = xftpDeleteRcvFiles' c [rcvFileEntityId] @@ -317,8 +336,8 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do batchFiles :: (DB.Connection -> DBRcvFileId -> IO a) -> [RcvFile] -> AM' [Either AgentErrorType a] batchFiles f rcvFiles = withStoreBatch' c $ \db -> map (\RcvFile {rcvFileId} -> f db rcvFileId) rcvFiles -notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> EntityId -> ACommand 'Agent e -> m () -notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, APC (sAEntity @e) cmd) +notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> EntityId -> AEvent e -> m () +notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd) xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId xftpSendFile' c userId file numRecipients = do @@ -342,7 +361,7 @@ xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {si let directYaml = prefixPath "direct.yaml" cfArgs <- atomically $ CF.randomArgs g let file = CryptoFile directYaml (Just cfArgs) - liftError (INTERNAL . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect) + liftError (FILE . FILE_IO . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect) key <- atomically $ C.randomSbKey g nonce <- atomically $ C.randomCbNonce g fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce $ Just RedirectFileInfo {size, digest} @@ -370,11 +389,11 @@ runXFTPSndPrepareWorker c Worker {doWork} = do runXFTPOperation cfg@AgentConfig {sndFilesTTL} = withWork c doWork (`getNextSndFileToPrepare` sndFilesTTL) $ \f@SndFile {sndFileId, sndFileEntityId, prefixPath} -> - prepareFile cfg f `catchAgentError` (sndWorkerInternalError c sndFileId sndFileEntityId prefixPath . show) + prepareFile cfg f `catchAgentError` sndWorkerInternalError c sndFileId sndFileEntityId prefixPath prepareFile :: AgentConfig -> SndFile -> AM () prepareFile _ SndFile {prefixPath = Nothing} = - throwError $ INTERNAL "no prefix path" - prepareFile cfg sndFile@SndFile {sndFileId, userId, prefixPath = Just ppath, status} = do + throwE $ INTERNAL "no prefix path" + prepareFile cfg sndFile@SndFile {sndFileId, sndFileEntityId, userId, prefixPath = Just ppath, status} = do SndFile {numRecipients, chunks} <- if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting then do @@ -388,9 +407,14 @@ runXFTPSndPrepareWorker c Worker {doWork} = do getSndFile db sndFileId else pure sndFile let numRecipients' = min numRecipients maxRecipients + -- in case chunk preparation previously failed mid-way, some chunks may already be created - + -- here we split previously prepared chunks from the pending ones to then build full list of servers + let (pendingChunks, preparedSrvs) = partitionEithers $ map srvOrPendingChunk chunks -- concurrently? -- separate worker to create chunks? record retries and delay on snd_file_chunks? - forM_ (filter (\SndFileChunk {replicas} -> null replicas) chunks) $ createChunk numRecipients' + srvs <- forM pendingChunks $ createChunk numRecipients' + let allSrvs = S.fromList $ preparedSrvs <> srvs + lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv) withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading where AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients, messageRetryInterval = ri} = cfg @@ -399,48 +423,60 @@ runXFTPSndPrepareWorker c Worker {doWork} = do let CryptoFile {filePath} = srcFile fileName = takeFileName filePath fileSize <- liftIO $ fromInteger <$> CF.getFileContentsSize srcFile - when (fileSize > maxFileSizeHard) $ throwError $ INTERNAL "max file size exceeded" + when (fileSize > maxFileSizeHard) $ throwE $ FILE FT.SIZE let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing} fileSize' = fromIntegral (B.length fileHdr) + fileSize payloadSize = fileSize' + fileSizeLen + authTagSize chunkSizes <- case redirect of Nothing -> pure $ prepareChunkSizes payloadSize Just _ -> case singleChunkSize payloadSize of - Nothing -> throwError $ INTERNAL "max file size exceeded for redirect" + Nothing -> throwE $ FILE FT.SIZE Just chunkSize -> pure [chunkSize] let encSize = sum $ map fromIntegral chunkSizes - void $ liftError (INTERNAL . show) $ encryptFile srcFile fileHdr key nonce fileSize' encSize fsEncPath + void $ liftError (FILE . FILE_IO . show) $ encryptFile srcFile fileHdr key nonce fileSize' encSize fsEncPath digest <- liftIO $ LC.sha512Hash <$> LB.readFile fsEncPath let chunkSpecs = prepareChunkSpecs fsEncPath chunkSizes chunkDigests <- liftIO $ mapM getChunkDigest chunkSpecs pure (FileDigest digest, zip chunkSpecs $ coerce chunkDigests) - createChunk :: Int -> SndFileChunk -> AM () + srvOrPendingChunk :: SndFileChunk -> Either SndFileChunk (ProtocolServer 'PXFTP) + srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of + [] -> Left ch + SndFileChunkReplica {server} : _ -> Right server + createChunk :: Int -> SndFileChunk -> AM (ProtocolServer 'PXFTP) createChunk numRecipients' ch = do atomically $ assertAgentForeground c (replica, ProtoServerWithAuth srv _) <- tryCreate withStore' c $ \db -> createSndFileReplica db ch replica - lift . void $ getXFTPSndWorker True c (Just srv) + pure srv where tryCreate = do usedSrvs <- newTVarIO ([] :: [XFTPServer]) - withRetryInterval (riFast ri) $ \_ loop -> do - lift $ waitForUserNetwork c + let AgentClient {xftpServers} = c + userSrvCount <- length <$> atomically (TM.lookup userId xftpServers) + withRetryIntervalCount (riFast ri) $ \n _ loop -> do + liftIO $ waitForUserNetwork c + let triedAllSrvs = n > userSrvCount createWithNextSrv usedSrvs - `catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e + `catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop triedAllSrvs e) (throwE e) e where - retryLoop loop = atomically (assertAgentForeground c) >> loop + -- we don't do closeXFTPServerClient here to not risk closing connection for concurrent chunk upload + retryLoop loop triedAllSrvs e = do + flip catchAgentError (\_ -> pure ()) $ do + when (triedAllSrvs && serverHostError e) $ notify c sndFileEntityId $ SFWARN e + atomically $ assertAgentForeground c + loop createWithNextSrv usedSrvs = do deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId - when deleted $ throwError $ INTERNAL "file deleted, aborting chunk creation" + when deleted $ throwE $ FILE NO_FILE withNextSrv c userId usedSrvs [] $ \srvAuth -> do replica <- agentXFTPNewChunk c ch numRecipients' srvAuth pure (replica, srvAuth) -sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> String -> AM () -sndWorkerInternalError c sndFileId sndFileEntityId prefixPath internalErrStr = do +sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM () +sndWorkerInternalError c sndFileId sndFileEntityId prefixPath err = do lift . forM_ prefixPath $ removePath <=< toFSFilePath - withStore' c $ \db -> updateSndFileError db sndFileId internalErrStr - notify c sndFileEntityId $ SFERR $ INTERNAL internalErrStr + withStore' c $ \db -> updateSndFileError db sndFileId (show err) + notify c sndFileEntityId $ SFERR err runXFTPSndWorker :: AgentClient -> XFTPServer -> Worker -> AM () runXFTPSndWorker c srv Worker {doWork} = do @@ -451,29 +487,32 @@ runXFTPSndWorker c srv Worker {doWork} = do runXFTPOperation cfg where runXFTPOperation :: AgentConfig -> AM () - runXFTPOperation cfg@AgentConfig {sndFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} = do + runXFTPOperation cfg@AgentConfig {sndFilesTTL, reconnectInterval = ri, xftpConsecutiveRetries} = do withWork c doWork (\db -> getNextSndChunkToUpload db srv sndFilesTTL) $ \case - SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) "chunk has no replicas" + SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) (INTERNAL "chunk has no replicas") fc@SndFileChunk {userId, sndFileId, sndFileEntityId, filePrefixPath, digest, replicas = replica@SndFileChunkReplica {sndChunkReplicaId, server, delay} : _} -> do let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do - lift $ waitForUserNetwork c + liftIO $ waitForUserNetwork c + atomically $ incXFTPServerStat c userId srv uploadAttempts uploadFileChunk cfg fc replica `catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e where retryLoop loop e replicaDelay = do flip catchAgentError (\_ -> pure ()) $ do - when notifyOnRetry $ notify c sndFileEntityId $ SFERR e + when (serverHostError e) $ notify c sndFileEntityId $ SFWARN e liftIO $ closeXFTPServerClient c userId server digest withStore' c $ \db -> updateSndChunkReplicaDelay db sndChunkReplicaId replicaDelay atomically $ assertAgentForeground c loop - retryDone e = sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) (show e) + retryDone e = do + atomically $ incXFTPServerStat c userId srv uploadErrs + sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) e uploadFileChunk :: AgentConfig -> SndFileChunk -> SndFileChunkReplica -> AM () - uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath}, digest = chunkDigest} replica = do + uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath, chunkSize = chSize}, digest = chunkDigest} replica = do replica'@SndFileChunkReplica {sndChunkReplicaId} <- addRecipients sndFileChunk replica fsFilePath <- lift $ toFSFilePath filePath - unlessM (doesFileExist fsFilePath) $ throwError $ INTERNAL "encrypted file doesn't exist on upload" + unlessM (doesFileExist fsFilePath) $ throwE $ FILE NO_FILE let chunkSpec' = chunkSpec {filePath = fsFilePath} :: XFTPChunkSpec atomically $ assertAgentForeground c agentXFTPUploadChunk c userId chunkDigest replica' chunkSpec' @@ -484,6 +523,8 @@ runXFTPSndWorker c srv Worker {doWork} = do let uploaded = uploadedSize chunks total = totalSize chunks complete = all chunkUploaded chunks + atomically $ incXFTPServerStat c userId srv uploads + atomically $ incXFTPServerSizeStat c userId srv uploadsSize (fromIntegral $ toKB chSize) notify c sndFileEntityId $ SFPROG uploaded total when complete $ do (sndDescr, rcvDescrs) <- sndFileToDescrs sf @@ -493,7 +534,7 @@ runXFTPSndWorker c srv Worker {doWork} = do where addRecipients :: SndFileChunk -> SndFileChunkReplica -> AM SndFileChunkReplica addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {rcvIdsKeys} - | length rcvIdsKeys > numRecipients = throwError $ INTERNAL "too many recipients" + | length rcvIdsKeys > numRecipients = throwE $ INTERNAL "too many recipients" | length rcvIdsKeys == numRecipients = pure cr | otherwise = do let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients @@ -501,22 +542,22 @@ runXFTPSndWorker c srv Worker {doWork} = do cr' <- withStore' c $ \db -> addSndChunkReplicaRecipients db cr $ L.toList rcvIdsKeys' addRecipients ch cr' sndFileToDescrs :: SndFile -> AM (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient]) - sndFileToDescrs SndFile {digest = Nothing} = throwError $ INTERNAL "snd file has no digest" - sndFileToDescrs SndFile {chunks = []} = throwError $ INTERNAL "snd file has no chunks" + sndFileToDescrs SndFile {digest = Nothing} = throwE $ INTERNAL "snd file has no digest" + sndFileToDescrs SndFile {chunks = []} = throwE $ INTERNAL "snd file has no chunks" sndFileToDescrs SndFile {digest = Just digest, key, nonce, chunks = chunks@(fstChunk : _), redirect} = do let chunkSize = FileSize $ sndChunkSize fstChunk size = FileSize $ sum $ map (fromIntegral . sndChunkSize) chunks -- snd description sndDescrChunks <- mapM toSndDescrChunk chunks let fdSnd = FileDescription {party = SFSender, size, digest, key, nonce, chunkSize, chunks = sndDescrChunks, redirect = Nothing} - validFdSnd <- either (throwError . INTERNAL) pure $ validateFileDescription fdSnd + validFdSnd <- either (throwE . INTERNAL) pure $ validateFileDescription fdSnd -- rcv descriptions let fdRcv = FileDescription {party = SFRecipient, size, digest, key, nonce, chunkSize, chunks = [], redirect} fdRcvs = createRcvFileDescriptions fdRcv chunks - validFdRcvs <- either (throwError . INTERNAL) pure $ mapM validateFileDescription fdRcvs + validFdRcvs <- either (throwE . INTERNAL) pure $ mapM validateFileDescription fdRcvs pure (validFdSnd, validFdRcvs) toSndDescrChunk :: SndFileChunk -> AM FileChunk - toSndDescrChunk SndFileChunk {replicas = []} = throwError $ INTERNAL "snd file chunk has no replicas" + toSndDescrChunk SndFileChunk {replicas = []} = throwE $ INTERNAL "snd file chunk has no replicas" toSndDescrChunk ch@SndFileChunk {chunkNo, digest = chDigest, replicas = (SndFileChunkReplica {server, replicaId, replicaKey} : _)} = do let chunkSize = FileSize $ sndChunkSize ch replicas = [FileChunkReplica {server, replicaId, replicaKey}] @@ -617,28 +658,32 @@ runXFTPDelWorker c srv Worker {doWork} = do runXFTPOperation cfg where runXFTPOperation :: AgentConfig -> AM () - runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} = do + runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpConsecutiveRetries} = do -- no point in deleting files older than rcv ttl, as they will be expired on server withWork c doWork (\db -> getNextDeletedSndChunkReplica db srv rcvFilesTTL) processDeletedReplica where processDeletedReplica replica@DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, chunkDigest, delay} = do let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do - lift $ waitForUserNetwork c + liftIO $ waitForUserNetwork c + atomically $ incXFTPServerStat c userId srv deleteAttempts deleteChunkReplica `catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e where retryLoop loop e replicaDelay = do flip catchAgentError (\_ -> pure ()) $ do - when notifyOnRetry $ notify c "" $ SFERR e + when (serverHostError e) $ notify c "" $ SFWARN e liftIO $ closeXFTPServerClient c userId server chunkDigest withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay atomically $ assertAgentForeground c loop - retryDone = delWorkerInternalError c deletedSndChunkReplicaId + retryDone e = do + atomically $ incXFTPServerStat c userId srv deleteErrs + delWorkerInternalError c deletedSndChunkReplicaId e deleteChunkReplica = do agentXFTPDeleteChunk c userId replica withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId + atomically $ incXFTPServerStat c userId srv deletions delWorkerInternalError :: AgentClient -> Int64 -> AgentErrorType -> AM () delWorkerInternalError c deletedSndChunkReplicaId e = do diff --git a/src/Simplex/FileTransfer/Chunks.hs b/src/Simplex/FileTransfer/Chunks.hs index 0b35649c5..d8890944d 100644 --- a/src/Simplex/FileTransfer/Chunks.hs +++ b/src/Simplex/FileTransfer/Chunks.hs @@ -26,6 +26,10 @@ kb :: Integral a => a -> a kb n = 1024 * n {-# INLINE kb #-} +toKB :: Integral a => a -> a +toKB n = n `div` 1024 +{-# INLINE toKB #-} + mb :: Integral a => a -> a mb n = 1024 * kb n {-# INLINE mb #-} diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 6cae2dd59..1404fd434 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -14,6 +14,7 @@ module Simplex.FileTransfer.Client where import Control.Logger.Simple import Control.Monad import Control.Monad.Except +import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import Data.Bifunctor (first) import Data.ByteString.Builder (Builder, byteString) @@ -21,7 +22,6 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Time (UTCTime) import Data.Word (Word32) import qualified Data.X509 as X import qualified Data.X509.Validation as XV @@ -38,8 +38,8 @@ import Simplex.Messaging.Client defaultNetworkConfig, proxyUsername, transportClientConfig, + unexpectedResponse, ) -import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding (smpDecode, smpEncode) @@ -51,13 +51,13 @@ import Simplex.Messaging.Protocol RecipientId, SenderId, ) -import Simplex.Messaging.Transport (ALPN, HandshakeError (VERSION), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters) +import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters) import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.Client import Simplex.Messaging.Transport.HTTP2.File -import Simplex.Messaging.Util (bshow, liftEitherWith, liftError', tshow, whenM) -import Simplex.Messaging.Version (compatibleVersion, pattern Compatible) +import Simplex.Messaging.Util (liftEitherWith, liftError', tshow, whenM) +import Simplex.Messaging.Version import UnliftIO import UnliftIO.Directory @@ -99,22 +99,23 @@ defaultXFTPClientConfig = getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do - let tcConfig = (transportClientConfig xftpNetworkConfig) {alpn = clientALPN} - http2Config = xftpHTTP2Config tcConfig config - username = proxyUsername transportSession + let username = proxyUsername transportSession ProtocolServer _ host port keyHash = srv useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host + let tcConfig = (transportClientConfig xftpNetworkConfig useHost) {alpn = clientALPN} + http2Config = xftpHTTP2Config tcConfig config clientVar <- newTVarIO Nothing let usePort = if null port then "443" else port clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected let HTTP2Client {sessionId, sessionALPN} = http2Client - thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = VersionXFTP 1, thAuth = Nothing, implySessId = False, batch = True} + v = VersionXFTP 1 + thServerVRange = versionToRange v + thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True} logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN thParams@THandleParams {thVersion} <- case sessionALPN of Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0 - Nothing -> pure thParams0 - _ -> throwError $ PCETransportError (TEHandshake VERSION) + _ -> pure thParams0 logDebug $ "Client negotiated protocol: " <> tshow thVersion let c = XFTPClient {http2Client, thParams, transportSession, config} atomically $ writeTVar clientVar $ Just c @@ -123,23 +124,24 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient) xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do shs@XFTPServerHandshake {authPubKey = ck} <- getServerHandshake - (v, sk) <- processServerHandshake shs + (vr, sk) <- processServerHandshake shs + let v = maxVersion vr sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash} - pure thParams0 {thAuth = Just THAuthClient {serverPeerPubKey = sk, serverCertKey = ck, sessSecret = Nothing}, thVersion = v} + pure thParams0 {thAuth = Just THAuthClient {serverPeerPubKey = sk, serverCertKey = ck, sessSecret = Nothing}, thVersion = v, thServerVRange = vr} where getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake getServerHandshake = do let helloReq = H.requestNoBody "POST" "/" [] HTTP2Response {respBody = HTTP2Body {bodyHead = shsBody}} <- - liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c helloReq Nothing - liftHS . smpDecode =<< liftHS (C.unPad shsBody) - processServerHandshake :: XFTPServerHandshake -> ExceptT XFTPClientError IO (VersionXFTP, C.PublicKeyX25519) + liftError' xftpClientError $ sendRequest c helloReq Nothing + liftTransportErr (TEHandshake PARSE) . smpDecode =<< liftTransportErr TEBadBlock (C.unPad shsBody) + processServerHandshake :: XFTPServerHandshake -> ExceptT XFTPClientError IO (VersionRangeXFTP, C.PublicKeyX25519) processServerHandshake XFTPServerHandshake {xftpVersionRange, sessionId = serverSessId, authPubKey = serverAuth} = do - unless (sessionId == serverSessId) $ throwError $ PCEResponseError SESSION - case xftpVersionRange `compatibleVersion` serverVRange of - Nothing -> throwError $ PCEResponseError HANDSHAKE - Just (Compatible v) -> - fmap (v,) . liftHS $ do + unless (sessionId == serverSessId) $ throwE $ PCETransportError TEBadSession + case xftpVersionRange `compatibleVRange` serverVRange of + Nothing -> throwE $ PCETransportError TEVersion + Just (Compatible vr) -> + fmap (vr,) . liftTransportErr (TEHandshake BAD_AUTH) $ do let (X.CertificateChain cert, exact) = serverAuth case cert of [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure () @@ -148,11 +150,11 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session C.x509ToPublic (pubKey, []) >>= C.pubKey sendClientHandshake :: XFTPClientHandshake -> ExceptT XFTPClientError IO () sendClientHandshake chs = do - chs' <- liftHS $ C.pad (smpEncode chs) xftpBlockSize + chs' <- liftTransportErr TELargeMsg $ C.pad (smpEncode chs) xftpBlockSize let chsReq = H.requestBuilder "POST" "/" [] $ byteString chs' - HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c chsReq Nothing - unless (B.null bodyHead) $ throwError $ PCEResponseError HANDSHAKE - liftHS = liftEitherWith (const $ PCEResponseError HANDSHAKE) + HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftError' xftpClientError $ sendRequest c chsReq Nothing + unless (B.null bodyHead) $ throwE $ PCETransportError TEBadBlock + liftTransportErr e = liftEitherWith (const $ PCETransportError e) closeXFTPClient :: XFTPClient -> IO () closeXFTPClient XFTPClient {http2Client} = closeHTTP2Client http2Client @@ -165,9 +167,6 @@ xftpClientServer = B.unpack . strEncode . snd3 . transportSession xftpTransportHost :: XFTPClient -> TransportHost xftpTransportHost XFTPClient {http2Client = HTTP2Client {client_ = HClient {host}}} = host -xftpSessionTs :: XFTPClient -> UTCTime -xftpSessionTs = sessionTs . http2Client - xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfig xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = defaultHTTP2ClientConfig @@ -185,9 +184,11 @@ xftpClientError = \case sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body) sendXFTPCommand c@XFTPClient {thParams} pKey fId cmd chunkSpec_ = do + -- TODO random corrId + let corrIdUsedAsNonce = "" t <- liftEither . first PCETransportError $ - xftpEncodeAuthTransmission thParams pKey ("", fId, FileCmd (sFileParty @p) cmd) + xftpEncodeAuthTransmission thParams pKey (corrIdUsedAsNonce, fId, FileCmd (sFileParty @p) cmd) sendXFTPTransmission c t chunkSpec_ sendXFTPTransmission :: XFTPClient -> ByteString -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body) @@ -195,14 +196,14 @@ sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = d let req = H.requestStreaming N.methodPost "/" [] streamBody reqTimeout = xftpReqTimeout config $ (\XFTPChunkSpec {chunkSize} -> chunkSize) <$> chunkSpec_ HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req (Just reqTimeout) - when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK + when (B.length bodyHead /= xftpBlockSize) $ throwE $ PCEResponseError BLOCK -- TODO validate that the file ID is the same as in the request? (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead case respOrErr of Right r -> case protocolError r of - Just e -> throwError $ PCEProtocolError e + Just e -> throwE $ PCEProtocolError e _ -> pure (r, body) - Left e -> throwError $ PCEResponseError e + Left e -> throwE $ PCEResponseError e where streamBody :: (Builder -> IO ()) -> IO () -> IO () streamBody send done = do @@ -210,7 +211,7 @@ sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = d forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} -> withFile filePath ReadMode $ \h -> do hSeek h AbsoluteSeek $ fromIntegral chunkOffset - hSendFile h send $ fromIntegral chunkSize + hSendFile h send chunkSize done createXFTPChunk :: @@ -223,13 +224,13 @@ createXFTPChunk :: createXFTPChunk c spKey file rcps auth_ = sendXFTPCommand c spKey "" (FNEW file rcps auth_) Nothing >>= \case (FRSndIds sId rIds, body) -> noFile body (sId, rIds) - (r, _) -> throwError . PCEUnexpectedResponse $ bshow r + (r, _) -> throwE $ unexpectedResponse r addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId) addXFTPRecipients c spKey fId rcps = sendXFTPCommand c spKey fId (FADD rcps) Nothing >>= \case (FRRcvIds rIds, body) -> noFile body rIds - (r, _) -> throwError . PCEUnexpectedResponse $ bshow r + (r, _) -> throwE $ unexpectedResponse r uploadXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO () uploadXFTPChunk c spKey fId chunkSpec = @@ -245,14 +246,19 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec { let dhSecret = C.dh' sDhKey rpDhKey cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce let t = chunkTimeout config chunkSize - ExceptT (sequence <$> (t `timeout` download cbState)) >>= maybe (throwError PCEResponseTimeout) pure + ExceptT (sequence <$> (t `timeout` (download cbState `catches` errors))) >>= maybe (throwE PCEResponseTimeout) pure where + errors = + [ Handler $ \(_e :: H.HTTP2Error) -> pure $ Left PCENetworkError, + Handler $ \(e :: IOException) -> pure $ Left (PCEIOError e), + Handler $ \(_e :: SomeException) -> pure $ Left PCENetworkError + ] download cbState = runExceptT . withExceptT PCEResponseError $ receiveEncFile chunkPart cbState chunkSpec `catchError` \e -> - whenM (doesFileExist filePath) (removeFile filePath) >> throwError e - _ -> throwError $ PCEResponseError NO_FILE - (r, _) -> throwError . PCEUnexpectedResponse $ bshow r + whenM (doesFileExist filePath) (removeFile filePath) >> throwE e + _ -> throwE $ PCEResponseError NO_FILE + (r, _) -> throwE $ unexpectedResponse r xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ = @@ -276,17 +282,17 @@ pingXFTP c@XFTPClient {thParams} = do (r, _) <- sendXFTPTransmission c t Nothing case r of FRPong -> pure () - _ -> throwError $ PCEUnexpectedResponse $ bshow r + _ -> throwE $ unexpectedResponse r okResponse :: (FileResponse, HTTP2Body) -> ExceptT XFTPClientError IO () okResponse = \case (FROk, body) -> noFile body () - (r, _) -> throwError . PCEUnexpectedResponse $ bshow r + (r, _) -> throwE $ unexpectedResponse r -- TODO this currently does not check anything because response size is not set and bodyPart is always Just noFile :: HTTP2Body -> a -> ExceptT XFTPClientError IO a noFile HTTP2Body {bodyPart} a = case bodyPart of - Just _ -> pure a -- throwError $ PCEResponseError HAS_FILE + Just _ -> pure a -- throwE $ PCEResponseError HAS_FILE _ -> pure a -- FACK :: FileCommand Recipient diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs index 1dafc8108..86b093ee7 100644 --- a/src/Simplex/FileTransfer/Client/Agent.hs +++ b/src/Simplex/FileTransfer/Client/Agent.hs @@ -11,6 +11,7 @@ import Control.Logger.Simple (logInfo) import Control.Monad import Control.Monad.Except import Control.Monad.Trans (lift) +import Control.Monad.Trans.Except import Data.Bifunctor (first) import qualified Data.ByteString.Char8 as B import Data.Text (Text) @@ -18,7 +19,6 @@ import Data.Text.Encoding (decodeUtf8) import Simplex.FileTransfer.Client import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError) -import Simplex.Messaging.Client.Agent () import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer) import Simplex.Messaging.TMap (TMap) @@ -109,7 +109,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do else atomically $ do putTMVar clientVar r TM.delete srv xftpClients - throwError e + throwE e tryConnectAsync :: ME () tryConnectAsync = void . lift . async . runExceptT $ do withRetryInterval (reconnectInterval config) $ \_ loop -> void $ tryConnectClient loop diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index b3fa494ed..aeac956e6 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -30,6 +30,7 @@ where import Control.Logger.Simple import Control.Monad import Control.Monad.Except +import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) @@ -292,7 +293,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re encryptFileForUpload :: TVar ChaChaDRG -> String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64) encryptFileForUpload g fileName = do fileSize <- fromInteger <$> getFileSize filePath - when (fileSize > maxFileSize) $ throwError $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported" + when (fileSize > maxFileSize) $ throwE $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported" encPath <- getEncPath tempPath "xftp" key <- atomically $ C.randomSbKey g nonce <- atomically $ C.randomCbNonce g @@ -323,7 +324,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re -- upload doesn't allow other requests within the same client until complete (but download does allow). logInfo $ "uploading " <> tshow (length chunks) <> " chunks..." (errs, rs) <- partitionEithers . concat <$> liftIO (pooledForConcurrentlyN 16 chunks' . mapM $ runExceptT . uploadFileChunk a) - mapM_ throwError errs + mapM_ throwE errs pure $ map snd (sortOn fst rs) where uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk) @@ -332,7 +333,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g) digest <- liftIO $ getChunkDigest chunkSpec - let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest} + let ch = FileInfo {sndKey, size = chunkSize, digest} c <- withRetry retryCount $ getXFTPServerClient a xftpServer (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec @@ -344,7 +345,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re when verbose $ putStrLn "" let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys replicas = [SentFileChunkReplica {server = xftpServer, recipients}] - pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize $ fromIntegral chunkSize, digest = FileDigest digest, replicas}) + pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize chunkSize, digest = FileDigest digest, replicas}) getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth getXFTPServer gen = \case srv :| [] -> pure srv @@ -437,12 +438,12 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, srvChunks = groupAllOn srv chunks g <- liftIO C.newRandom (errs, rs) <- partitionEithers . concat <$> liftIO (pooledForConcurrentlyN 16 srvChunks $ mapM $ runExceptT . downloadFileChunk g a encPath size downloadedChunks) - mapM_ throwError errs + mapM_ throwE errs let chunkPaths = map snd $ sortOn fst rs encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths - when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch" + when (encDigest /= unFileDigest digest) $ throwE $ CLIError "File digest mismatch" encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths - when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch" + when (FileSize encSize /= size) $ throwE $ CLIError "File size mismatch" liftIO $ printNoNewLine "Decrypting file..." CryptoFile path _ <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce $ fmap CF.plain . getFilePath forM_ chunks $ acknowledgeFileChunk a @@ -464,20 +465,20 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, printProgress "Downloaded" downloaded encSize when verbose $ putStrLn "" pure (chunkNo, chunkPath) - downloadFileChunk _ _ _ _ _ _ = throwError $ CLIError "chunk has no replicas" + downloadFileChunk _ _ _ _ _ _ = throwE $ CLIError "chunk has no replicas" getFilePath :: String -> ExceptT String IO FilePath getFilePath name = case filePath of Just path -> ifM (doesDirectoryExist path) (uniqueCombine path name) $ - ifM (doesFileExist path) (throwError "File already exists") (pure path) + ifM (doesFileExist path) (throwE "File already exists") (pure path) _ -> (`uniqueCombine` name) . ( "Downloads") =<< getHomeDirectory acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO () acknowledgeFileChunk a FileChunk {replicas = replica : _} = do let FileChunkReplica {server, replicaId, replicaKey} = replica c <- withRetry retryCount $ getXFTPServerClient a server withRetry retryCount $ ackXFTPChunk c replicaKey (unChunkReplicaId replicaId) - acknowledgeFileChunk _ _ = throwError $ CLIError "chunk has no replicas" + acknowledgeFileChunk _ _ = throwE $ CLIError "chunk has no replicas" printProgress :: String -> Int64 -> Int64 -> IO () printProgress s part total = printNoNewLine $ s <> " " <> show ((part * 100) `div` total) <> "%" @@ -503,7 +504,7 @@ cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do let FileChunkReplica {server, replicaId, replicaKey} = replica withReconnect a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId) logInfo $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server - deleteFileChunk _ _ = throwError $ CLIError "chunk has no replicas" + deleteFileChunk _ _ = throwE $ CLIError "chunk has no replicas" cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO () cliFileDescrInfo InfoOptions {fileDescription} = do @@ -533,7 +534,7 @@ getFileDescription path = getFileDescription' :: FilePartyI p => FilePath -> ExceptT CLIError IO (ValidFileDescription p) getFileDescription' path = getFileDescription path >>= \case - AVFD fd -> either (throwError . CLIError) pure $ checkParty fd + AVFD fd -> either (throwE . CLIError) pure $ checkParty fd singleChunkSize :: Int64 -> Maybe Word32 singleChunkSize size' = @@ -563,7 +564,7 @@ prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) c where addSpec :: (Int64, [XFTPChunkSpec]) -> Word32 -> (Int64, [XFTPChunkSpec]) addSpec (chunkOffset, specs) sz = - let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = fromIntegral sz} + let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = sz} in (chunkOffset + fromIntegral sz, spec : specs) getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath @@ -574,13 +575,13 @@ withReconnect a srv n run = withRetry n $ do c <- withRetry n $ getXFTPServerClient a srv withExceptT (CLIError . show) (run c) `catchError` \e -> do liftIO $ closeXFTPServerClient a srv - throwError e + throwE e withRetry :: Show e => Int -> ExceptT e IO a -> ExceptT CLIError IO a withRetry retryCount = withRetry' retryCount . withExceptT (CLIError . show) where withRetry' :: Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a - withRetry' 0 _ = throwError $ CLIError "internal: no retry attempts" + withRetry' 0 _ = throwE $ CLIError "internal: no retry attempts" withRetry' 1 a = a withRetry' n a = a `catchError` \e -> do diff --git a/src/Simplex/FileTransfer/Crypto.hs b/src/Simplex/FileTransfer/Crypto.hs index 547a5675a..72344f3c0 100644 --- a/src/Simplex/FileTransfer/Crypto.hs +++ b/src/Simplex/FileTransfer/Crypto.hs @@ -8,6 +8,7 @@ module Simplex.FileTransfer.Crypto where import Control.Monad import Control.Monad.Except +import Control.Monad.Trans.Except import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) import qualified Data.ByteArray as BA @@ -48,17 +49,17 @@ encryptFile srcFile fileHdr key nonce fileSize' encSize encFile = do | otherwise = do let chSize = min len 65536 ch <- liftIO $ get chSize - when (B.length ch /= fromIntegral chSize) $ throwError $ FTCEFileIOError "encrypting file: unexpected EOF" + when (B.length ch /= fromIntegral chSize) $ throwE $ FTCEFileIOError "encrypting file: unexpected EOF" let (ch', sb') = LC.sbEncryptChunk sb ch liftIO $ B.hPut w ch' encryptChunks_ get w (sb', len - chSize) decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO CryptoFile) -> ExceptT FTCryptoError IO CryptoFile -decryptChunks _ [] _ _ _ = throwError $ FTCEInvalidHeader "empty" +decryptChunks _ [] _ _ _ = throwE $ FTCEInvalidHeader "empty" decryptChunks encSize (chPath : chPaths) key nonce getDestFile = case reverse chPaths of [] -> do (!authOk, !f) <- liftEither . first FTCECryptoError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (LB.readFile chPath) - unless authOk $ throwError FTCEInvalidAuthTag + unless authOk $ throwE FTCEInvalidAuthTag (FileHeader {fileName}, !f') <- parseFileHeader f destFile <- withExceptT FTCEFileIOError $ getDestFile fileName CF.writeFile destFile f' @@ -73,7 +74,7 @@ decryptChunks encSize (chPath : chPaths) key nonce getDestFile = case reverse ch decryptLastChunk h state' expectedLen unless authOk $ do removeFile path - throwError FTCEInvalidAuthTag + throwE FTCEInvalidAuthTag pure destFile where decryptFirstChunk = do @@ -105,8 +106,8 @@ decryptChunks encSize (chPath : chPaths) key nonce getDestFile = case reverse ch parseFileHeader s = do let (hdrStr, s') = LB.splitAt 1024 s case A.parse smpP $ LB.toStrict hdrStr of - A.Fail _ _ e -> throwError $ FTCEInvalidHeader e - A.Partial _ -> throwError $ FTCEInvalidHeader "incomplete" + A.Fail _ _ e -> throwE $ FTCEInvalidHeader e + A.Partial _ -> throwE $ FTCEInvalidHeader "incomplete" A.Done rest hdr -> pure (hdr, LB.fromStrict rest <> s') readChunks :: [FilePath] -> IO LB.ByteString diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 418e48482..c55b327f8 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -48,6 +48,7 @@ import Simplex.Messaging.Protocol SndPublicAuthKey, Transmission, TransmissionForAuth (..), + CorrId (..), encodeTransmission, encodeTransmissionForAuth, messageTagP, @@ -328,7 +329,7 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion 'TClient -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey (corrId, fId, msg) = do let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, fId, msg) - xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth (Just pKey) corrId tForAuth + xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth (Just pKey) (C.cbNonce $ bs corrId) tForAuth xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString xftpEncodeTransmission thParams (corrId, fId, msg) = do diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 7b6787a43..24dcc5e38 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -17,6 +18,7 @@ import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Control.Monad.Trans.Except import Data.Bifunctor (first) import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Builder (Builder, byteString) @@ -63,10 +65,13 @@ import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize) import Simplex.Messaging.Transport.HTTP2.Server import Simplex.Messaging.Transport.Server (runTCPServer, tlsServerCredentials) import Simplex.Messaging.Util -import Simplex.Messaging.Version (isCompatible) +import Simplex.Messaging.Version import System.Exit (exitFailure) import System.FilePath (()) import System.IO (hPrint, hPutStrLn, universalNewlineMode) +#ifdef slow_servers +import System.Random (getStdRandom, randomR) +#endif import UnliftIO import UnliftIO.Concurrent (threadDelay) import UnliftIO.Directory (doesFileExist, removeFile, renameFile) @@ -91,10 +96,10 @@ runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpSer data Handshake = HandshakeSent C.PrivateKeyX25519 - | HandshakeAccepted (THandleAuth 'TServer) VersionXFTP + | HandshakeAccepted (THandleParams XFTPVersion 'TServer) xftpServer :: XFTPServerConfig -> TMVar Bool -> M () -xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration} started = do +xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do mapM_ (expireServerFiles Nothing) fileExpiration restoreServerStats raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer @@ -111,7 +116,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira let cleanup sessionId = atomically $ TM.delete sessionId sessions liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do reqBody <- getHTTP2Body r xftpBlockSize - let thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = VersionXFTP 1, thAuth = Nothing, implySessId = False, batch = True} + let v = VersionXFTP 1 + thServerVRange = versionToRange v + thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True} req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse} flip runReaderT env $ case sessionALPN of Nothing -> processRequest req0 @@ -121,34 +128,43 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here) _ -> liftIO . sendResponse $ H.responseNoBody N.ok200 [] -- shouldn't happen: means server picked handshake protocol it doesn't know about xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M (Maybe (THandleParams XFTPVersion 'TServer)) - xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse} = do + xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams0@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse} = do s <- atomically $ TM.lookup sessionId sessions r <- runExceptT $ case s of Nothing -> processHello Just (HandshakeSent pk) -> processClientHandshake pk - Just (HandshakeAccepted auth v) -> pure $ Just thParams {thAuth = Just auth, thVersion = v} + Just (HandshakeAccepted thParams) -> pure $ Just thParams either sendError pure r where processHello = do - unless (B.null bodyHead) $ throwError HANDSHAKE + unless (B.null bodyHead) $ throwE HANDSHAKE (k, pk) <- atomically . C.generateKeyPair =<< asks random atomically $ TM.insert sessionId (HandshakeSent pk) sessions let authPubKey = (chain, C.signX509 serverSignKey $ C.publicToX509 k) - let hs = XFTPServerHandshake {xftpVersionRange = supportedFileServerVRange, sessionId, authPubKey} + let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey} shs <- encodeXftp hs +#ifdef slow_servers + lift randomDelay +#endif liftIO . sendResponse $ H.responseBuilder N.ok200 [] shs pure Nothing processClientHandshake pk = do - unless (B.length bodyHead == xftpBlockSize) $ throwError HANDSHAKE + unless (B.length bodyHead == xftpBlockSize) $ throwE HANDSHAKE body <- liftHS $ C.unPad bodyHead - XFTPClientHandshake {xftpVersion, keyHash} <- liftHS $ smpDecode body + XFTPClientHandshake {xftpVersion = v, keyHash} <- liftHS $ smpDecode body kh <- asks serverIdentity - unless (keyHash == kh) $ throwError HANDSHAKE - unless (xftpVersion `isCompatible` supportedFileServerVRange) $ throwError HANDSHAKE - let auth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing} - atomically $ TM.insert sessionId (HandshakeAccepted auth xftpVersion) sessions - liftIO . sendResponse $ H.responseNoBody N.ok200 [] - pure Nothing + unless (keyHash == kh) $ throwE HANDSHAKE + case compatibleVRange' xftpServerVRange v of + Just (Compatible vr) -> do + let auth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing} + thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr} + atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions +#ifdef slow_servers + lift randomDelay +#endif + liftIO . sendResponse $ H.responseNoBody N.ok200 [] + pure Nothing + Nothing -> throwE HANDSHAKE sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion 'TServer)) sendError err = do runExceptT (encodeXftp err) >>= \case @@ -310,6 +326,9 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea where sendXFTPResponse (corrId, fId, resp) serverFile_ = do let t_ = xftpEncodeTransmission thParams (corrId, fId, resp) +#ifdef slow_servers + randomDelay +#endif liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_ where streamBody t_ send done = do @@ -321,9 +340,18 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea send $ byteString t -- timeout sending file in the same way as receiving forM_ serverFile_ $ \ServerFile {filePath, fileSize, sbState} -> do - withFile filePath ReadMode $ \h -> sendEncFile h send sbState (fromIntegral fileSize) + withFile filePath ReadMode $ \h -> sendEncFile h send sbState fileSize done +#ifdef slow_servers +randomDelay :: M () +randomDelay = do + d <- asks $ responseDelay . config + when (d > 0) $ do + pc <- getStdRandom (randomR (-200, 200)) + threadDelay $ (d * (1000 + pc)) `div` 1000 +#endif + data VerificationResult = VRVerified XFTPRequest | VRFailed verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult @@ -368,7 +396,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case st <- asks store r <- runExceptT $ do sizes <- asks $ allowedChunkSizes . config - unless (size file `elem` sizes) $ throwError SIZE + unless (size file `elem` sizes) $ throwE SIZE ts <- liftIO getSystemTime -- TODO validate body empty sId <- ExceptT $ addFileRetry st file 3 ts @@ -452,7 +480,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case pure $ FRErr e receiveChunk spec = do t <- asks $ fileTimeout . config - liftIO $ fromMaybe (Left TIMEOUT) <$> timeout t (runExceptT (receiveFile getBody spec) `catchAll_` pure (Left FILE_IO)) + liftIO $ fromMaybe (Left TIMEOUT) <$> timeout t (runExceptT $ receiveFile getBody spec) sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile) sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do readTVarIO filePath >>= \case diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index b7f60c9af..f8a6bc996 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -13,12 +13,9 @@ import Control.Logger.Simple import Control.Monad import Control.Monad.IO.Unlift import Crypto.Random -import Data.Default (def) import Data.Int (Int64) -import Data.List (find) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) import Data.Time.Clock (getCurrentTime) import Data.Word (Word32) import Data.X509.Validation (Fingerprint (..)) @@ -28,6 +25,7 @@ import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId) import Simplex.FileTransfer.Server.Stats import Simplex.FileTransfer.Server.Store import Simplex.FileTransfer.Server.StoreLog +import Simplex.FileTransfer.Transport (VersionRangeXFTP) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey) import Simplex.Messaging.Server.Expiration @@ -64,12 +62,15 @@ data XFTPServerConfig = XFTPServerConfig caCertificateFile :: FilePath, privateKeyFile :: FilePath, certificateFile :: FilePath, + -- | XFTP client-server protocol version range + xftpServerVRange :: VersionRangeXFTP, -- stats config - see SMP server config logStatsInterval :: Maybe Int64, logStatsStartTime :: Int64, serverStatsLogFile :: FilePath, serverStatsBackupFile :: Maybe FilePath, - transportConfig :: TransportServerConfig + transportConfig :: TransportServerConfig, + responseDelay :: Int } defaultInactiveClientExpiration :: ExpirationConfig @@ -103,7 +104,7 @@ supportedXFTPhandshakes :: [ALPN] supportedXFTPhandshakes = ["xftp/1"] newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv -newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do +newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do random <- liftIO C.newRandom store <- atomically newFileStore storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile @@ -112,17 +113,7 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi forM_ fileSizeQuota $ \quota -> do logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used) when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!" - tlsServerParams' <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile - let TransportServerConfig {alpn} = transportConfig config - let tlsServerParams = case alpn of - Nothing -> tlsServerParams' - Just supported -> - tlsServerParams' - { T.serverHooks = - def - { T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supported) - } - } + tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig) Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index d53b3f4fa..76b1f157a 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -7,19 +7,20 @@ module Simplex.FileTransfer.Server.Main where -import qualified Data.ByteString.Char8 as B import Data.Either (fromRight) import Data.Functor (($>)) import Data.Ini (lookupValue, readIniFile) import Data.Int (Int64) import Data.Maybe (fromMaybe) import qualified Data.Text as T +import qualified Data.Text.IO as T import Network.Socket (HostName) import Options.Applicative import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Description (FileSize (..)) import Simplex.FileTransfer.Server (runXFTPServer) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, supportedXFTPhandshakes) +import Simplex.FileTransfer.Transport (supportedFileServerVRange) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer) @@ -28,6 +29,7 @@ import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (combine) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) @@ -68,7 +70,7 @@ xftpServerCLI cfgPath logPath = do fp <- createServerX509 cfgPath x509cfg let host = fromMaybe (if ip == "127.0.0.1" then "" else ip) fqdn srv = ProtoServerWithAuth (XFTPServer [THDomainName host] "" (C.KeyHash fp)) Nothing - writeFile iniFile $ iniFileContent host + T.writeFile iniFile $ iniFileContent host putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server." warnCAPrivateKeyFile cfgPath x509cfg printServiceInfo serverVersion srv @@ -82,7 +84,7 @@ xftpServerCLI cfgPath logPath = do \# Log is compacted on start (deleted objects are removed).\n" <> ("enable: " <> onOff enableStoreLog <> "\n\n") <> "# Expire files after the specified number of hours.\n" - <> ("expire_files_hours: " <> show defFileExpirationHours <> "\n\n") + <> ("expire_files_hours: " <> tshow defFileExpirationHours <> "\n\n") <> "log_stats: off\n\ \\n\ \[AUTH]\n\ @@ -101,20 +103,20 @@ xftpServerCLI cfgPath logPath = do \# control_port_user_password:\n\ \[TRANSPORT]\n\ \# host is only used to print server address on start\n" - <> ("host: " <> host <> "\n") - <> ("port: " <> defaultServerPort <> "\n") + <> ("host: " <> T.pack host <> "\n") + <> ("port: " <> T.pack defaultServerPort <> "\n") <> "log_tls_errors: off\n\ \# control_port: 5226\n\ \\n\ \[FILES]\n" - <> ("path: " <> filesPath <> "\n") - <> ("storage_quota: " <> B.unpack (strEncode fileSizeQuota) <> "\n") + <> ("path: " <> T.pack filesPath <> "\n") + <> ("storage_quota: " <> safeDecodeUtf8 (strEncode fileSizeQuota) <> "\n") <> "\n\ \[INACTIVE_CLIENTS]\n\ \# TTL and interval to check inactive clients\n\ \disconnect: off\n" - <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n") - <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n") + <> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n") + <> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n") runServer ini = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering @@ -164,7 +166,7 @@ xftpServerCLI cfgPath logPath = do defaultFileExpiration { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini }, - fileTimeout = 10 * 60 * 1000000, -- 10 mins to send 4mb chunk + fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk inactiveClientExpiration = settingIsOn "INACTIVE_CLIENTS" "disconnect" ini $> ExpirationConfig @@ -174,6 +176,7 @@ xftpServerCLI cfgPath logPath = do caCertificateFile = c caCrtFile, privateKeyFile = c serverKeyFile, certificateFile = c serverCrtFile, + xftpServerVRange = supportedFileServerVRange, logStatsInterval = logStats $> 86400, -- seconds logStatsStartTime = 0, -- seconds from 00:00 UTC serverStatsLogFile = combine logPath "file-server-stats.daily.log", @@ -182,7 +185,8 @@ xftpServerCLI cfgPath logPath = do defaultTransportServerConfig { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini, alpn = Just supportedXFTPhandshakes - } + }, + responseDelay = 0 } data CliCommand diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index 27f1b8b95..d72f9862b 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -34,9 +34,11 @@ where import Control.Applicative ((<|>)) import qualified Control.Exception as E +import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Control.Monad.Trans.Except import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (bimap, first) @@ -45,17 +47,19 @@ import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Functor (($>)) import Data.Word (Word16, Word32) import qualified Data.X509 as X +import Network.HTTP2.Client (HTTP2Error) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol (CommandError) -import Simplex.Messaging.Transport (HandshakeError (..), SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..)) +import Simplex.Messaging.Transport (SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..)) import Simplex.Messaging.Transport.HTTP2.File -import Simplex.Messaging.Util (bshow) +import Simplex.Messaging.Util (bshow, tshow) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal import System.IO (Handle, IOMode (..), withFile) @@ -95,7 +99,7 @@ supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion -- XFTP protocol does not use this handshake method xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient) -xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwError $ TEHandshake VERSION +xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwE TEVersion data XFTPServerHandshake = XFTPServerHandshake { xftpVersionRange :: VersionRangeXFTP, @@ -144,9 +148,14 @@ sendEncFile h send = go go sbState' $ sz - fromIntegral (B.length ch) receiveFile :: (Int -> IO ByteString) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () -receiveFile getBody = receiveFile_ receive +receiveFile getBody chunk = ExceptT $ runExceptT (receiveFile_ receive chunk) `E.catches` handlers where receive h sz = hReceiveFile getBody h sz >>= \sz' -> pure $ if sz' == 0 then Right () else Left SIZE + handlers = + [ E.Handler $ \(e :: HTTP2Error) -> logWarn (err e) $> Left TIMEOUT, + E.Handler $ \(e :: E.SomeException) -> logError (err e) $> Left FILE_IO + ] + err e = "receiveFile error: " <> tshow e receiveEncFile :: (Int -> IO ByteString) -> LC.SbState -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () receiveEncFile getBody = receiveFile_ . receive @@ -185,7 +194,7 @@ receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChu receiveFile_ receive XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do ExceptT $ withFile filePath WriteMode (`receive` chunkSize) digest' <- liftIO $ LC.sha256Hash <$> LB.readFile filePath - when (digest' /= chunkDigest) $ throwError DIGEST + when (digest' /= chunkDigest) $ throwE DIGEST data XFTPErrorType = -- | incorrect block format, encoding or signature size @@ -212,10 +221,8 @@ data XFTPErrorType HAS_FILE | -- | file IO error FILE_IO - | -- | file sending timeout + | -- | file sending or receiving timeout TIMEOUT - | -- | bad redirect data - REDIRECT {redirectError :: String} | -- | internal server error INTERNAL | -- | used internally, never returned by the server (to be removed) @@ -225,11 +232,9 @@ data XFTPErrorType instance StrEncoding XFTPErrorType where strEncode = \case CMD e -> "CMD " <> bshow e - REDIRECT e -> "REDIRECT " <> bshow e e -> bshow e strP = "CMD " *> (CMD <$> parseRead1) - <|> "REDIRECT " *> (REDIRECT <$> parseRead A.takeByteString) <|> parseRead1 instance Encoding XFTPErrorType where @@ -247,7 +252,6 @@ instance Encoding XFTPErrorType where HAS_FILE -> "HAS_FILE" FILE_IO -> "FILE_IO" TIMEOUT -> "TIMEOUT" - REDIRECT err -> "REDIRECT " <> smpEncode err INTERNAL -> "INTERNAL" DUPLICATE_ -> "DUPLICATE_" @@ -266,7 +270,6 @@ instance Encoding XFTPErrorType where "HAS_FILE" -> pure HAS_FILE "FILE_IO" -> pure FILE_IO "TIMEOUT" -> pure TIMEOUT - "REDIRECT" -> REDIRECT <$> _smpP "INTERNAL" -> pure INTERNAL "DUPLICATE_" -> pure DUPLICATE_ _ -> fail "bad error type" diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index ba306a6c6..15dc672da 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -2,24 +2,33 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Simplex.FileTransfer.Types where +import qualified Data.Aeson.TH as J +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Data.Word (Word32) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description -import Simplex.Messaging.Agent.Protocol (RcvFileId, SndFileId) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (fromTextField_) -import Simplex.Messaging.Protocol +import Simplex.Messaging.Parsers +import Simplex.Messaging.Protocol (XFTPServer) import System.FilePath (()) +type RcvFileId = ByteString + +type SndFileId = ByteString + authTagSize :: Int64 authTagSize = fromIntegral C.authTagSize @@ -236,3 +245,35 @@ data DeletedSndChunkReplica = DeletedSndChunkReplica retries :: Int } deriving (Show) + +data FileErrorType + = -- | cannot proceed with download from not approved relays without proxy + NOT_APPROVED + | -- | max file size exceeded + SIZE + | -- | bad redirect data + REDIRECT {redirectError :: String} + | -- | file crypto error + FILE_IO {fileIOError :: String} + | -- | file not found or was deleted + NO_FILE + deriving (Eq, Show) + +instance StrEncoding FileErrorType where + strP = + A.takeTill (== ' ') + >>= \case + "NOT_APPROVED" -> pure NOT_APPROVED + "SIZE" -> pure SIZE + "REDIRECT" -> REDIRECT <$> (A.space *> textP) + "FILE_IO" -> FILE_IO <$> (A.space *> textP) + "NO_FILE" -> pure NO_FILE + _ -> fail "bad FileErrorType" + strEncode = \case + NOT_APPROVED -> "NOT_APPROVED" + SIZE -> "SIZE" + REDIRECT e -> "REDIRECT " <> encodeUtf8 (T.pack e) + FILE_IO e -> "FILE_IO " <> encodeUtf8 (T.pack e) + NO_FILE -> "NO_FILE" + +$(J.deriveJSON (sumTypeJSON id) ''FileErrorType) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 38112b030..c08e04298 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -29,10 +29,7 @@ -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md module Simplex.Messaging.Agent - ( -- * queue-based SMP agent - runAgentClient, - - -- * SMP agent functional API + ( -- * SMP agent functional API AgentClient (..), AE, SubscriptionsInfo (..), @@ -55,6 +52,7 @@ module Simplex.Messaging.Agent deleteConnectionAsync, deleteConnectionsAsync, createConnection, + prepareConnectionToJoin, joinConnection, allowConnection, acceptContact, @@ -69,6 +67,7 @@ module Simplex.Messaging.Agent sendMessages, sendMessagesB, ackMessage, + getConnectionQueueInfo, switchConnection, abortConnectionSwitch, synchronizeRatchet, @@ -78,12 +77,13 @@ module Simplex.Messaging.Agent getConnectionServers, getConnectionRatchetAdHash, setProtocolServers, + checkUserServers, testProtocolServer, setNtfServers, setNetworkConfig, - getNetworkConfig, setUserNetworkInfo, reconnectAllServers, + reconnectSMPServer, registerNtfToken, verifyNtfToken, checkNtfToken, @@ -105,25 +105,26 @@ module Simplex.Messaging.Agent rcConnectHost, rcConnectCtrl, rcDiscoverCtrl, + getAgentServersSummary, + resetAgentServersStats, foregroundAgent, suspendAgent, execAgentStoreSQL, getAgentMigrations, debugAgentLocks, - getAgentStats, - resetAgentStats, getAgentSubscriptions, logConnection, ) where -import Control.Logger.Simple (logError, logInfo, showText) +import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J -import Data.Bifunctor (bimap, first, second) +import Data.Bifunctor (bimap, first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Composition ((.:), (.:.), (.::), (.::.)) @@ -137,6 +138,8 @@ import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock @@ -146,21 +149,23 @@ import Data.Word (Word16) import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile') import Simplex.FileTransfer.Description (ValidFileDescription) import Simplex.FileTransfer.Protocol (FileParty (..)) +import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.FileTransfer.Util (removePath) import Simplex.Messaging.Agent.Client import Simplex.Messaging.Agent.Env.SQLite -import Simplex.Messaging.Agent.Lock (withLock', withLock) +import Simplex.Messaging.Agent.Lock (withLock, withLock') import Simplex.Messaging.Agent.NtfSubSupervisor import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval +import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations -import Simplex.Messaging.Client (ProtocolClient (..), ServerTransmission) +import Simplex.Messaging.Client (ProtocolClient (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs) -import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOn, pattern PQEncOff, pattern PQSupportOn, pattern PQSupportOff) +import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -168,7 +173,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, XFTPServerWithAuth) +import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import qualified Simplex.Messaging.TMap as TM @@ -179,7 +184,6 @@ import Simplex.RemoteControl.Client import Simplex.RemoteControl.Invitation import Simplex.RemoteControl.Types import System.Mem.Weak (deRefWeak) -import UnliftIO.Async (race_) import UnliftIO.Concurrent (forkFinally, forkIO, killThread, mkWeakThreadId, threadDelay) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -194,26 +198,63 @@ getSMPAgentClient = getSMPAgentClient_ 1 {-# INLINE getSMPAgentClient #-} getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> SQLiteStore -> Bool -> IO AgentClient -getSMPAgentClient_ clientId cfg initServers store backgroundMode = - liftIO $ newSMPAgentEnv cfg store >>= runReaderT runAgent +getSMPAgentClient_ clientId cfg initServers@InitialAgentServers {smp, xftp} store backgroundMode = + newSMPAgentEnv cfg store >>= runReaderT runAgent where runAgent = do - c@AgentClient {acThread} <- atomically . newAgentClient clientId initServers =<< ask + liftIO $ checkServers "SMP" smp >> checkServers "XFTP" xftp + currentTs <- liftIO getCurrentTime + c@AgentClient {acThread} <- atomically . newAgentClient clientId initServers currentTs =<< ask t <- runAgentThreads c `forkFinally` const (liftIO $ disconnectAgentClient c) atomically . writeTVar acThread . Just =<< mkWeakThreadId t pure c + checkServers protocol srvs = + forM_ (M.assocs srvs) $ \(userId, srvs') -> checkUserServers ("getSMPAgentClient " <> protocol <> " " <> tshow userId) srvs' runAgentThreads c | backgroundMode = run c "subscriber" $ subscriber c - | otherwise = + | otherwise = do + restoreServersStats c raceAny_ [ run c "subscriber" $ subscriber c, run c "runNtfSupervisor" $ runNtfSupervisor c, - run c "cleanupManager" $ cleanupManager c + run c "cleanupManager" $ cleanupManager c, + run c "logServersStats" $ logServersStats c ] + `E.finally` saveServersStats c run AgentClient {subQ, acThread} name a = a `E.catchAny` \e -> whenM (isJust <$> readTVarIO acThread) $ do logError $ "Agent thread " <> name <> " crashed: " <> tshow e - atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR $ CRITICAL True $ show e) + atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ CRITICAL True $ show e) + +logServersStats :: AgentClient -> AM' () +logServersStats c = do + delay <- asks (initialLogStatsDelay . config) + liftIO $ threadDelay' delay + int <- asks (logStatsInterval . config) + forever $ do + saveServersStats c + liftIO $ threadDelay' int + +saveServersStats :: AgentClient -> AM' () +saveServersStats c@AgentClient {subQ, smpServersStats, xftpServersStats} = do + sss <- mapM (lift . getAgentSMPServerStats) =<< readTVarIO smpServersStats + xss <- mapM (lift . getAgentXFTPServerStats) =<< readTVarIO xftpServersStats + let stats = AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss} + tryAgentError' (withStore' c (`updateServersStats` stats)) >>= \case + Left e -> atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e) + Right () -> pure () + +restoreServersStats :: AgentClient -> AM' () +restoreServersStats c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt} = do + tryAgentError' (withStore c getServersStats) >>= \case + Left e -> atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e) + Right (startedAt, Nothing) -> atomically $ writeTVar srvStatsStartedAt startedAt + Right (startedAt, Just AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss}) -> do + atomically $ writeTVar srvStatsStartedAt startedAt + sss' <- mapM (atomically . newAgentSMPServerStats') sss + atomically $ writeTVar smpServersStats sss' + xss' <- mapM (atomically . newAgentXFTPServerStats') xss + atomically $ writeTVar xftpServersStats xss' disconnectAgentClient :: AgentClient -> IO () disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns, xftpAgent = xa}} = do @@ -234,12 +275,12 @@ resumeAgentClient :: AgentClient -> IO () resumeAgentClient c = atomically $ writeTVar (active c) True {-# INLINE resumeAgentClient #-} -createUser :: AgentClient -> NonEmpty SMPServerWithAuth -> NonEmpty XFTPServerWithAuth -> AE UserId +createUser :: AgentClient -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> AE UserId createUser c = withAgentEnv c .: createUser' c {-# INLINE createUser #-} -- | Delete user record optionally deleting all user's connections on SMP servers -deleteUser :: AgentClient -> UserId -> Bool -> AE () +deleteUser :: AgentClient -> UserId -> Bool -> AE () deleteUser c = withAgentEnv c .: deleteUser' c {-# INLINE deleteUser #-} @@ -288,9 +329,18 @@ createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId "" enableNtfs {-# INLINE createConnection #-} --- | Join SMP agent connection (JOIN command) -joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId -joinConnection c userId enableNtfs = withAgentEnv c .:: joinConn c userId "" enableNtfs +-- | Create SMP agent connection without queue (to be joined with joinConnection passing connection ID). +-- This method is required to prevent race condition when confirmation from peer is received before +-- the caller of joinConnection saves connection ID to the database. +-- Instead of it we could send confirmation asynchronously, but then it would be harder to report +-- "link deleted" (SMP AUTH) interactively, so this approach is simpler overall. +prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId +prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs + +-- | Join SMP agent connection (JOIN command). +joinConnection :: AgentClient -> UserId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId +joinConnection c userId Nothing enableNtfs = withAgentEnv c .:: joinConn c userId "" False enableNtfs +joinConnection c userId (Just connId) enableNtfs = withAgentEnv c .:: joinConn c userId connId True enableNtfs {-# INLINE joinConnection #-} -- | Allow connection to continue after CONF notification (LET command) @@ -344,18 +394,22 @@ sendMessage c = withAgentEnv c .:: sendMessage' c type MsgReq = (ConnId, PQEncryption, MsgFlags, MsgBody) -- | Send multiple messages to different connections (SEND command) -sendMessages :: AgentClient -> [MsgReq] -> IO [Either AgentErrorType (AgentMsgId, PQEncryption)] -sendMessages c = withAgentEnv' c . sendMessages' c +sendMessages :: AgentClient -> [MsgReq] -> AE [Either AgentErrorType (AgentMsgId, PQEncryption)] +sendMessages c = withAgentEnv c . sendMessages' c {-# INLINE sendMessages #-} -sendMessagesB :: Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> IO (t (Either AgentErrorType (AgentMsgId, PQEncryption))) -sendMessagesB c = withAgentEnv' c . sendMessagesB' c +sendMessagesB :: Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> AE (t (Either AgentErrorType (AgentMsgId, PQEncryption))) +sendMessagesB c = withAgentEnv c . sendMessagesB' c {-# INLINE sendMessagesB #-} ackMessage :: AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AE () ackMessage c = withAgentEnv c .:. ackMessage' c {-# INLINE ackMessage #-} +getConnectionQueueInfo :: AgentClient -> ConnId -> AE ServerQueueInfo +getConnectionQueueInfo c = withAgentEnv c . getConnectionQueueInfo' c +{-# INLINE getConnectionQueueInfo #-} + -- | Switch connection to the new receive queue switchConnection :: AgentClient -> ConnId -> AE ConnectionStats switchConnection c = withAgentEnv c . switchConnection' c @@ -410,31 +464,27 @@ setNetworkConfig c@AgentClient {useNetworkConfig} cfg' = do (_, cfg) <- readTVar useNetworkConfig if cfg == cfg' then pure False - else True <$ (writeTVar useNetworkConfig $! (slowNetworkConfig cfg', cfg')) + else + let cfgSlow = slowNetworkConfig cfg' + in True <$ (cfgSlow `seq` writeTVar useNetworkConfig (cfgSlow, cfg')) when changed $ reconnectAllServers c --- returns fast network config -getNetworkConfig :: AgentClient -> IO NetworkConfig -getNetworkConfig = fmap snd . readTVarIO . useNetworkConfig -{-# INLINE getNetworkConfig #-} - setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO () -setUserNetworkInfo c@AgentClient {userNetworkState} UserNetworkInfo {networkType = nt', online} = withAgentEnv' c $ do - d <- asks $ initialInterval . userNetworkInterval . config - ts <- liftIO getCurrentTime - atomically $ do - ns@UserNetworkState {networkType = nt, offline} <- readTVar userNetworkState - when (nt' /= nt || online /= isNothing offline) $ - writeTVar userNetworkState $! - let offline' - | nt' /= UNNone && online = Nothing - | isJust offline = offline - | otherwise = Just UNSOffline {offlineDelay = d, offlineFrom = ts} - in ns {networkType = nt', offline = offline'} +setUserNetworkInfo c@AgentClient {userNetworkInfo, userNetworkUpdated} ni = withAgentEnv' c $ do + ts' <- liftIO getCurrentTime + i <- asks $ userOfflineDelay . config + -- if network offline event happens in less than `userOfflineDelay` after the previous event, it is ignored + atomically . whenM ((isOnline ni ||) <$> notRecentlyChanged ts' i) $ do + writeTVar userNetworkInfo ni + writeTVar userNetworkUpdated $ Just ts' + where + notRecentlyChanged ts' i = + maybe True (\ts -> diffUTCTime ts' ts > i) <$> readTVar userNetworkUpdated reconnectAllServers :: AgentClient -> IO () reconnectAllServers c = do reconnectServerClients c smpClients + reconnectServerClients c xftpClients reconnectServerClients c ntfClients -- | Register device notifications token @@ -473,8 +523,8 @@ xftpStartWorkers c = withAgentEnv c . startXFTPWorkers c {-# INLINE xftpStartWorkers #-} -- | Receive XFTP file -xftpReceiveFile :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> AE RcvFileId -xftpReceiveFile c = withAgentEnv c .:. xftpReceiveFile' c +xftpReceiveFile :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AE RcvFileId +xftpReceiveFile c = withAgentEnv c .:: xftpReceiveFile' c {-# INLINE xftpReceiveFile #-} -- | Delete XFTP rcv file (deletes work files from file system and db records) @@ -537,12 +587,9 @@ rcDiscoverCtrl :: AgentClient -> NonEmpty RCCtrlPairing -> AE (RCCtrlPairing, RC rcDiscoverCtrl AgentClient {agentEnv = Env {multicastSubscribers = subs}} = withExceptT RCP . discoverRCCtrl subs {-# INLINE rcDiscoverCtrl #-} -getAgentStats :: AgentClient -> IO [(AgentStatsKey, Int)] -getAgentStats c = readTVarIO (agentStats c) >>= mapM (\(k, cnt) -> (k,) <$> readTVarIO cnt) . M.assocs - -resetAgentStats :: AgentClient -> IO () -resetAgentStats = atomically . TM.clear . agentStats -{-# INLINE resetAgentStats #-} +resetAgentServersStats :: AgentClient -> AE () +resetAgentServersStats c = withAgentEnv c $ resetAgentServersStats' c +{-# INLINE resetAgentServersStats #-} withAgentEnv' :: AgentClient -> AM' a -> IO a withAgentEnv' c = (`runReaderT` agentEnv c) @@ -555,64 +602,36 @@ withAgentEnv c a = ExceptT $ runExceptT a `runReaderT` agentEnv c logConnection :: AgentClient -> Bool -> IO () logConnection c connected = let event = if connected then "connected to" else "disconnected from" - in logInfo $ T.unwords ["client", showText (clientId c), event, "Agent"] + in logInfo $ T.unwords ["client", tshow (clientId c), event, "Agent"] --- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's. -runAgentClient :: AgentClient -> AM' () -runAgentClient c = race_ (subscriber c) (client c) -{-# INLINE runAgentClient #-} - -client :: AgentClient -> AM' () -client c@AgentClient {rcvQ, subQ} = forever $ do - (corrId, entId, cmd) <- atomically $ readTBQueue rcvQ - runExceptT (processCommand c (entId, cmd)) - >>= atomically . writeTBQueue subQ . \case - Left e -> (corrId, entId, APC SAEConn $ ERR e) - Right (entId', resp) -> (corrId, entId', resp) - --- | execute any SMP agent command -processCommand :: AgentClient -> (EntityId, APartyCmd 'Client) -> AM (EntityId, APartyCmd 'Agent) -processCommand c (connId, APC e cmd) = - second (APC e) <$> case cmd of - NEW enableNtfs (ACM cMode) pqIK subMode -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing pqIK subMode - JOIN enableNtfs (ACR _ cReq) pqEnc subMode connInfo -> (,OK) <$> joinConn c userId connId enableNtfs cReq connInfo pqEnc subMode - LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK) - ACPT invId pqEnc ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo pqEnc SMSubscribe - RJCT invId -> rejectContact' c connId invId $> (connId, OK) - SUB -> subscribeConnection' c connId $> (connId, OK) - SEND pqEnc msgFlags msgBody -> (connId,) . uncurry MID <$> sendMessage' c connId pqEnc msgFlags msgBody - ACK msgId rcptInfo_ -> ackMessage' c connId msgId rcptInfo_ $> (connId, OK) - SWCH -> switchConnection' c connId $> (connId, OK) - OFF -> suspendConnection' c connId $> (connId, OK) - DEL -> deleteConnection' c connId $> (connId, OK) - CHK -> (connId,) . STAT <$> getConnectionServers' c connId - where - -- command interface does not support different users - userId :: UserId - userId = 1 - -createUser' :: AgentClient -> NonEmpty SMPServerWithAuth -> NonEmpty XFTPServerWithAuth -> AM UserId +createUser' :: AgentClient -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> AM UserId createUser' c smp xftp = do + liftIO $ checkUserServers "createUser SMP" smp + liftIO $ checkUserServers "createUser XFTP" xftp userId <- withStore' c createUserRecord - atomically $ TM.insert userId smp $ smpServers c - atomically $ TM.insert userId xftp $ xftpServers c + atomically $ TM.insert userId (mkUserServers smp) $ smpServers c + atomically $ TM.insert userId (mkUserServers xftp) $ xftpServers c pure userId deleteUser' :: AgentClient -> UserId -> Bool -> AM () -deleteUser' c userId delSMPQueues = do +deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueues = do if delSMPQueues then withStore c (`setUserDeleted` userId) >>= deleteConnectionsAsync_ delUser c False else withStore c (`deleteUserRecord` userId) atomically $ TM.delete userId $ smpServers c + atomically $ TM.delete userId $ xftpServers c + atomically $ modifyTVar' smpServersStats $ M.filterWithKey (\(userId', _) _ -> userId' /= userId) + atomically $ modifyTVar' xftpServersStats $ M.filterWithKey (\(userId', _) _ -> userId' /= userId) + lift $ saveServersStats c where delUser = whenM (withStore' c (`deleteUserWithoutConns` userId)) . atomically $ - writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId) + writeTBQueue (subQ c) ("", "", AEvt SAENone $ DEL_USER userId) newConnAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ConnId newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do connId <- newConnNoQueues c userId "" enableNtfs cMode (CR.connPQEncryption pqInitKeys) - enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ NEW enableNtfs (ACM cMode) pqInitKeys subMode + enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode) pqInitKeys subMode pure connId newConnNoQueues :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId @@ -631,18 +650,18 @@ joinConnAsync c userId corrId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation - enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) pqSupport subMode cInfo + enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN enableNtfs (ACR sConnectionMode cReqUri) pqSupport subMode cInfo pure connId - Nothing -> throwError $ AGENT A_VERSION + Nothing -> throwE $ AGENT A_VERSION joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _subMode _cInfo _pqEncryption = - throwError $ CMD PROHIBITED + throwE $ CMD PROHIBITED "joinConnAsync" allowConnectionAsync' :: AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> AM () allowConnectionAsync' c corrId connId confId ownConnInfo = withStore c (`getConn` connId) >>= \case SomeConn _ (RcvConnection _ RcvQueue {server}) -> - enqueueCommand c corrId connId (Just server) $ AClientCommand $ APC SAEConn $ LET confId ownConnInfo - _ -> throwError $ CMD PROHIBITED + enqueueCommand c corrId connId (Just server) $ AClientCommand $ LET confId ownConnInfo + _ -> throwE $ CMD PROHIBITED "allowConnectionAsync" acceptContactAsync' :: AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId acceptContactAsync' c corrId enableNtfs invId ownConnInfo pqSupport subMode = do @@ -652,8 +671,8 @@ acceptContactAsync' c corrId enableNtfs invId ownConnInfo pqSupport subMode = do withStore' c $ \db -> acceptInvitation db invId ownConnInfo joinConnAsync c userId corrId enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do withStore' c (`unacceptInvitation` invId) - throwError err - _ -> throwError $ CMD PROHIBITED + throwE err + _ -> throwE $ CMD PROHIBITED "acceptContactAsync" ackMessageAsync' :: AgentClient -> ACorrId -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AM () ackMessageAsync' c corrId connId msgId rcptInfo_ = do @@ -661,17 +680,17 @@ ackMessageAsync' c corrId connId msgId rcptInfo_ = do case cType of SCDuplex -> enqueueAck SCRcv -> enqueueAck - SCSnd -> throwError $ CONN SIMPLEX - SCContact -> throwError $ CMD PROHIBITED - SCNew -> throwError $ CMD PROHIBITED + SCSnd -> throwE $ CONN SIMPLEX + SCContact -> throwE $ CMD PROHIBITED "ackMessageAsync: SCContact" + SCNew -> throwE $ CMD PROHIBITED "ackMessageAsync: SCNew" where enqueueAck :: AM () enqueueAck = do let mId = InternalId msgId RcvMsg {msgType} <- withStore c $ \db -> getRcvMsg db connId mId - when (isJust rcptInfo_ && msgType /= AM_A_MSG_) $ throwError $ CMD PROHIBITED + when (isJust rcptInfo_ && msgType /= AM_A_MSG_) $ throwE $ CMD PROHIBITED "ackMessageAsync: receipt not allowed" (RcvQueue {server}, _) <- withStore c $ \db -> setMsgUserAck db connId mId - enqueueCommand c corrId connId (Just server) . AClientCommand $ APC SAEConn $ ACK msgId rcptInfo_ + enqueueCommand c corrId connId (Just server) . AClientCommand $ ACK msgId rcptInfo_ deleteConnectionAsync' :: AgentClient -> Bool -> ConnId -> AM () deleteConnectionAsync' c waitDelivery connId = deleteConnectionsAsync' c waitDelivery [connId] @@ -697,35 +716,38 @@ switchConnectionAsync' c corrId connId = withConnLock c connId "switchConnectionAsync" $ withStore c (`getConn` connId) >>= \case SomeConn _ (DuplexConnection cData rqs@(rq :| _rqs) sqs) - | isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED + | isJust (switchingRQ rqs) -> throwE $ CMD PROHIBITED "switchConnectionAsync: already switching" | otherwise -> do - when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED + when (ratchetSyncSendProhibited cData) $ throwE $ CMD PROHIBITED "switchConnectionAsync: send prohibited" rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted - enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH + enqueueCommand c corrId connId Nothing $ AClientCommand SWCH let rqs' = updatedQs rq1 rqs pure . connectionStats $ DuplexConnection cData rqs' sqs - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex" newConn :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c) newConn c userId connId enableNtfs cMode clientData pqInitKeys subMode = - getSMPServer c userId >>= newConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode + getSMPServer c userId >>= newConnSrv c userId connId False enableNtfs cMode clientData pqInitKeys subMode -newConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c) -newConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv = do - connId' <- newConnNoQueues c userId connId enableNtfs cMode (CR.connPQEncryption pqInitKeys) +newConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c) +newConnSrv c userId connId hasNewConn enableNtfs cMode clientData pqInitKeys subMode srv = do + connId' <- + if hasNewConn + then pure connId + else newConnNoQueues c userId connId enableNtfs cMode (CR.connPQEncryption pqInitKeys) newRcvConnSrv c userId connId' enableNtfs cMode clientData pqInitKeys subMode srv newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c) -newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv = do +newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do case (cMode, pqInitKeys) of - (SCMContact, CR.IKUsePQ) -> throwError $ CMD PROHIBITED + (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv" _ -> pure () AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config - (rq, qUri) <- newRcvQueue c userId connId srv smpClientVRange subMode `catchAgentError` \e -> liftIO (print e) >> throwError e + let sndSecure = case cMode of SCMInvitation -> True; SCMContact -> False + (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srvWithAuth smpClientVRange subMode sndSecure `catchAgentError` \e -> liftIO (print e) >> throwE e + atomically $ incSMPServerStat c userId srv connCreated rq' <- withStore c $ \db -> updateNewConnRcv db connId rq - liftIO $ case subMode of - SMOnlyCreate -> pure () - SMSubscribe -> addSubscription c rq' + lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId when enableNtfs $ do ns <- asks ntfSupervisor atomically $ sendNtfSubCommand ns (connId, NSCCreate) @@ -738,18 +760,36 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange) -joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId -joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do +newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId +newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of + CRInvitationUri {} -> + lift (compatibleInvitationUri cReq) >>= \case + Just (_, Compatible (CR.E2ERatchetParams v _ _ _), aVersion) -> create aVersion (Just v) + Nothing -> throwE $ AGENT A_VERSION + CRContactUri {} -> + lift (compatibleContactUri cReq) >>= \case + Just (_, aVersion) -> create aVersion Nothing + Nothing -> throwE $ AGENT A_VERSION + where + create :: Compatible VersionSMPA -> Maybe CR.VersionE2E -> AM ConnId + create (Compatible connAgentVersion) e2eV_ = do + g <- asks random + let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion e2eV_ + cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} + withStore c $ \db -> createNewConn db g cData SCMInvitation + +joinConn :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId +joinConn c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode = do srv <- case cReq of CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> getNextServer c userId [qServer q] _ -> getSMPServer c userId - joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv + joinConnSrv c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode srv -startJoinInvitation :: UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (Compatible VersionSMPA, ConnData, NewSndQueue, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448) -startJoinInvitation userId connId enableNtfs cReqUri pqSup = +startJoinInvitation :: UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, NewSndQueue, C.PublicKeyX25519, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448) +startJoinInvitation userId connId sq_ enableNtfs cReqUri pqSup = lift (compatibleInvitationUri cReqUri) >>= \case - Just (qInfo, (Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_)), aVersion@(Compatible connAgentVersion)) -> do + Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_), Compatible connAgentVersion) -> do g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) (pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport) @@ -758,10 +798,14 @@ startJoinInvitation userId connId enableNtfs cReqUri pqSup = maxSupported <- asks $ maxVersion . e2eEncryptVRange . config let rcVs = CR.RatchetVersions {current = v, maxSupported} rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams - q <- lift $ newSndQueue userId "" qInfo + -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out + -- e2ePubKey is always present, it's Maybe historically + (q, e2ePubKey) <- case sq_ of + Just sq@SndQueue {e2ePubKey = Just k} -> pure ((sq :: SndQueue) {dbQueueId = DBNewQueue}, k) + _ -> lift $ newSndQueue userId "" qInfo let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} - pure (aVersion, cData, q, rc, e2eSndParams) - Nothing -> throwError $ AGENT A_VERSION + pure (cData, q, e2ePubKey, rc, e2eSndParams) + Nothing -> throwE $ AGENT A_VERSION connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport)) connRequestPQSupport c pqSup cReq = withAgentEnv' c $ case cReq of @@ -786,55 +830,69 @@ compatibleContactUri (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = AgentConfig {smpClientVRange, smpAgentVRange} <- asks config pure $ (,) - <$> (qUri `compatibleVersion` smpClientVRange) + <$> (qUri `compatibleVersion` smpClientVRange) <*> (crAgentVRange `compatibleVersion` smpAgentVRange) versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_ {-# INLINE versionPQSupport_ #-} -joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM ConnId -joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv = +joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM ConnId +joinConnSrv c userId connId hasNewConn enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv = withInvLock c (strEncode inv) "joinConnSrv" $ do - (aVersion, cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqSup + (cData, q, _, rc, e2eSndParams) <- startJoinInvitation userId connId Nothing enableNtfs inv pqSup g <- asks random (connId', sq) <- withStore c $ \db -> runExceptT $ do - r@(connId', _) <- ExceptT $ createSndConn db g cData q + r@(connId', _) <- + if hasNewConn + then (connId,) <$> ExceptT (updateNewConnSnd db connId q) + else ExceptT $ createSndConn db g cData q liftIO $ createRatchet db connId' rc pure r let cData' = (cData :: ConnData) {connId = connId'} - tryError (confirmQueue aVersion c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case + -- joinConnSrv is only used on user interaction, and its failure is permanent, + -- otherwise we would need to manage retries here to avoid SndQueue recreated with a different key, + -- similar to how joinConnAsync does that. + tryError (secureConfirmQueue c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case Right _ -> pure connId' Left e -> do -- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md void $ withStore' c $ \db -> deleteConn db Nothing connId' - throwError e -joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = + throwE e +joinConnSrv c userId connId hasNewConn enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = lift (compatibleContactUri cReqUri) >>= \case Just (qInfo, vrsn) -> do - (connId', cReq) <- newConnSrv c userId connId enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv - sendInvitation c userId qInfo vrsn cReq cInfo + (connId', cReq) <- newConnSrv c userId connId hasNewConn enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv + void $ sendInvitation c userId qInfo vrsn cReq cInfo pure connId' - Nothing -> throwError $ AGENT A_VERSION + Nothing -> throwE $ AGENT A_VERSION joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM () joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv = do - (_aVersion, cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqSupport - q' <- withStore c $ \db -> runExceptT $ do - liftIO $ createRatchet db connId rc - ExceptT $ updateNewConnSnd db connId q - confirmQueueAsync c cData q' srv cInfo (Just e2eSndParams) subMode + SomeConn cType conn <- withStore c (`getConn` connId) + case conn of + NewConnection _ -> doJoin Nothing + SndConnection _ sq -> doJoin $ Just sq + _ -> throwE $ CMD PROHIBITED $ "joinConnSrvAsync: bad connection " <> show cType + where + doJoin :: Maybe SndQueue -> AM () + doJoin sq_ = do + (cData, sq, _, rc, e2eSndParams) <- startJoinInvitation userId connId sq_ enableNtfs inv pqSupport + sq' <- withStore c $ \db -> runExceptT $ do + liftIO $ createRatchet db connId rc + maybe (ExceptT $ updateNewConnSnd db connId sq) pure sq_ + secureConfirmQueueAsync c cData sq' srv cInfo (Just e2eSndParams) subMode joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do - throwError $ CMD PROHIBITED + throwE $ CMD PROHIBITED "joinConnSrvAsync" createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM SMPQueueInfo createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do - (rq, qUri) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode + let sndSecure = smpClientVersion >= sndAuthKeySMPClientVersion + (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode sndSecure + atomically $ incSMPServerStat c userId (qServer rq) connCreated let qInfo = toVersionT qUri smpClientVersion rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq - liftIO $ case subMode of - SMOnlyCreate -> pure () - SMSubscribe -> addSubscription c rq' + lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId when enableNtfs $ do ns <- asks ntfSupervisor atomically $ sendNtfSubCommand ns (connId, NSCCreate) @@ -852,7 +910,7 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne liftIO $ setRcvQueueConfirmedE2E db rq dhSecret $ min v v' pure senderKey enqueueCommand c "" connId (Just server) . AInternalCommand $ ICAllowSecure rcvId senderKey - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "allowConnection" -- | Accept contact (ACPT command) in Reader monad acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId @@ -861,10 +919,10 @@ acceptContact' c connId enableNtfs invId ownConnInfo pqSupport subMode = withCon withStore c (`getConn` contactConnId) >>= \case SomeConn _ (ContactConnection ConnData {userId} _) -> do withStore' c $ \db -> acceptInvitation db invId ownConnInfo - joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do + joinConn c userId connId False enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do withStore' c (`unacceptInvitation` invId) - throwError err - _ -> throwError $ CMD PROHIBITED + throwE err + _ -> throwE $ CMD PROHIBITED "acceptContact" -- | Reject contact (RJCT command) in Reader monad rejectContact' :: AgentClient -> ConnId -> InvitationId -> AM () @@ -880,8 +938,8 @@ subscribeConnection' c connId = toConnResult connId =<< subscribeConnections' c toConnResult :: ConnId -> Map ConnId (Either AgentErrorType ()) -> AM () toConnResult connId rs = case M.lookup connId rs of Just (Right ()) -> when (M.size rs > 1) $ logError $ T.pack $ "too many results " <> show (M.size rs) - Just (Left e) -> throwError e - _ -> throwError $ INTERNAL $ "no result for connection " <> B.unpack connId + Just (Left e) -> throwE e + _ -> throwE $ INTERNAL $ "no result for connection " <> B.unpack connId type QCmdResult = (QueueStatus, Either AgentErrorType ()) @@ -894,7 +952,7 @@ subscribeConnections' c connIds = do (subRs, rcvQs) = M.mapEither rcvQueueOrResult cs mapM_ (mapM_ (\(cData, sqs) -> mapM_ (lift . resumeMsgDelivery c cData) sqs) . sndQueue) cs mapM_ (resumeConnCmds c) $ M.keys cs - rcvRs <- lift $ connResults <$> subscribeQueues c (concat $ M.elems rcvQs) + rcvRs <- lift $ connResults . fst <$> subscribeQueues c (concat $ M.elems rcvQs) ns <- asks ntfSupervisor tkn <- readTVarIO (ntfTkn ns) when (instantNotifications tkn) . void . lift . forkIO . void . runExceptT $ sendNtfCreate ns rcvRs conns @@ -948,7 +1006,7 @@ subscribeConnections' c connIds = do let actual = M.size rs expected = length connIds when (actual /= expected) . atomically $ - writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected) + writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected) resubscribeConnection' :: AgentClient -> ConnId -> AM () resubscribeConnection' c connId = toConnResult connId =<< resubscribeConnections' c [connId] @@ -964,14 +1022,14 @@ resubscribeConnections' c connIds = do getConnectionMessage' :: AgentClient -> ConnId -> AM (Maybe SMPMsgMeta) getConnectionMessage' c connId = do - whenM (atomically $ hasActiveSubscription c connId) . throwError $ CMD PROHIBITED + whenM (atomically $ hasActiveSubscription c connId) . throwE $ CMD PROHIBITED "getConnectionMessage: subscribed" SomeConn _ conn <- withStore c (`getConn` connId) case conn of DuplexConnection _ (rq :| _) _ -> getQueueMessage c rq RcvConnection _ rq -> getQueueMessage c rq ContactConnection _ rq -> getQueueMessage c rq - SndConnection _ _ -> throwError $ CONN SIMPLEX - NewConnection _ -> throwError $ CMD PROHIBITED + SndConnection _ _ -> throwE $ CONN SIMPLEX + NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionMessage: NewConnection" getNotificationMessage' :: AgentClient -> C.CbNonce -> ByteString -> AM (NotificationInfo, [SMPMsgMeta]) getNotificationMessage' c nonce encNtfInfo = do @@ -983,7 +1041,7 @@ getNotificationMessage' c nonce encNtfInfo = do ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchAgentError` \_ -> pure Nothing maxMsgs <- asks $ ntfMaxMessages . config (NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta},) <$> getNtfMessages ntfConnId ntfMsgMeta maxMsgs - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "getNotificationMessage" where getNtfMessages ntfConnId nMeta = getMsg where @@ -1000,16 +1058,27 @@ getNotificationMessage' c nonce encNtfInfo = do -- | Send message to the connection (SEND command) in Reader monad sendMessage' :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AM (AgentMsgId, PQEncryption) -sendMessage' c connId pqEnc msgFlags msg = ExceptT $ runIdentity <$> sendMessagesB' c (Identity (Right (connId, pqEnc, msgFlags, msg))) +sendMessage' c connId pqEnc msgFlags msg = ExceptT $ runIdentity <$> sendMessagesB_ c (Identity (Right (connId, pqEnc, msgFlags, msg))) (S.singleton connId) {-# INLINE sendMessage' #-} -- | Send multiple messages to different connections (SEND command) in Reader monad -sendMessages' :: AgentClient -> [MsgReq] -> AM' [Either AgentErrorType (AgentMsgId, PQEncryption)] +sendMessages' :: AgentClient -> [MsgReq] -> AM [Either AgentErrorType (AgentMsgId, PQEncryption)] sendMessages' c = sendMessagesB' c . map Right {-# INLINE sendMessages' #-} -sendMessagesB' :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption))) -sendMessagesB' c reqs = withConnLocks c connIds "sendMessages" $ do +sendMessagesB' :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> AM (t (Either AgentErrorType (AgentMsgId, PQEncryption))) +sendMessagesB' c reqs = do + connIds <- liftEither $ foldl' addConnId (Right S.empty) reqs + lift $ sendMessagesB_ c reqs connIds + where + addConnId s@(Right s') (Right (connId, _, _, _)) + | B.null connId = s + | connId `S.notMember` s' = Right $ S.insert connId s' + | otherwise = Left $ INTERNAL "sendMessages: duplicate connection ID" + addConnId s _ = s + +sendMessagesB_ :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> Set ConnId -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption))) +sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do reqs' <- withStoreBatch c (\db -> fmap (bindRight $ \req@(connId, _, _, _) -> bimap storeError (req,) <$> getConn db connId) reqs) let (toEnable, reqs'') = mapAccumL prepareConn [] reqs' void $ withStoreBatch' c $ \db -> map (\connId -> setConnPQSupport db connId PQSupportOn) toEnable @@ -1024,14 +1093,13 @@ sendMessagesB' c reqs = withConnLocks c connIds "sendMessages" $ do where prepareMsg :: ConnData -> NonEmpty SndQueue -> ([ConnId], Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) prepareMsg cData@ConnData {connId, pqSupport} sqs - | ratchetSyncSendProhibited cData = (acc, Left $ CMD PROHIBITED) + | ratchetSyncSendProhibited cData = (acc, Left $ CMD PROHIBITED "sendMessagesB: send prohibited") -- connection is only updated if PQ encryption was disabled, and now it has to be enabled. -- support for PQ encryption (small message envelopes) will not be disabled when message is sent. | pqEnc == PQEncOn && pqSupport == PQSupportOff = let cData' = cData {pqSupport = PQSupportOn} :: ConnData in (connId : acc, Right (cData', sqs, Just pqEnc, msgFlags, A_MSG msg)) | otherwise = (acc, Right (cData, sqs, Just pqEnc, msgFlags, A_MSG msg)) - connIds = map (\(connId, _, _, _) -> connId) $ rights $ toList reqs -- / async command processing v v v @@ -1064,11 +1132,15 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do lift $ waitForWork doWork atomically $ throwWhenInactive c atomically $ beginAgentOperation c AOSndNetwork - withWork c doWork (`getPendingServerCommand` server_) $ processCmd (riFast ri) + withWork c doWork (`getPendingServerCommand` server_) $ runProcessCmd (riFast ri) where - processCmd :: RetryInterval -> PendingCommand -> AM () - processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} = case command of - AClientCommand (APC _ cmd) -> case cmd of + runProcessCmd ri cmd = do + pending <- newTVarIO [] + processCmd ri cmd pending + mapM_ (atomically . writeTBQueue subQ) . reverse =<< readTVarIO pending + processCmd :: RetryInterval -> PendingCommand -> TVar [ATransmission] -> AM () + processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} pendingCmds = case command of + AClientCommand cmd -> case cmd of NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do usedSrvs <- newTVarIO ([] :: [SMPServer]) tryCommand . withNextSrv c userId usedSrvs [] $ \srv -> do @@ -1083,11 +1155,11 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK SWCH -> - noServer . tryCommand . withConnLock c connId "switchConnection" $ + noServer . tryWithLock "switchConnection" $ withStore c (`getConn` connId) >>= \case SomeConn _ conn@(DuplexConnection _ (replaced :| _rqs) _) -> switchDuplexConnection c conn replaced >>= notify . SWITCH QDRcv SPStarted - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "SWCH: not duplex" DEL -> withServer' . tryCommand $ deleteConnection' c connId >> notify OK _ -> notify $ ERR $ INTERNAL $ "unsupported async command " <> show (aCommandTag cmd) AInternalCommand cmd -> case cmd of @@ -1098,9 +1170,12 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do withStore c $ \db -> runExceptT $ (,) <$> ExceptT (getConn db connId) <*> ExceptT (getAcceptedConfirmation db connId) case conn of RcvConnection cData rq -> do - secure rq senderKey - mapM_ (connectReplyQueues c cData ownConnInfo) (L.nonEmpty $ smpReplyQueues senderConf) - _ -> throwError $ INTERNAL $ "incorrect connection type " <> show (internalCmdTag cmd) + mapM_ (secure rq) senderKey + mapM_ (connectReplyQueues c cData ownConnInfo Nothing) (L.nonEmpty $ smpReplyQueues senderConf) + -- duplex connection is matched to handle SKEY retries + DuplexConnection cData _ (sq :| _) -> + mapM_ (connectReplyQueues c cData ownConnInfo (Just sq)) (L.nonEmpty $ smpReplyQueues senderConf) + _ -> throwE $ INTERNAL $ "incorrect connection type " <> show (internalCmdTag cmd) ICDuplexSecure _rId senderKey -> withServer' . tryWithLock "ICDuplexSecure" . withDuplexConn $ \(DuplexConnection cData (rq :| _) (sq :| _)) -> do secure rq senderKey void $ enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO @@ -1117,6 +1192,9 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do case find ((replaceQId ==) . dbQId) rqs of Just rq1 -> when (status == Confirmed) $ do secureQueue c rq' senderKey + -- we may add more statistics special to queue rotation later on, + -- not accounting secure during rotation for now: + -- atomically $ incSMPServerStat c userId server connSecured withStore' c $ \db -> setRcvQueueStatus db rq' Secured void . enqueueMessages c cData sqs SMP.noMsgFlags $ QUSE [((server, sndId), True)] rq1' <- withStore' c $ \db -> setRcvSwitchStatus db rq1 $ Just RSSendingQUSE @@ -1136,8 +1214,8 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do tryError (deleteQueue c rq') >>= \case Right () -> finalizeSwitch Left e - | temporaryOrHostError e -> throwError e - | otherwise -> finalizeSwitch >> throwError e + | temporaryOrHostError e -> throwE e + | otherwise -> finalizeSwitch >> throwE e where finalizeSwitch = do withStore' c $ \db -> deleteConnRcvQueue db rq' @@ -1152,8 +1230,9 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do rq <- withStore c $ \db -> getRcvQueue db connId srv rId ackQueueMessage c rq srvMsgId secure :: RcvQueue -> SMP.SndPublicAuthKey -> AM () - secure rq senderKey = do + secure rq@RcvQueue {server} senderKey = do secureQueue c rq senderKey + atomically $ incSMPServerStat c userId server connSecured withStore' c $ \db -> setRcvQueueStatus db rq Secured where withServer a = case server_ of @@ -1177,13 +1256,15 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do tryWithLock name = tryCommand . withConnLock c connId name internalErr s = cmdError $ INTERNAL $ s <> ": " <> show (agentCommandTag command) cmdError e = notify (ERR e) >> withStore' c (`deleteCommand` cmdId) - notify :: forall e. AEntityI e => ACommand 'Agent e -> AM () - notify cmd = atomically $ writeTBQueue subQ (corrId, connId, APC (sAEntity @e) cmd) + notify :: forall e. AEntityI e => AEvent e -> AM () + notify cmd = + let t = (corrId, connId, AEvt (sAEntity @e) cmd) + in atomically $ ifM (isFullTBQueue subQ) (modifyTVar' pendingCmds (t :)) (writeTBQueue subQ t) -- ^ ^ ^ async command processing / enqueueMessages :: AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, PQEncryption) enqueueMessages c cData sqs msgFlags aMessage = do - when (ratchetSyncSendProhibited cData) $ throwError $ INTERNAL "enqueueMessages: ratchet is not synchronized" + when (ratchetSyncSendProhibited cData) $ throwE $ INTERNAL "enqueueMessages: ratchet is not synchronized" enqueueMessages' c cData sqs msgFlags aMessage enqueueMessages' :: AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, CR.PQEncryption) @@ -1207,7 +1288,7 @@ enqueueMessage c cData sq msgFlags aMessage = {-# INLINE enqueueMessage #-} -- this function is used only for sending messages in batch, it returns the list of successes to enqueue additional deliveries -enqueueMessageB :: forall t. (Traversable t) => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) -> AM' (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId)))) +enqueueMessageB :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) -> AM' (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId)))) enqueueMessageB c reqs = do cfg <- asks config reqMids <- withStoreBatch c $ \db -> fmap (bindRight $ storeSentMsg db cfg) reqs @@ -1239,7 +1320,7 @@ enqueueSavedMessage :: AgentClient -> ConnData -> AgentMsgId -> SndQueue -> AM' enqueueSavedMessage c cData msgId sq = enqueueSavedMessageB c $ Identity (cData, [sq], msgId) {-# INLINE enqueueSavedMessage #-} -enqueueSavedMessageB :: (Foldable t) => AgentClient -> t (ConnData, [SndQueue], AgentMsgId) -> AM' () +enqueueSavedMessageB :: Foldable t => AgentClient -> t (ConnData, [SndQueue], AgentMsgId) -> AM' () enqueueSavedMessageB c reqs = do -- saving to the database is in the start to avoid race conditions when delivery is read from queue before it is saved void $ withStoreBatch' c $ \db -> concatMap (storeDeliveries db) reqs @@ -1269,7 +1350,7 @@ submitPendingMsg c cData sq = do void $ getDeliveryWorker True c cData sq runSmpQueueMsgDelivery :: AgentClient -> ConnData -> SndQueue -> (Worker, TMVar ()) -> AM () -runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork}, qLock) = do +runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userId, server, sndSecure} (Worker {doWork}, qLock) = do AgentConfig {messageRetryInterval = ri, messageTimeout, helloTimeout, quotaExceededTimeout} <- asks config forever $ do atomically $ endAgentOperation c AOSndNetwork @@ -1283,7 +1364,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork let mId = unId msgId ri' = maybe id updateRetryInterval2 msgRetryState ri withRetryLock2 ri' qLock $ \riState loop -> do - lift $ waitForUserNetwork c + liftIO $ waitForUserNetwork c resp <- tryError $ case msgType of AM_CONN_INFO -> sendConfirmation c sq msgBody AM_CONN_INFO_REPLY -> sendConfirmation c sq msgBody @@ -1292,55 +1373,69 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork Left e -> do let err = if msgType == AM_A_MSG_ then MERR mId e else ERR e case e of - SMP SMP.QUOTA -> case msgType of - AM_CONN_INFO -> connError msgId NOT_AVAILABLE - AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE - _ -> do - expireTs <- addUTCTime (-quotaExceededTimeout) <$> liftIO getCurrentTime - if internalTs < expireTs then notifyDelMsgs msgId e expireTs else retrySndMsg RISlow - SMP SMP.AUTH -> case msgType of - AM_CONN_INFO -> connError msgId NOT_AVAILABLE - AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE - AM_RATCHET_INFO -> connError msgId NOT_AVAILABLE - -- in duplexHandshake mode (v2) HELLO is only sent once, without retrying, - -- because the queue must be secured by the time the confirmation or the first HELLO is received - AM_HELLO_ -> case rq_ of - -- party initiating connection - Just _ -> connError msgId NOT_AVAILABLE - -- party joining connection - _ -> connError msgId NOT_ACCEPTED - AM_REPLY_ -> notifyDel msgId err - AM_A_MSG_ -> notifyDel msgId err - AM_A_RCVD_ -> notifyDel msgId err - AM_QCONT_ -> notifyDel msgId err - AM_QADD_ -> qError msgId "QADD: AUTH" - AM_QKEY_ -> qError msgId "QKEY: AUTH" - AM_QUSE_ -> qError msgId "QUSE: AUTH" - AM_QTEST_ -> qError msgId "QTEST: AUTH" - AM_EREADY_ -> notifyDel msgId err + SMP _ SMP.QUOTA -> do + atomically $ incSMPServerStat c userId server sentQuotaErrs + case msgType of + AM_CONN_INFO -> connError msgId NOT_AVAILABLE + AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE + _ -> do + expireTs <- addUTCTime (-quotaExceededTimeout) <$> liftIO getCurrentTime + if internalTs < expireTs + then notifyDelMsgs msgId e expireTs + else do + notify $ MWARN (unId msgId) e + retrySndMsg RISlow + SMP _ SMP.AUTH -> do + atomically $ incSMPServerStat c userId server sentAuthErrs + case msgType of + AM_CONN_INFO -> connError msgId NOT_AVAILABLE + AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE + AM_RATCHET_INFO -> connError msgId NOT_AVAILABLE + -- in duplexHandshake mode (v2) HELLO is only sent once, without retrying, + -- because the queue must be secured by the time the confirmation or the first HELLO is received + AM_HELLO_ -> case rq_ of + -- party initiating connection + Just _ -> connError msgId NOT_AVAILABLE + -- party joining connection + _ -> connError msgId NOT_ACCEPTED + AM_A_MSG_ -> notifyDel msgId err + AM_A_RCVD_ -> notifyDel msgId err + AM_QCONT_ -> notifyDel msgId err + AM_QADD_ -> qError msgId "QADD: AUTH" + AM_QKEY_ -> qError msgId "QKEY: AUTH" + AM_QUSE_ -> qError msgId "QUSE: AUTH" + AM_QTEST_ -> qError msgId "QTEST: AUTH" + AM_EREADY_ -> notifyDel msgId err _ -- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server), -- the message sending would be retried | temporaryOrHostError e -> do let msgTimeout = if msgType == AM_HELLO_ then helloTimeout else messageTimeout expireTs <- addUTCTime (-msgTimeout) <$> liftIO getCurrentTime - if internalTs < expireTs then notifyDelMsgs msgId e expireTs else retrySndMsg RIFast - | otherwise -> notifyDel msgId err + if internalTs < expireTs + then notifyDelMsgs msgId e expireTs + else do + when (serverHostError e) $ notify $ MWARN (unId msgId) e + retrySndMsg RIFast + | otherwise -> do + atomically $ incSMPServerStat c userId server sentOtherErrs + notifyDel msgId err where retrySndMsg riMode = do withStore' c $ \db -> updatePendingMsgRIState db connId msgId riState retrySndOp c $ loop riMode - Right () -> do + Right proxySrv_ -> do case msgType of - AM_CONN_INFO -> setConfirmed - AM_CONN_INFO_REPLY -> setConfirmed + AM_CONN_INFO + | sndSecure -> notify (CON pqEncryption) >> setStatus Active + | otherwise -> setStatus Confirmed + AM_CONN_INFO_REPLY -> setStatus Confirmed AM_RATCHET_INFO -> pure () - AM_REPLY_ -> pure () AM_HELLO_ -> do withStore' c $ \db -> setSndQueueStatus db sq Active case rq_ of -- party initiating connection (in v1) - Just RcvQueue {status} -> + Just rq@RcvQueue {status} -> -- it is unclear why subscribeQueue was needed here, -- message delivery can only be enabled for queues that were created in the current session or subscribed -- subscribeQueue c rq connId @@ -1349,10 +1444,12 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork -- it would lead to the non-deterministic internal ID of the first sent message, at to some other race conditions, -- because it can be sent before HELLO is received -- With `status == Active` condition, CON is sent here only by the accepting party, that previously received HELLO - when (status == Active) $ notify $ CON pqEncryption + when (status == Active) $ do + atomically $ incSMPServerStat c userId (qServer rq) connCompleted + notify $ CON pqEncryption -- this branch should never be reached as receive queue is created before the confirmation, _ -> logError "HELLO sent without receive queue" - AM_A_MSG_ -> notify $ SENT mId + AM_A_MSG_ -> notify $ SENT mId proxySrv_ AM_A_RCVD_ -> pure () AM_QCONT_ -> pure () AM_QADD_ -> pure () @@ -1390,9 +1487,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork AM_EREADY_ -> pure () delMsgKeep (msgType == AM_A_MSG_) msgId where - setConfirmed = do + setStatus status = do withStore' c $ \db -> do - setSndQueueStatus db sq Confirmed + setSndQueueStatus db sq status when (isJust rq_) $ removeConfirmations db connId where notifyDelMsgs :: InternalId -> AgentErrorType -> UTCTime -> AM () @@ -1402,13 +1499,14 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork forM_ (L.nonEmpty msgIds_) $ \msgIds -> do notify $ MERRS (L.map unId msgIds) err withStore' c $ \db -> forM_ msgIds $ \msgId' -> deleteSndMsgDelivery db connId sq msgId' False `catchAll_` pure () + atomically $ incSMPServerStat' c userId server sentExpiredErrs (length msgIds_ + 1) delMsg :: InternalId -> AM () delMsg = delMsgKeep False delMsgKeep :: Bool -> InternalId -> AM () delMsgKeep keepForReceipt msgId = withStore' c $ \db -> deleteSndMsgDelivery db connId sq msgId keepForReceipt - notify :: forall e. AEntityI e => ACommand 'Agent e -> AM () - notify cmd = atomically $ writeTBQueue subQ ("", connId, APC (sAEntity @e) cmd) - notifyDel :: AEntityI e => InternalId -> ACommand 'Agent e -> AM () + notify :: forall e. AEntityI e => AEvent e -> AM () + notify cmd = atomically $ writeTBQueue subQ ("", connId, AEvt (sAEntity @e) cmd) + notifyDel :: AEntityI e => InternalId -> AEvent e -> AM () notifyDel msgId cmd = notify cmd >> delMsg msgId connError msgId = notifyDel msgId . ERR . CONN qError msgId = notifyDel msgId . ERR . AGENT . A_QUEUE @@ -1428,9 +1526,9 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do case conn of DuplexConnection {} -> ack >> sendRcpt conn >> del RcvConnection {} -> ack >> del - SndConnection {} -> throwError $ CONN SIMPLEX - ContactConnection {} -> throwError $ CMD PROHIBITED - NewConnection _ -> throwError $ CMD PROHIBITED + SndConnection {} -> throwE $ CONN SIMPLEX + ContactConnection {} -> throwE $ CMD PROHIBITED "ackMessage: ContactConnection" + NewConnection _ -> throwE $ CMD PROHIBITED "ackMessage: NewConnection" where ack :: AM () ack = do @@ -1444,7 +1542,7 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do msg@RcvMsg {msgType, msgReceipt} <- withStore c $ \db -> getRcvMsg db connId $ InternalId msgId case rcptInfo_ of Just rcptInfo -> do - unless (msgType == AM_A_MSG_) $ throwError (CMD PROHIBITED) + unless (msgType == AM_A_MSG_) . throwE $ CMD PROHIBITED "ackMessage: receipt not allowed" when (connAgentVersion >= deliveryRcptsSMPAgentVersion) $ do let RcvMsg {msgMeta = MsgMeta {sndMsgId}, internalHash} = msg rcpt = A_RCVD [AMessageReceipt {agentMsgId = sndMsgId, msgHash = internalHash, rcptInfo}] @@ -1455,17 +1553,27 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do withStore' c $ \db -> deleteDeliveredSndMsg db connId $ InternalId sndMsgId _ -> pure () +getConnectionQueueInfo' :: AgentClient -> ConnId -> AM ServerQueueInfo +getConnectionQueueInfo' c connId = do + SomeConn _ conn <- withStore c (`getConn` connId) + case conn of + DuplexConnection _ (rq :| _) _ -> getQueueInfo c rq + RcvConnection _ rq -> getQueueInfo c rq + ContactConnection _ rq -> getQueueInfo c rq + SndConnection {} -> throwE $ CONN SIMPLEX + NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionQueueInfo': NewConnection" + switchConnection' :: AgentClient -> ConnId -> AM ConnectionStats switchConnection' c connId = withConnLock c connId "switchConnection" $ withStore c (`getConn` connId) >>= \case SomeConn _ conn@(DuplexConnection cData rqs@(rq :| _rqs) _) - | isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED + | isJust (switchingRQ rqs) -> throwE $ CMD PROHIBITED "switchConnection: already switching" | otherwise -> do - when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED + when (ratchetSyncSendProhibited cData) $ throwE $ CMD PROHIBITED "switchConnection: send prohibited" rq' <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted switchDuplexConnection c conn rq' - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "switchConnection: not duplex" switchDuplexConnection :: AgentClient -> Connection 'CDuplex -> RcvQueue -> AM ConnectionStats switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBQueueId dbQueueId, sndId} = do @@ -1474,10 +1582,10 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s -- try to get the server that is different from all queues, or at least from the primary rcv queue srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs) srv' <- if srv == server then getNextServer c userId [server] else pure srvAuth - (q, qUri) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe + (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe False let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq' - liftIO $ addSubscription c rq'' + lift $ addNewQueueSubscription c rq'' tSess sessId void . enqueueMessages c cData sqs SMP.noMsgFlags $ QADD [(qUri, Just (server, sndId))] rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSendingQADD let rqs' = updatedQs rq1 rqs <> [rq''] @@ -1490,7 +1598,7 @@ abortConnectionSwitch' c connId = SomeConn _ (DuplexConnection cData rqs sqs) -> case switchingRQ rqs of Just rq | canAbortRcvSwitch rq -> do - when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED + when (ratchetSyncSendProhibited cData) $ throwE $ CMD PROHIBITED "abortConnectionSwitch: send prohibited" -- multiple queues to which the connections switches were possible when repeating switch was allowed let (delRqs, keepRqs) = L.partition ((Just (dbQId rq) ==) . dbReplaceQId) rqs case L.nonEmpty keepRqs of @@ -1502,10 +1610,10 @@ abortConnectionSwitch' c connId = let rqs'' = updatedQs rq' rqs' conn' = DuplexConnection cData rqs'' sqs pure $ connectionStats conn' - _ -> throwError $ INTERNAL "won't delete all rcv queues in connection" - | otherwise -> throwError $ CMD PROHIBITED - _ -> throwError $ CMD PROHIBITED - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ INTERNAL "won't delete all rcv queues in connection" + | otherwise -> throwE $ CMD PROHIBITED "abortConnectionSwitch: no rcv queues left" + _ -> throwE $ CMD PROHIBITED "abortConnectionSwitch: not allowed" + _ -> throwE $ CMD PROHIBITED "abortConnectionSwitch: not duplex" synchronizeRatchet' :: AgentClient -> ConnId -> PQSupport -> Bool -> AM ConnectionStats synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchronizeRatchet" $ do @@ -1525,14 +1633,18 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni let cData'' = cData' {ratchetSyncState = RSStarted} :: ConnData conn' = DuplexConnection cData'' rqs sqs pure $ connectionStats conn' - | otherwise -> throwError $ CMD PROHIBITED - _ -> throwError $ CMD PROHIBITED + | otherwise -> throwE $ CMD PROHIBITED "synchronizeRatchet: not allowed" + _ -> throwE $ CMD PROHIBITED "synchronizeRatchet: not duplex" ackQueueMessage :: AgentClient -> RcvQueue -> SMP.MsgId -> AM () -ackQueueMessage c rq srvMsgId = - sendAck c rq srvMsgId `catchAgentError` \case - SMP SMP.NO_MSG -> pure () - e -> throwError e +ackQueueMessage c rq@RcvQueue {userId, server} srvMsgId = do + atomically $ incSMPServerStat c userId server ackAttempts + tryAgentError (sendAck c rq srvMsgId) >>= \case + Right _ -> atomically $ incSMPServerStat c userId server ackMsgs + Left (SMP _ SMP.NO_MSG) -> atomically $ incSMPServerStat c userId server ackNoMsgErrs + Left e -> do + unless (temporaryOrHostError e) $ atomically $ incSMPServerStat c userId server ackOtherErrs + throwE e -- | Suspend SMP agent connection (OFF command) in Reader monad suspendConnection' :: AgentClient -> ConnId -> AM () @@ -1542,8 +1654,8 @@ suspendConnection' c connId = withConnLock c connId "suspendConnection" $ do DuplexConnection _ rqs _ -> mapM_ (suspendQueue c) rqs RcvConnection _ rq -> suspendQueue c rq ContactConnection _ rq -> suspendQueue c rq - SndConnection _ _ -> throwError $ CONN SIMPLEX - NewConnection _ -> throwError $ CMD PROHIBITED + SndConnection _ _ -> throwE $ CONN SIMPLEX + NewConnection _ -> throwE $ CMD PROHIBITED "suspendConnection" -- | Delete SMP agent connection (DEL command) in Reader monad -- unlike deleteConnectionAsync, this function does not mark connection as deleted in case of deletion failure @@ -1599,7 +1711,7 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do -- ! between completed deletions of connections, and deletions delayed due to wait for delivery (see deleteConn) deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing rs' <- lift $ catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) (M.keys delRs)) - forM_ rs' $ \cId -> notify ("", cId, APC SAEConn DEL_CONN) + forM_ rs' $ \cId -> notify ("", cId, AEvt SAEConn DEL_CONN) pure (errs' <> delRs, rqs, connIds') where rcvQueues :: SomeConn -> Either (Either AgentErrorType ()) [RcvQueue] @@ -1614,7 +1726,7 @@ deleteConnQueues c waitDelivery ntf rqs = do let connIds = M.keys $ M.filter isRight rs deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing rs' <- catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) connIds) - forM_ rs' $ \cId -> notify ("", cId, APC SAEConn DEL_CONN) + forM_ rs' $ \cId -> notify ("", cId, AEvt SAEConn DEL_CONN) pure rs where deleteQueueRecs :: [(RcvQueue, Either AgentErrorType ())] -> AM' [(RcvQueue, Either AgentErrorType ())] @@ -1629,12 +1741,16 @@ deleteConnQueues c waitDelivery ntf rqs = do Int -> (RcvQueue, Either AgentErrorType ()) -> IO ((RcvQueue, Either AgentErrorType ()), Maybe (AM' ())) - deleteQueueRec db maxErrs (rq, r) = case r of + deleteQueueRec db maxErrs (rq@RcvQueue {userId, server}, r) = case r of Right _ -> deleteConnRcvQueue db rq $> ((rq, r), Just (notifyRQ rq Nothing)) Left e | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> incRcvDeleteErrors db rq $> ((rq, r), Nothing) - | otherwise -> deleteConnRcvQueue db rq $> ((rq, Right ()), Just (notifyRQ rq (Just e))) - notifyRQ rq e_ = notify ("", qConnId rq, APC SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_) + | otherwise -> do + deleteConnRcvQueue db rq + -- attempts and successes are counted in deleteQueues function + atomically $ incSMPServerStat c userId server connDeleted + pure ((rq, Right ()), Just (notifyRQ rq (Just e))) + notifyRQ rq e_ = notify ("", qConnId rq, AEvt SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_) notify = when ntf . atomically . writeTBQueue (subQ c) connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ()) connResults = M.map snd . foldl' addResult M.empty @@ -1671,7 +1787,7 @@ deleteConnections_ getConnections ntf waitDelivery c connIds = do let actual = M.size rs expected = length connIds when (actual /= expected) . atomically $ - writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected) + writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected) getConnectionServers' :: AgentClient -> ConnId -> AM ConnectionStats getConnectionServers' c connId = do @@ -1705,10 +1821,17 @@ connectionStats = \case ratchetSyncSupported = connAgentVersion >= ratchetSyncSMPAgentVersion } --- | Change servers to be used for creating new queues, in Reader monad -setProtocolServers :: (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> IO () -setProtocolServers c userId srvs = atomically $ TM.insert userId srvs (userServers c) -{-# INLINE setProtocolServers #-} +-- | Change servers to be used for creating new queues. +-- This function will set all servers as enabled in case all passed servers are disabled. +setProtocolServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> NonEmpty (ServerCfg p) -> IO () +setProtocolServers c userId srvs = do + checkUserServers "setProtocolServers" srvs + atomically $ TM.insert userId (mkUserServers srvs) (userServers c) + +checkUserServers :: Text -> NonEmpty (ServerCfg p) -> IO () +checkUserServers name srvs = + unless (any (\ServerCfg {enabled} -> enabled) srvs) $ + logWarn (name <> ": all passed servers are disabled, using all servers.") registerNtfToken' :: AgentClient -> DeviceToken -> NotificationsMode -> AM NtfTknStatus registerNtfToken' c suppliedDeviceToken suppliedNtfMode = @@ -1754,7 +1877,7 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = ns <- asks ntfSupervisor tryReplace ns `catchAgentError` \e -> if temporaryOrHostError e - then throwError e + then throwE e else do withStore' c $ \db -> removeNtfToken db tkn atomically $ nsRemoveNtfToken ns @@ -1781,7 +1904,7 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = withStore' c (`createNtfToken` tkn) registerToken tkn pure NTRegistered - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "createToken" registerToken :: NtfToken -> AM () registerToken tkn@NtfToken {ntfPubKey, ntfDhKeys = (pubDhKey, privDhKey)} = do (tknId, srvPubDhKey) <- agentNtfRegisterToken c tkn ntfPubKey pubDhKey @@ -1794,7 +1917,7 @@ verifyNtfToken' :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AM ( verifyNtfToken' c deviceToken nonce code = withStore' c getSavedNtfToken >>= \case Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret, ntfMode} -> do - when (deviceToken /= savedDeviceToken) . throwError $ CMD PROHIBITED + when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "verifyNtfToken: different token" code' <- liftEither . bimap cryptoError NtfRegCode $ C.cbDecrypt dhSecret nonce code toStatus <- withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $ @@ -1803,36 +1926,36 @@ verifyNtfToken' c deviceToken nonce code = cron <- asks $ ntfCron . config agentNtfEnableCron c tknId tkn cron when (ntfMode == NMInstant) $ initializeNtfSubs c - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "verifyNtfToken: no token" checkNtfToken' :: AgentClient -> DeviceToken -> AM NtfTknStatus checkNtfToken' c deviceToken = withStore' c getSavedNtfToken >>= \case Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId} -> do - when (deviceToken /= savedDeviceToken) . throwError $ CMD PROHIBITED + when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "checkNtfToken: different token" agentNtfCheckToken c tknId tkn - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "checkNtfToken: no token" deleteNtfToken' :: AgentClient -> DeviceToken -> AM () deleteNtfToken' c deviceToken = withStore' c getSavedNtfToken >>= \case Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do - when (deviceToken /= savedDeviceToken) . throwError $ CMD PROHIBITED + when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "deleteNtfToken: different token" deleteToken_ c tkn deleteNtfSubs c NSCSmpDelete - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token" getNtfToken' :: AgentClient -> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer) getNtfToken' c = withStore' c getSavedNtfToken >>= \case Just NtfToken {deviceToken, ntfTknStatus, ntfMode, ntfServer} -> pure (deviceToken, ntfTknStatus, ntfMode, ntfServer) - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "getNtfToken" getNtfTokenData' :: AgentClient -> AM NtfToken getNtfTokenData' c = withStore' c getSavedNtfToken >>= \case Just tkn -> pure tkn - _ -> throwError $ CMD PROHIBITED + _ -> throwE $ CMD PROHIBITED "getNtfTokenData" -- | Set connection notifications, in Reader monad toggleConnectionNtfs' :: AgentClient -> ConnId -> Bool -> AM () @@ -1842,7 +1965,7 @@ toggleConnectionNtfs' c connId enable = do DuplexConnection cData _ _ -> toggle cData RcvConnection cData _ -> toggle cData ContactConnection cData _ -> toggle cData - _ -> throwError $ CONN SIMPLEX + _ -> throwE $ CONN SIMPLEX where toggle :: ConnData -> AM () toggle cData @@ -1861,8 +1984,8 @@ deleteToken_ c tkn@NtfToken {ntfTokenId, ntfTknStatus} = do withStore' c $ \db -> updateNtfToken db tkn ntfTknStatus ntfTknAction atomically $ nsUpdateToken ns tkn {ntfTknStatus, ntfTknAction} agentNtfDeleteToken c tknId tkn `catchAgentError` \case - NTF AUTH -> pure () - e -> throwError e + NTF _ AUTH -> pure () + e -> throwE e withStore' c $ \db -> removeNtfToken db tkn atomically $ nsRemoveNtfToken ns @@ -1878,12 +2001,12 @@ withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = let updatedToken = tkn {ntfTknStatus = toStatus, ntfTknAction = toAction_} atomically $ nsUpdateToken ns updatedToken pure toStatus - Left e@(NTF AUTH) -> do + Left e@(NTF _ AUTH) -> do withStore' c $ \db -> removeNtfToken db tkn atomically $ nsRemoveNtfToken ns void $ registerNtfToken' c deviceToken ntfMode - throwError e - Left e -> throwError e + throwE e + Left e -> throwE e initializeNtfSubs :: AgentClient -> AM () initializeNtfSubs c = sendNtfConnCommands c NSCCreate @@ -1904,12 +2027,20 @@ sendNtfConnCommands c cmd = do Just (ConnData {enableNtfs}, _) -> when enableNtfs . atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd) _ -> - atomically $ writeTBQueue (subQ c) ("", connId, APC SAEConn $ ERR $ INTERNAL "no connection data") + atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn $ ERR $ INTERNAL "no connection data") setNtfServers :: AgentClient -> [NtfServer] -> IO () setNtfServers c = atomically . writeTVar (ntfServers c) {-# INLINE setNtfServers #-} +resetAgentServersStats' :: AgentClient -> AM () +resetAgentServersStats' c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt} = do + startedAt <- liftIO getCurrentTime + atomically $ writeTVar srvStatsStartedAt startedAt + atomically $ TM.clear smpServersStats + atomically $ TM.clear xftpServersStats + withStore' c (`resetServersStats` startedAt) + -- | Activate operations foregroundAgent :: AgentClient -> IO () foregroundAgent c = do @@ -1964,9 +2095,7 @@ subscriber :: AgentClient -> AM' () subscriber c@AgentClient {msgQ} = forever $ do t <- atomically $ readTBQueue msgQ agentOperationBracket c AORcvNetwork waitUntilActive $ - runExceptT (processSMPTransmission c t) >>= \case - Left e -> liftIO $ print e - Right _ -> return () + processSMPTransmissions c t cleanupManager :: AgentClient -> AM' () cleanupManager c@AgentClient {subQ} = do @@ -1988,7 +2117,7 @@ cleanupManager c@AgentClient {subQ} = do run SFERR deleteExpiredReplicasForDeletion liftIO $ threadDelay' int where - run :: forall e. AEntityI e => (AgentErrorType -> ACommand 'Agent e) -> AM () -> AM' () + run :: forall e. AEntityI e => (AgentErrorType -> AEvent e) -> AM () -> AM' () run err a = do waitActive . runExceptT $ a `catchAgentError` (notify "" . err) step <- asks $ cleanupStepInterval . config @@ -2035,25 +2164,85 @@ cleanupManager c@AgentClient {subQ} = do deleteExpiredReplicasForDeletion = do rcvFilesTTL <- asks $ rcvFilesTTL . config withStore' c (`deleteDeletedSndChunkReplicasExpired` rcvFilesTTL) - notify :: forall e. AEntityI e => EntityId -> ACommand 'Agent e -> AM () - notify entId cmd = atomically $ writeTBQueue subQ ("", entId, APC (sAEntity @e) cmd) + notify :: forall e. AEntityI e => EntityId -> AEvent e -> AM () + notify entId cmd = atomically $ writeTBQueue subQ ("", entId, AEvt (sAEntity @e) cmd) data ACKd = ACKd | ACKPending --- | make sure to ACK or throw in each message processing branch --- it cannot be finally, unfortunately, as sometimes it needs to be ACK+DEL -processSMPTransmission :: AgentClient -> ServerTransmission SMPVersion BrokerMsg -> AM () -processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, sessId, isResponse, rId, cmd) = do - (rq, SomeConn _ conn) <- withStore c (\db -> getRcvConn db srv rId) - processSMP rq conn $ toConnData conn +-- | Make sure to ACK or throw in each message processing branch +-- It cannot be finally, as sometimes it needs to be ACK+DEL, +-- and sometimes ACK has to be sent from the consumer. +processSMPTransmissions :: AgentClient -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> AM' () +processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId, ts) = do + upConnIds <- newTVarIO [] + forM_ ts $ \(entId, t) -> case t of + STEvent msgOrErr -> + withRcvConn entId $ \rq@RcvQueue {connId} conn -> case msgOrErr of + Right msg -> runProcessSMP rq conn (toConnData conn) msg + Left e -> lift $ notifyErr connId e + STResponse (Cmd SRecipient cmd) respOrErr -> + withRcvConn entId $ \rq conn -> case cmd of + SMP.SUB -> case respOrErr of + Right SMP.OK -> processSubOk rq upConnIds + Right msg@SMP.MSG {} -> do + processSubOk rq upConnIds -- the connection is UP even when processing this particular message fails + runProcessSMP rq conn (toConnData conn) msg + Right r -> processSubErr rq $ unexpectedResponse r + Left e -> unless (temporaryClientError e) $ processSubErr rq e -- timeout/network was already reported + SMP.ACK _ -> case respOrErr of + Right msg@SMP.MSG {} -> runProcessSMP rq conn (toConnData conn) msg + _ -> pure () -- TODO process OK response to ACK + _ -> pure () -- TODO process expired response to DEL + STResponse {} -> pure () -- TODO process expired responses to sent messages + STUnexpectedError e -> do + logServer "<--" c srv entId $ "error: " <> bshow e + notifyErr "" e + connIds <- readTVarIO upConnIds + unless (null connIds) $ do + notify' "" $ UP srv connIds + atomically $ incSMPServerStat' c userId srv connSubscribed $ length connIds where - processSMP :: forall c. RcvQueue -> Connection c -> ConnData -> AM () + withRcvConn :: SMP.RecipientId -> (forall c. RcvQueue -> Connection c -> AM ()) -> AM' () + withRcvConn rId a = do + tryAgentError' (withStore c $ \db -> getRcvConn db srv rId) >>= \case + Left e -> notify' "" (ERR e) + Right (rq@RcvQueue {connId}, SomeConn _ conn) -> + tryAgentError' (a rq conn) >>= \case + Left e -> notify' connId (ERR e) + Right () -> pure () + processSubOk :: RcvQueue -> TVar [ConnId] -> AM () + processSubOk rq@RcvQueue {connId} upConnIds = + atomically . whenM (isPendingSub connId) $ do + addSubscription c rq + modifyTVar' upConnIds (connId :) + processSubErr :: RcvQueue -> SMPClientError -> AM () + processSubErr rq@RcvQueue {connId} e = do + atomically . whenM (isPendingSub connId) $ + failSubscription c rq e >> incSMPServerStat c userId srv connSubErrs + lift $ notifyErr connId e + isPendingSub connId = do + pending <- (&&) <$> hasPendingSubscription c connId <*> activeClientSession c tSess sessId + unless pending $ incSMPServerStat c userId srv connSubIgnored + pure pending + notify' :: forall e m. (AEntityI e, MonadIO m) => ConnId -> AEvent e -> m () + notify' connId msg = atomically $ writeTBQueue subQ ("", connId, AEvt (sAEntity @e) msg) + notifyErr :: ConnId -> SMPClientError -> AM' () + notifyErr connId = notify' connId . ERR . protocolClientError SMP (B.unpack $ strEncode srv) + runProcessSMP :: RcvQueue -> Connection c -> ConnData -> BrokerMsg -> AM () + runProcessSMP rq conn cData msg = do + pending <- newTVarIO [] + processSMP rq conn cData msg pending + mapM_ (atomically . writeTBQueue subQ) . reverse =<< readTVarIO pending + processSMP :: forall c. RcvQueue -> Connection c -> ConnData -> BrokerMsg -> TVar [ATransmission] -> AM () processSMP - rq@RcvQueue {e2ePrivKey, e2eDhSecret, status} + rq@RcvQueue {rcvId = rId, sndSecure, e2ePrivKey, e2eDhSecret, status} conn - cData@ConnData {userId, connId, connAgentVersion, ratchetSyncState = rss} = - withConnLock c connId "processSMP" $ case cmd of - SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} -> + cData@ConnData {connId, connAgentVersion, ratchetSyncState = rss} + smpMsg + pendingMsgs = + withConnLock c connId "processSMP" $ case smpMsg of + SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} -> do + atomically $ incSMPServerStat c userId srv recvMsgs void . handleNotifyAck $ do msg' <- decryptSMPMessage rq msg ack' <- handleNotifyAck $ case msg' of @@ -2070,16 +2259,19 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <- parseMessage msgBody clientVRange <- asks $ smpClientVRange . config - unless (phVer `isCompatible` clientVRange) . throwError $ AGENT A_VERSION + unless (phVer `isCompatible` clientVRange) . throwE $ AGENT A_VERSION case (e2eDhSecret, e2ePubKey_) of (Nothing, Just e2ePubKey) -> do let e2eDh = C.dh' e2ePubKey e2ePrivKey decryptClientMessage e2eDh clientMsg >>= \case (SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption_, encConnInfo, agentVersion}) -> - smpConfirmation srvMsgId conn senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack + smpConfirmation srvMsgId conn (Just senderKey) e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack + (SMP.PHEmpty, AgentConfirmation {e2eEncryption_, encConnInfo, agentVersion}) + | sndSecure -> smpConfirmation srvMsgId conn Nothing e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack + | otherwise -> prohibited "handshake: missing sender key" >> ack (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) -> smpInvitation srvMsgId conn connReq connInfo >> ack - _ -> prohibited >> ack + _ -> prohibited "handshake: incorrect state" >> ack (Just e2eDh, Nothing) -> do decryptClientMessage e2eDh clientMsg >>= \case (SMP.PHEmpty, AgentRatchetKey {agentVersion, e2eEncryption}) -> do @@ -2102,7 +2294,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, _ -> pure () let encryptedMsgHash = C.sha256Hash encAgentMessage g <- asks random - tryError (agentClientMsg g encryptedMsgHash) >>= \case + tryAgentError (agentClientMsg g encryptedMsgHash) >>= \case Right (Just (msgId, msgMeta, aMessage, rcPrev)) -> do conn'' <- resetRatchetSync case aMessage of @@ -2133,12 +2325,13 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, withStore' c $ \db -> setConnRatchetSync db connId RSOk pure conn'' | otherwise = pure conn' - Right _ -> prohibited >> ack + Right Nothing -> prohibited "msg: bad agent msg" >> ack Left e@(AGENT A_DUPLICATE) -> do + atomically $ incSMPServerStat c userId srv recvDuplicates withStore' c (\db -> getLastMsg db connId srvMsgId) >>= \case Just RcvMsg {internalId, msgMeta, msgBody = agentMsgBody, userAck} | userAck -> ackDel internalId - | otherwise -> do + | otherwise -> liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case AgentMessage _ (A_MSG body) -> do logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId @@ -2147,6 +2340,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, _ -> ack _ -> checkDuplicateHash e encryptedMsgHash >> ack Left (AGENT (A_CRYPTO e)) -> do + atomically $ incSMPServerStat c userId srv recvCryptoErrs exists <- withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash unless exists notifySync ack @@ -2159,12 +2353,14 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, conn'' = updateConnection cData'' connDuplex notify . RSYNC rss' (Just e) $ connectionStats conn'' withStore' c $ \db -> setConnRatchetSync db connId rss' - Left e -> checkDuplicateHash e encryptedMsgHash >> ack + Left e -> do + atomically $ incSMPServerStat c userId srv recvErrs + checkDuplicateHash e encryptedMsgHash >> ack where checkDuplicateHash :: AgentErrorType -> ByteString -> AM () checkDuplicateHash e encryptedMsgHash = unlessM (withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash) $ - throwError e + throwE e agentClientMsg :: TVar ChaChaDRG -> ByteString -> AM (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448)) agentClientMsg g encryptedMsgHash = withStore c $ \db -> runExceptT $ do rc <- ExceptT $ getRatchet db connId -- ratchet state pre-decryption - required for processing EREADY @@ -2183,8 +2379,13 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, liftIO $ createRcvMsg db connId rq rcvMsg pure $ Just (internalId, msgMeta, aMessage, rc) _ -> pure Nothing - _ -> prohibited >> ack - _ -> prohibited >> ack + _ -> prohibited "msg: bad client msg" >> ack + (Just e2eDh, Just _) -> + decryptClientMessage e2eDh clientMsg >>= \case + -- this is a repeated confirmation delivery because ack failed to be sent + (_, AgentConfirmation {}) -> ack + _ -> prohibited "msg: public header" >> ack + (Nothing, Nothing) -> prohibited "msg: no keys" >> ack updateConnVersion :: Connection c -> ConnData -> VersionSMPA -> AM (Connection c) updateConnVersion conn' cData' msgAgentVersion = do aVRange <- asks $ smpAgentVRange . config @@ -2204,34 +2405,39 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, handleNotifyAck :: AM ACKd -> AM ACKd handleNotifyAck m = m `catchAgentError` \e -> notify (ERR e) >> ack SMP.END -> - atomically (TM.lookup tSess smpClients $>>= (tryReadTMVar . sessionVar) >>= processEND) - >>= logServer "<--" c srv rId + atomically (TM.lookup tSess (smpClients c) $>>= (tryReadTMVar . sessionVar) >>= processEND) + >>= notifyEnd where processEND = \case Just (Right clnt) - | sessId == sessionId (thParams clnt) -> do - removeSubscription c connId - notify' END - pure "END" - | otherwise -> ignored - _ -> ignored - ignored = pure "END from disconnected client - ignored" - _ -> do - logServer "<--" c srv rId $ "unexpected: " <> bshow cmd - notify . ERR $ BROKER (B.unpack $ strEncode srv) $ if isResponse then TIMEOUT else UNEXPECTED + | sessId == sessionId (thParams $ connectedClient clnt) -> + removeSubscription c connId $> True + _ -> pure False + notifyEnd removed + | removed = notify END >> logServer "<--" c srv rId "END" + | otherwise = logServer "<--" c srv rId "END from disconnected client - ignored" + SMP.ERR e -> notify $ ERR $ SMP (B.unpack $ strEncode srv) e + r -> unexpected r where - notify :: forall e m. MonadIO m => AEntityI e => ACommand 'Agent e -> m () - notify = atomically . notify' + notify :: forall e m. (AEntityI e, MonadIO m) => AEvent e -> m () + notify msg = + let t = ("", connId, AEvt (sAEntity @e) msg) + in atomically $ ifM (isFullTBQueue subQ) (modifyTVar' pendingMsgs (t :)) (writeTBQueue subQ t) - notify' :: forall e. AEntityI e => ACommand 'Agent e -> STM () - notify' msg = writeTBQueue subQ ("", connId, APC (sAEntity @e) msg) - - prohibited :: AM () - prohibited = notify . ERR $ AGENT A_PROHIBITED + prohibited :: Text -> AM () + prohibited s = do + logError $ "prohibited: " <> s + notify . ERR . AGENT $ A_PROHIBITED $ T.unpack s enqueueCmd :: InternalCommand -> AM () enqueueCmd = enqueueCommand c "" connId (Just srv) . AInternalCommand + unexpected :: BrokerMsg -> AM () + unexpected r = do + logServer "<--" c srv rId $ "unexpected: " <> bshow r + -- TODO add extended information about transmission type once UNEXPECTED has string + notify . ERR $ BROKER (B.unpack $ strEncode srv) $ UNEXPECTED (take 32 $ show r) + decryptClientMessage :: C.DhSecretX25519 -> SMP.ClientMsgEnvelope -> AM (SMP.PrivHeader, AgentMsgEnvelope) decryptClientMessage e2eDh SMP.ClientMsgEnvelope {cmNonce, cmEncBody} = do clientMsg <- agentCbDecrypt e2eDh cmNonce cmEncBody @@ -2242,25 +2448,25 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, -- aVRange <- asks $ smpAgentVRange . config -- if agentVersion agentEnvelope `isCompatible` aVRange -- then pure (privHeader, agentEnvelope) - -- else throwError $ AGENT A_VERSION + -- else throwE $ AGENT A_VERSION pure (privHeader, agentEnvelope) parseMessage :: Encoding a => ByteString -> AM a parseMessage = liftEither . parse smpP (AGENT A_MESSAGE) - smpConfirmation :: SMP.MsgId -> Connection c -> C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM () + smpConfirmation :: SMP.MsgId -> Connection c -> Maybe C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM () smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config let ConnData {pqSupport} = toConnData conn' unless (agentVersion `isCompatible` smpAgentVRange && smpClientVersion `isCompatible` smpClientVRange) - (throwError $ AGENT A_VERSION) + (throwE $ AGENT A_VERSION) case status of New -> case (conn', e2eEncryption) of -- party initiating connection (RcvConnection _ _, Just (CR.AE2ERatchetParams _ e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _ _))) -> do - unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION) + unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwE $ AGENT A_VERSION) (pk1, rcDHRs, pKem) <- withStore c (`getRatchetX3dhKeys` connId) rcParams <- liftError cryptoError $ CR.pqX3dhRcv pk1 rcDHRs pKem e2eSndParams let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion e2eEncryptVRange} @@ -2271,9 +2477,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, case (agentMsgBody_, skipped) of (Right agentMsgBody, CR.SMDNoChange) -> parseMessage agentMsgBody >>= \case - AgentConnInfoReply smpQueues connInfo -> + AgentConnInfoReply smpQueues connInfo -> do processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion} - _ -> prohibited -- including AgentConnInfo, that is prohibited here in v2 + withStore' c $ \db -> updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) + _ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2 where processConf connInfo senderConf = do let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'} @@ -2283,32 +2490,41 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, createConfirmation db g newConfirmation let srvs = map qServer $ smpReplyQueues senderConf notify $ CONF confId pqSupport' srvs connInfo - _ -> prohibited + _ -> prohibited "conf: decrypt error or skipped" -- party accepting connection - (DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do + (DuplexConnection _ (rq'@RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do g <- asks random - withStore c (\db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo) >>= parseMessage . fst >>= \case + (agentMsgBody, pqEncryption) <- withStore c $ \db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo + parseMessage agentMsgBody >>= \case AgentConnInfo connInfo -> do notify $ INFO pqSupport connInfo let dhSecret = C.dh' e2ePubKey e2ePrivKey - withStore' c $ \db -> setRcvQueueConfirmedE2E db rq dhSecret $ min v' smpClientVersion - enqueueCmd $ ICDuplexSecure rId senderKey - _ -> prohibited - _ -> prohibited - _ -> prohibited + withStore' c $ \db -> do + setRcvQueueConfirmedE2E db rq dhSecret $ min v' smpClientVersion + updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) + case senderKey of + Just k -> enqueueCmd $ ICDuplexSecure rId k + Nothing -> do + notify $ CON pqEncryption + withStore' c $ \db -> setRcvQueueStatus db rq' Active + _ -> prohibited "conf: not AgentConnInfo" + _ -> prohibited "conf: incorrect state" + _ -> prohibited "conf: status /= new" helloMsg :: SMP.MsgId -> MsgMeta -> Connection c -> AM () helloMsg srvMsgId MsgMeta {pqEncryption} conn' = do logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId case status of - Active -> prohibited + Active -> prohibited "hello: active" _ -> case conn' of DuplexConnection _ _ (sq@SndQueue {status = sndStatus} :| _) -- `sndStatus == Active` when HELLO was previously sent, and this is the reply HELLO -- this branch is executed by the accepting party in duplexHandshake mode (v2) -- (was executed by initiating party in v1 that is no longer supported) - | sndStatus == Active -> notify $ CON pqEncryption + | sndStatus == Active -> do + atomically $ incSMPServerStat c userId srv connCompleted + notify $ CON pqEncryption | otherwise -> enqueueDuplexHello sq _ -> pure () where @@ -2343,7 +2559,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, let sndMsgId = InternalSndId agentMsgId SndMsg {internalId = InternalId msgId, msgType, internalHash, msgReceipt} <- withStore c $ \db -> getSndMsgViaRcpt db connId sndMsgId if msgType /= AM_A_MSG_ - then notify (ERR $ AGENT A_PROHIBITED) $> Nothing -- unexpected message type for receipt + then prohibited "receipt: not a msg" $> Nothing else case msgReceipt of Just MsgReceipt {msgRcptStatus = MROk} -> pure Nothing -- already notified with MROk status _ -> do @@ -2356,7 +2572,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, qAddMsg :: SMP.MsgId -> NonEmpty (SMPQueueUri, Maybe SndQAddr) -> Connection 'CDuplex -> AM () qAddMsg _ ((_, Nothing) :| _) _ = qError "adding queue without switching is not supported" qAddMsg srvMsgId ((qUri, Just addr) :| _) (DuplexConnection cData' rqs sqs) = do - when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized") + when (ratchetSyncSendProhibited cData') $ throwE $ AGENT (A_QUEUE "ratchet is not synchronized") clientVRange <- asks $ smpClientVRange . config case qUri `compatibleVersion` clientVRange of Just qInfo@(Compatible sqInfo@SMPQueueInfo {queueAddress}) -> @@ -2366,31 +2582,27 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, let (delSqs, keepSqs) = L.partition ((Just dbQueueId ==) . dbReplaceQId) sqs case L.nonEmpty keepSqs of Just sqs' -> do - -- move inside case? - sq_@SndQueue {sndPublicKey, e2ePubKey} <- lift $ newSndQueue userId connId qInfo + (sq_@SndQueue {sndPublicKey}, dhPublicKey) <- lift $ newSndQueue userId connId qInfo sq2 <- withStore c $ \db -> do liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} - case (sndPublicKey, e2ePubKey) of - (Just sndPubKey, Just dhPublicKey) -> do - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress) - let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}} - void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)] - sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY - let sqs'' = updatedQs sq1 sqs' <> [sq2] - conn' = DuplexConnection cData' rqs sqs'' - notify . SWITCH QDSnd SPStarted $ connectionStats conn' - _ -> qError "absent sender keys" + logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress) + let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}} + void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPublicKey)] + sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY + let sqs'' = updatedQs sq1 sqs' <> [sq2] + conn' = DuplexConnection cData' rqs sqs'' + notify . SWITCH QDSnd SPStarted $ connectionStats conn' _ -> qError "QADD: won't delete all snd queues in connection" _ -> qError "QADD: replaced queue address is not found in connection" - _ -> throwError $ AGENT A_VERSION + _ -> throwE $ AGENT A_VERSION -- processed by queue recipient qKeyMsg :: SMP.MsgId -> NonEmpty (SMPQueueInfo, SndPublicAuthKey) -> Connection 'CDuplex -> AM () qKeyMsg srvMsgId ((qInfo, senderKey) :| _) conn'@(DuplexConnection cData' rqs _) = do - when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized") + when (ratchetSyncSendProhibited cData') $ throwE $ AGENT (A_QUEUE "ratchet is not synchronized") clientVRange <- asks $ smpClientVRange . config - unless (qInfo `isCompatible` clientVRange) . throwError $ AGENT A_VERSION + unless (qInfo `isCompatible` clientVRange) . throwE $ AGENT A_VERSION case findRQ (smpServer, senderId) rqs of Just rq'@RcvQueue {rcvId, e2ePrivKey = dhPrivKey, smpClientVersion = cVer, status = status'} | status' == New || status' == Confirmed -> do @@ -2410,7 +2622,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, qUseMsg :: SMP.MsgId -> NonEmpty ((SMPServer, SMP.SenderId), Bool) -> Connection 'CDuplex -> AM () -- NOTE: does not yet support the change of the primary status during the rotation qUseMsg srvMsgId ((addr, _primary) :| _) (DuplexConnection cData' rqs sqs) = do - when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized") + when (ratchetSyncSendProhibited cData') $ throwE $ AGENT (A_QUEUE "ratchet is not synchronized") case findQ addr sqs of Just sq'@SndQueue {dbReplaceQueueId = Just replaceQId} -> do case find ((replaceQId ==) . dbQId) sqs of @@ -2429,7 +2641,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, _ -> qError "QUSE: switched queue address not found in connection" qError :: String -> AM a - qError = throwError . AGENT . A_QUEUE + qError = throwE . AGENT . A_QUEUE ereadyMsg :: CR.RatchetX448 -> Connection 'CDuplex -> AM () ereadyMsg rcPrev (DuplexConnection cData'@ConnData {lastExternalSndId} _ sqs) = do @@ -2451,7 +2663,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, invId <- withStore c $ \db -> createInvitation db g newInv let srvs = L.map qServer $ crSmpQueues crData notify $ REQ invId pqSupport srvs cInfo - _ -> prohibited + _ -> prohibited "inv: sent to message conn" where pqSupported (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible agentVersion) = PQSupportOn `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just v) @@ -2465,7 +2677,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, newRatchetKey e2eOtherPartyParams@(CR.E2ERatchetParams e2eVersion k1Rcv k2Rcv _) conn'@(DuplexConnection cData'@ConnData {lastExternalSndId, pqSupport} _ sqs) = unlessM ratchetExists $ do AgentConfig {e2eEncryptVRange} <- asks config - unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION) + unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwE $ AGENT A_VERSION) keys <- getSendRatchetKeys let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion e2eEncryptVRange} initRatchet rcVs keys @@ -2490,7 +2702,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, -- can communicate for other client to reset to RSRequired -- - need to add new AgentMsgEnvelope, AgentMessage, AgentMessageType -- - need to deduplicate on receiving side - throwError $ AGENT (A_CRYPTO RATCHET_SYNC) + throwE $ AGENT (A_CRYPTO RATCHET_SYNC) where sendReplyKey = do g <- asks random @@ -2545,40 +2757,55 @@ checkSQSwchStatus sq@SndQueue {sndSwchStatus} expected = switchStatusError :: (SMPQueueRec q, Show a) => q -> a -> Maybe a -> AM () switchStatusError q expected actual = - throwError . INTERNAL $ + throwE . INTERNAL $ ("unexpected switch status, queueId=" <> show (queueId q)) <> (", expected=" <> show expected) <> (", actual=" <> show actual) -connectReplyQueues :: AgentClient -> ConnData -> ConnInfo -> NonEmpty SMPQueueInfo -> AM () -connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) = do +connectReplyQueues :: AgentClient -> ConnData -> ConnInfo -> Maybe SndQueue -> NonEmpty SMPQueueInfo -> AM () +connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _) = do clientVRange <- asks $ smpClientVRange . config case qInfo `proveCompatible` clientVRange of - Nothing -> throwError $ AGENT A_VERSION + Nothing -> throwE $ AGENT A_VERSION Just qInfo' -> do - sq <- lift $ newSndQueue userId connId qInfo' - sq' <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq + -- in case of SKEY retry the connection is already duplex + sq' <- maybe upgradeConn pure sq_ + agentSecureSndQueue c sq' enqueueConfirmation c cData sq' ownConnInfo Nothing + where + upgradeConn = do + (sq, _) <- lift $ newSndQueue userId connId qInfo' + withStore c $ \db -> upgradeRcvConnToDuplex db connId sq -confirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () -confirmQueueAsync c cData sq srv connInfo e2eEncryption_ subMode = do +secureConfirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () +secureConfirmQueueAsync c cData sq srv connInfo e2eEncryption_ subMode = do + agentSecureSndQueue c sq storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation c cData sq srv connInfo subMode lift $ submitPendingMsg c cData sq -confirmQueue :: Compatible VersionSMPA -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () -confirmQueue (Compatible agentVersion) c cData@ConnData {connId, pqSupport} sq srv connInfo e2eEncryption_ subMode = do +secureConfirmQueue :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () +secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv connInfo e2eEncryption_ subMode = do + agentSecureSndQueue c sq msg <- mkConfirmation =<< mkAgentConfirmation c cData sq srv connInfo subMode - sendConfirmation c sq msg + void $ sendConfirmation c sq msg withStore' c $ \db -> setSndQueueStatus db sq Confirmed where mkConfirmation :: AgentMessage -> AM MsgBody mkConfirmation aMessage = do currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config withStore c $ \db -> runExceptT $ do - void . liftIO $ updateSndIds db connId + let agentMsgBody = smpEncode aMessage + (_, internalSndId, _) <- liftIO $ updateSndIds db connId + liftIO $ updateSndMsgHash db connId internalSndId (C.sha256Hash agentMsgBody) let pqEnc = CR.pqSupportToEnc pqSupport - (encConnInfo, _) <- agentRatchetEncrypt db cData (smpEncode aMessage) e2eEncConnInfoLength (Just pqEnc) currentE2EVersion - pure . smpEncode $ AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo} + (encConnInfo, _) <- agentRatchetEncrypt db cData agentMsgBody e2eEncConnInfoLength (Just pqEnc) currentE2EVersion + pure . smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption_, encConnInfo} + +agentSecureSndQueue :: AgentClient -> SndQueue -> AM () +agentSecureSndQueue c sq@SndQueue {sndSecure, status} = + when (sndSecure && status == New) $ do + secureSndQueue c sq + withStore' c $ \db -> setSndQueueStatus db sq Secured mkAgentConfirmation :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM AgentMessage mkAgentConfirmation c cData sq srv connInfo subMode = do @@ -2655,26 +2882,28 @@ agentRatchetDecrypt' g db connId rc encAgentMsg = do liftIO $ updateRatchet db connId rc' skippedDiff liftEither $ bimap (SEAgentError . cryptoError) (,CR.rcRcvKEM rc') agentMsgBody_ -newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> AM' NewSndQueue -newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do +newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> AM' (NewSndQueue, C.PublicKeyX25519) +newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, sndSecure, dhPublicKey = rcvE2ePubDhKey})) = do C.AuthAlg a <- asks $ sndAuthAlg . config g <- asks random (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair a g (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g - pure - SndQueue - { userId, - connId, - server = smpServer, - sndId = senderId, - sndPublicKey = Just sndPublicKey, - sndPrivateKey, - e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey, - e2ePubKey = Just e2ePubKey, - status = New, - dbQueueId = DBNewQueue, - primary = True, - dbReplaceQueueId = Nothing, - sndSwchStatus = Nothing, - smpClientVersion - } + let sq = + SndQueue + { userId, + connId, + server = smpServer, + sndId = senderId, + sndSecure, + sndPublicKey, + sndPrivateKey, + e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey, + e2ePubKey = Just e2ePubKey, + status = New, + dbQueueId = DBNewQueue, + primary = True, + dbReplaceQueueId = Nothing, + sndSwchStatus = Nothing, + smpClientVersion + } + pure (sq, e2ePubKey) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 27223b12f..43b3b8064 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -28,9 +29,11 @@ module Simplex.Messaging.Agent.Client withConnLocks, withInvLock, withLockMap, + ipAddressProtected, closeAgentClient, closeProtocolServerClients, reconnectServerClients, + reconnectSMPServer, closeXFTPServerClient, runSMPServerTest, runXFTPServerTest, @@ -41,17 +44,22 @@ module Simplex.Messaging.Agent.Client getQueueMessage, decryptSMPMessage, addSubscription, + failSubscription, + addNewQueueSubscription, getSubscriptions, sendConfirmation, sendInvitation, temporaryAgentError, temporaryOrHostError, + serverHostError, secureQueue, + secureSndQueue, enableQueueNotifications, enableQueuesNtfs, disableQueueNotifications, disableQueuesNtfs, sendAgentMessage, + getQueueInfo, agentNtfRegisterToken, agentNtfVerifyToken, agentNtfCheckToken, @@ -66,7 +74,6 @@ module Simplex.Messaging.Agent.Client agentXFTPUploadChunk, agentXFTPAddRecipients, agentXFTPDeleteChunk, - agentCbEncrypt, agentCbDecrypt, cryptoError, sendAck, @@ -77,11 +84,19 @@ module Simplex.Messaging.Agent.Client logSecret, removeSubscription, hasActiveSubscription, + hasPendingSubscription, hasGetLock, + activeClientSession, agentClientStore, agentDRG, + ServerQueueInfo (..), + AgentServersSummary (..), + ServerSessions (..), + SMPServerSubs (..), + getAgentServersSummary, getAgentSubscriptions, slowNetworkConfig, + protocolClientError, Worker (..), SessionVar (..), SubscriptionsInfo (..), @@ -90,7 +105,6 @@ module Simplex.Messaging.Agent.Client AgentOpState (..), AgentState (..), AgentLocks (..), - AgentStatsKey (..), getAgentWorker, getAgentWorker', cancelWorker, @@ -103,9 +117,10 @@ module Simplex.Messaging.Agent.Client waitUntilActive, UserNetworkInfo (..), UserNetworkType (..), - UserNetworkState (..), - UNSOffline (..), + getNetworkConfig', waitForUserNetwork, + isNetworkOnline, + isOnline, throwWhenInactive, throwWhenNoDelivery, beginAgentOperation, @@ -125,18 +140,27 @@ module Simplex.Messaging.Agent.Client getNextServer, withUserServers, withNextSrv, + incSMPServerStat, + incSMPServerStat', + incXFTPServerStat, + incXFTPServerStat', + incXFTPServerSizeStat, AgentWorkersDetails (..), getAgentWorkersDetails, AgentWorkersSummary (..), getAgentWorkersSummary, + AgentQueuesInfo (..), + getAgentQueuesInfo, SMPTransportSession, NtfTransportSession, XFTPTransportSession, + ProxiedRelay (..), + SMPConnectedClient (..), ) where import Control.Applicative ((<|>)) -import Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.Async (Async, uninterruptibleCancel) import Control.Concurrent.STM (retry, throwSTM) import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..)) @@ -145,14 +169,15 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader +import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J import qualified Data.Aeson.TH as J import Data.Bifunctor (bimap, first, second) -import Data.ByteString.Base64 +import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Either (lefts, partitionEithers) +import Data.Either (isRight, partitionEithers) import Data.Functor (($>)) import Data.Int (Int64) import Data.List (deleteFirstsBy, foldl', partition, (\\)) @@ -160,33 +185,35 @@ import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (isJust, isNothing, listToMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe) import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import Data.Text.Encoding -import Data.Time (UTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime) +import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime) import Data.Time.Clock.System (getSystemTime) import Data.Word (Word16) +import qualified Database.SQLite.Simple as SQL import Network.Socket (HostName) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError) import qualified Simplex.FileTransfer.Client as X import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb) import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse) import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion) +import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..)) import Simplex.FileTransfer.Util (uniqueCombine) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval +import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), withTransaction) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues (getRcvQueues)) import qualified Simplex.Messaging.Agent.TRcvQueues as RQ import Simplex.Messaging.Client -import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -194,7 +221,7 @@ import Simplex.Messaging.Notifications.Client import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Transport (NTFVersion) import Simplex.Messaging.Notifications.Types -import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse, sumTypeJSON) import Simplex.Messaging.Protocol ( AProtocolType (..), BrokerMsg, @@ -209,6 +236,7 @@ import Simplex.Messaging.Protocol ProtoServerWithAuth (..), Protocol (..), ProtocolServer (..), + ProtocolType (..), ProtocolTypeI (..), QueueId, QueueIdsKeys (..), @@ -216,6 +244,7 @@ import Simplex.Messaging.Protocol RcvNtfPublicDhKey, SMPMsgMeta (..), SProtocolType (..), + SenderCanSecure, SndPublicAuthKey, SubscriptionMode (..), UserProtocol, @@ -226,11 +255,12 @@ import Simplex.Messaging.Protocol sameSrvAddr', ) import qualified Simplex.Messaging.Protocol as SMP +import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Session import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (SMPVersion) -import Simplex.Messaging.Transport.Client (TransportHost) +import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId), TransportError (..)) +import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Util import Simplex.Messaging.Version import System.Mem.Weak (Weak) @@ -241,7 +271,7 @@ import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, removeFile) import qualified UnliftIO.Exception as E import UnliftIO.STM -type ClientVar msg = SessionVar (Either AgentErrorType (Client msg)) +type ClientVar msg = SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)) type SMPClientVar = ClientVar SMP.BrokerMsg @@ -258,17 +288,21 @@ type XFTPTransportSession = TransportSession FileResponse data AgentClient = AgentClient { acThread :: TVar (Maybe (Weak ThreadId)), active :: TVar Bool, - rcvQ :: TBQueue (ATransmission 'Client), - subQ :: TBQueue (ATransmission 'Agent), - msgQ :: TBQueue (ServerTransmission SMPVersion BrokerMsg), - smpServers :: TMap UserId (NonEmpty SMPServerWithAuth), + subQ :: TBQueue ATransmission, + msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg), + smpServers :: TMap UserId (UserServers 'PSMP), smpClients :: TMap SMPTransportSession SMPClientVar, + -- smpProxiedRelays: + -- SMPTransportSession defines connection from proxy to relay, + -- SMPServerWithAuth defines client connected to SMP proxy (with the same userId and entityId in TransportSession) + smpProxiedRelays :: TMap SMPTransportSession SMPServerWithAuth, ntfServers :: TVar [NtfServer], ntfClients :: TMap NtfTransportSession NtfClientVar, - xftpServers :: TMap UserId (NonEmpty XFTPServerWithAuth), + xftpServers :: TMap UserId (UserServers 'PXFTP), xftpClients :: TMap XFTPTransportSession XFTPClientVar, useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks - userNetworkState :: TVar UserNetworkState, + userNetworkInfo :: TVar UserNetworkInfo, + userNetworkUpdated :: TVar (Maybe UTCTime), subscrConns :: TVar (Set ConnId), activeSubs :: TRcvQueues, pendingSubs :: TRcvQueues, @@ -292,11 +326,20 @@ data AgentClient = AgentClient deleteLock :: Lock, -- smpSubWorkers for SMP servers sessions smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ())), - agentStats :: TMap AgentStatsKey (TVar Int), clientId :: Int, - agentEnv :: Env + agentEnv :: Env, + smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats, + xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats, + srvStatsStartedAt :: TVar UTCTime } +data SMPConnectedClient = SMPConnectedClient + { connectedClient :: SMPClient, + proxiedRelays :: TMap SMPServer ProxiedRelayVar + } + +type ProxiedRelayVar = SessionVar (Either AgentErrorType ProxiedRelay) + getAgentWorker :: (Ord k, Show k) => String -> Bool -> AgentClient -> k -> TMap k Worker -> (Worker -> AM ()) -> AM' Worker getAgentWorker = getAgentWorker' id pure {-# INLINE getAgentWorker #-} @@ -345,7 +388,7 @@ getAgentWorker' toW fromW name hasWork c key ws work = do notifyErr err = do let e = either ((", error: " <>) . show) (\_ -> ", no error") e_ msg = "Worker " <> name <> " for " <> show key <> " terminated " <> show (restartCount rc) <> " times" <> e - writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ err msg) + writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err msg) newWorker :: AgentClient -> STM Worker newWorker c = do @@ -390,50 +433,40 @@ data AgentLocks = AgentLocks } deriving (Show) -data AgentStatsKey = AgentStatsKey - { userId :: UserId, - host :: ByteString, - clientTs :: ByteString, - cmd :: ByteString, - res :: ByteString - } - deriving (Eq, Ord, Show) - data UserNetworkInfo = UserNetworkInfo { networkType :: UserNetworkType, online :: Bool } deriving (Show) +isNetworkOnline :: AgentClient -> STM Bool +isNetworkOnline c = isOnline <$> readTVar (userNetworkInfo c) + +isOnline :: UserNetworkInfo -> Bool +isOnline UserNetworkInfo {networkType, online} = networkType /= UNNone && online + data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther deriving (Eq, Show) -data UserNetworkState = UserNetworkState - { networkType :: UserNetworkType, - offline :: Maybe UNSOffline - } - deriving (Show) - -data UNSOffline = UNSOffline {offlineDelay :: Int64, offlineFrom :: UTCTime} - deriving (Show) - -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's. -newAgentClient :: Int -> InitialAgentServers -> Env -> STM AgentClient -newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do - let qSize = tbqSize $ config agentEnv +newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Env -> STM AgentClient +newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs agentEnv = do + let cfg = config agentEnv + qSize = tbqSize cfg acThread <- newTVar Nothing active <- newTVar True - rcvQ <- newTBQueue qSize subQ <- newTBQueue qSize msgQ <- newTBQueue qSize - smpServers <- newTVar smp + smpServers <- newTVar $ M.map mkUserServers smp smpClients <- TM.empty + smpProxiedRelays <- TM.empty ntfServers <- newTVar ntf ntfClients <- TM.empty - xftpServers <- newTVar xftp + xftpServers <- newTVar $ M.map mkUserServers xftp xftpClients <- TM.empty useNetworkConfig <- newTVar (slowNetworkConfig netCfg, netCfg) - userNetworkState <- newTVar $ UserNetworkState UNOther Nothing + userNetworkInfo <- newTVar $ UserNetworkInfo UNOther True + userNetworkUpdated <- newTVar Nothing subscrConns <- newTVar S.empty activeSubs <- RQ.empty pendingSubs <- RQ.empty @@ -453,22 +486,25 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = invLocks <- TM.empty deleteLock <- createLock smpSubWorkers <- TM.empty - agentStats <- TM.empty + smpServersStats <- TM.empty + xftpServersStats <- TM.empty + srvStatsStartedAt <- newTVar currentTs return AgentClient { acThread, active, - rcvQ, subQ, msgQ, smpServers, smpClients, + smpProxiedRelays, ntfServers, ntfClients, xftpServers, xftpClients, useNetworkConfig, - userNetworkState, + userNetworkInfo, + userNetworkUpdated, subscrConns, activeSubs, pendingSubs, @@ -488,9 +524,11 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = invLocks, deleteLock, smpSubWorkers, - agentStats, clientId, - agentEnv + agentEnv, + smpServersStats, + xftpServersStats, + srvStatsStartedAt } slowNetworkConfig :: NetworkConfig -> NetworkConfig @@ -511,109 +549,171 @@ agentDRG AgentClient {agentEnv = Env {random}} = random class (Encoding err, Show err) => ProtocolServerClient v err msg | msg -> v, msg -> err where type Client msg = c | c -> msg getProtocolServerClient :: AgentClient -> TransportSession msg -> AM (Client msg) - clientProtocolError :: err -> AgentErrorType - closeProtocolServerClient :: Client msg -> IO () - clientServer :: Client msg -> String - clientTransportHost :: Client msg -> TransportHost - clientSessionTs :: Client msg -> UTCTime + type ProtoClient msg = c | c -> msg + protocolClient :: Client msg -> ProtoClient msg + clientProtocolError :: HostName -> err -> AgentErrorType + closeProtocolServerClient :: ProtoClient msg -> IO () + clientServer :: ProtoClient msg -> String + clientTransportHost :: ProtoClient msg -> TransportHost instance ProtocolServerClient SMPVersion ErrorType BrokerMsg where - type Client BrokerMsg = ProtocolClient SMPVersion ErrorType BrokerMsg + type Client BrokerMsg = SMPConnectedClient getProtocolServerClient = getSMPServerClient + type ProtoClient BrokerMsg = ProtocolClient SMPVersion ErrorType BrokerMsg + protocolClient = connectedClient clientProtocolError = SMP closeProtocolServerClient = closeProtocolClient clientServer = protocolClientServer clientTransportHost = transportHost' - clientSessionTs = sessionTs instance ProtocolServerClient NTFVersion ErrorType NtfResponse where type Client NtfResponse = ProtocolClient NTFVersion ErrorType NtfResponse getProtocolServerClient = getNtfServerClient + type ProtoClient NtfResponse = ProtocolClient NTFVersion ErrorType NtfResponse + protocolClient = id clientProtocolError = NTF closeProtocolServerClient = closeProtocolClient clientServer = protocolClientServer clientTransportHost = transportHost' - clientSessionTs = sessionTs instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where type Client FileResponse = XFTPClient getProtocolServerClient = getXFTPServerClient + type ProtoClient FileResponse = XFTPClient + protocolClient = id clientProtocolError = XFTP closeProtocolServerClient = X.closeXFTPClient clientServer = X.xftpClientServer clientTransportHost = X.xftpTransportHost - clientSessionTs = X.xftpSessionTs -getSMPServerClient :: AgentClient -> SMPTransportSession -> AM SMPClient -getSMPServerClient c@AgentClient {active, smpClients, msgQ, workerSeq} tSess@(userId, srv, _) = do - unlessM (readTVarIO active) . throwError $ INACTIVE - atomically (getSessVar workerSeq tSess smpClients) - >>= either newClient (waitForProtocolClient c tSess) +getSMPServerClient :: AgentClient -> SMPTransportSession -> AM SMPConnectedClient +getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do + unlessM (readTVarIO active) $ throwE INACTIVE + ts <- liftIO getCurrentTime + atomically (getSessVar workerSeq tSess smpClients ts) + >>= either newClient (waitForProtocolClient c tSess smpClients) where - -- we resubscribe only on newClient error, but not on waitForProtocolClient error, - -- as the large number of delivery workers waiting for the client TMVar - -- make it expensive to check for pending subscriptions. - newClient v = - newProtocolClient c tSess smpClients connectClient v - `catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwError e - connectClient :: SMPClientVar -> AM SMPClient - connectClient v = do + newClient v = do + prs <- atomically TM.empty + smpConnectClient c tSess prs v + +getSMPProxyClient :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay) +getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} proxySrv_ destSess@(userId, destSrv, qId) = do + unlessM (readTVarIO active) $ throwE INACTIVE + proxySrv <- maybe (getNextServer c userId [destSrv]) pure proxySrv_ + ts <- liftIO getCurrentTime + atomically (getClientVar proxySrv ts) >>= \(tSess, auth, v) -> + either (newProxyClient tSess auth ts) (waitForProxyClient tSess auth) v + where + getClientVar :: SMPServerWithAuth -> UTCTime -> STM (SMPTransportSession, Maybe SMP.BasicAuth, Either SMPClientVar SMPClientVar) + getClientVar proxySrv ts = do + ProtoServerWithAuth srv auth <- TM.lookup destSess smpProxiedRelays >>= maybe (TM.insert destSess proxySrv smpProxiedRelays $> proxySrv) pure + let tSess = (userId, srv, qId) + (tSess,auth,) <$> getSessVar workerSeq tSess smpClients ts + newProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> UTCTime -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay) + newProxyClient tSess auth ts v = do + (prs, rv) <- atomically $ do + prs <- TM.empty + -- we do not need to check if it is a new proxied relay session, + -- as the client is just created and there are no sessions yet + (prs,) . either id id <$> getSessVar workerSeq destSrv prs ts + clnt <- smpConnectClient c tSess prs v + (clnt,) <$> newProxiedRelay clnt auth rv + waitForProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay) + waitForProxyClient tSess auth v = do + clnt@(SMPConnectedClient _ prs) <- waitForProtocolClient c tSess smpClients v + ts <- liftIO getCurrentTime + sess <- + atomically (getSessVar workerSeq destSrv prs ts) + >>= either (newProxiedRelay clnt auth) (waitForProxiedRelay tSess) + pure (clnt, sess) + newProxiedRelay :: SMPConnectedClient -> Maybe SMP.BasicAuth -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay) + newProxiedRelay (SMPConnectedClient smp prs) proxyAuth rv = + tryAgentError (liftClient SMP (clientServer smp) $ connectSMPProxiedRelay smp destSrv proxyAuth) >>= \case + Right sess -> do + atomically $ putTMVar (sessionVar rv) (Right sess) + pure $ Right sess + Left e -> do + atomically $ do + unless (serverHostError e) $ do + removeSessVar rv destSrv prs + TM.delete destSess smpProxiedRelays + putTMVar (sessionVar rv) (Left e) + pure $ Left e + waitForProxiedRelay :: SMPTransportSession -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay) + waitForProxiedRelay (_, srv, _) rv = do + NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c + sess_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar rv) + pure $ case sess_ of + Just (Right sess) -> Right sess + Just (Left e) -> Left e + Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT + +smpConnectClient :: AgentClient -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient +smpConnectClient c@AgentClient {smpClients, msgQ} tSess@(_, srv, _) prs v = + newProtocolClient c tSess smpClients connectClient v + `catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e + where + connectClient :: SMPClientVar -> AM SMPConnectedClient + connectClient v' = do cfg <- lift $ getClientConfig c smpCfg g <- asks random env <- ask - liftError' (protocolClientError SMP $ B.unpack $ strEncode srv) $ - getProtocolClient g tSess cfg (Just msgQ) $ - clientDisconnected env v + liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do + smp <- ExceptT $ getProtocolClient g tSess cfg (Just msgQ) $ smpClientDisconnected c tSess env v' prs + pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs} - clientDisconnected :: Env -> SMPClientVar -> SMPClient -> IO () - clientDisconnected env v client = do - removeClientAndSubs >>= serverDown - logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv +smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO () +smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess@(userId, srv, qId) env v prs client = do + removeClientAndSubs >>= serverDown + logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv + where + -- we make active subscriptions pending only if the client for tSess was current (in the map) and active, + -- because we can have a race condition when a new current client could have already + -- made subscriptions active, and the old client would be processing diconnection later. + removeClientAndSubs :: IO ([RcvQueue], [ConnId]) + removeClientAndSubs = atomically $ ifM currentActiveClient removeSubs $ pure ([], []) where - -- we make active subscriptions pending only if the client for tSess was current (in the map) and active, - -- because we can have a race condition when a new current client could have already - -- made subscriptions active, and the old client would be processing diconnection later. - removeClientAndSubs :: IO ([RcvQueue], [ConnId]) - removeClientAndSubs = atomically $ ifM currentActiveClient removeSubs $ pure ([], []) - where - currentActiveClient = (&&) <$> removeSessVar' v tSess smpClients <*> readTVar active - removeSubs = do - (qs, cs) <- RQ.getDelSessQueues tSess $ activeSubs c - RQ.batchAddQueues (pendingSubs c) qs - pure (qs, cs) + currentActiveClient = (&&) <$> removeSessVar' v tSess smpClients <*> readTVar active + removeSubs = do + (qs, cs) <- RQ.getDelSessQueues tSess $ activeSubs c + RQ.batchAddQueues (pendingSubs c) qs + -- this removes proxied relays that this client created sessions to + destSrvs <- M.keys <$> readTVar prs + forM_ destSrvs $ \destSrv -> TM.delete (userId, destSrv, qId) smpProxiedRelays + pure (qs, cs) - serverDown :: ([RcvQueue], [ConnId]) -> IO () - serverDown (qs, conns) = whenM (readTVarIO active) $ do - incClientStat c userId client "DISCONNECT" "" - notifySub "" $ hostEvent DISCONNECT client - unless (null conns) $ notifySub "" $ DOWN srv conns - unless (null qs) $ do - atomically $ mapM_ (releaseGetLock c) qs - runReaderT (resubscribeSMPSession c tSess) env + serverDown :: ([RcvQueue], [ConnId]) -> IO () + serverDown (qs, conns) = whenM (readTVarIO active) $ do + notifySub "" $ hostEvent' DISCONNECT client + unless (null conns) $ notifySub "" $ DOWN srv conns + unless (null qs) $ do + atomically $ mapM_ (releaseGetLock c) qs + runReaderT (resubscribeSMPSession c tSess) env - notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO () - notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd) + notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> IO () + notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd) resubscribeSMPSession :: AgentClient -> SMPTransportSession -> AM' () -resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = - atomically getWorkerVar >>= mapM_ (either newSubWorker (\_ -> pure ())) +resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do + ts <- liftIO getCurrentTime + atomically (getWorkerVar ts) >>= mapM_ (either newSubWorker (\_ -> pure ())) where - getWorkerVar = + getWorkerVar ts = ifM (null <$> getPending) (pure Nothing) -- prevent race with cleanup and adding pending queues in another call - (Just <$> getSessVar workerSeq tSess smpSubWorkers) + (Just <$> getSessVar workerSeq tSess smpSubWorkers ts) newSubWorker v = do a <- async $ void (E.tryAny runSubWorker) >> atomically (cleanup v) atomically $ putTMVar (sessionVar v) a runSubWorker = do ri <- asks $ reconnectInterval . config - timeoutCounts <- newTVarIO 0 withRetryInterval ri $ \_ loop -> do pending <- atomically getPending forM_ (L.nonEmpty pending) $ \qs -> do - waitForUserNetwork c - void . tryAgentError' $ reconnectSMPClient timeoutCounts c tSess qs + liftIO $ waitForUserNetwork c + reconnectSMPClient c tSess qs loop getPending = RQ.getSessQueues tSess $ pendingSubs c cleanup :: SessionVar (Async ()) -> STM () @@ -623,44 +723,36 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = whenM (isEmptyTMVar $ sessionVar v) retry removeSessVar v tSess smpSubWorkers -reconnectSMPClient :: TVar Int -> AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> AM () -reconnectSMPClient tc c tSess@(_, srv, _) qs = do - NetworkConfig {tcpTimeout} <- atomically $ getNetworkConfig c - -- this allows 3x of timeout per batch of subscription (90 queues per batch empirically) - let t = (length qs `div` 90 + 1) * tcpTimeout * 3 - ExceptT (sequence <$> (t `timeout` runExceptT resubscribe)) >>= \case - Just _ -> atomically $ writeTVar tc 0 - Nothing -> do - tc' <- atomically $ stateTVar tc $ \i -> (i + 1, i + 1) - maxTC <- asks $ maxSubscriptionTimeouts . config - let err = if tc' >= maxTC then CRITICAL True else INTERNAL - msg = show tc' <> " consecutive subscription timeouts: " <> show (length qs) <> " queues, transport session: " <> show tSess - atomically $ writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ err msg) +reconnectSMPClient :: AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> AM' () +reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do + cs <- readTVarIO $ RQ.getConnections $ activeSubs c + (rs, sessId_) <- subscribeQueues c $ L.toList qs + let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs + conns = filter (`M.notMember` cs) okConns + unless (null conns) $ notifySub "" $ UP srv conns + let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs + mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs + forM_ (listToMaybe tempErrs) $ \(connId, e) -> do + when (null okConns && M.null cs && null finalErrs) . liftIO $ + forM_ sessId_ $ \sessId -> do + -- We only close the client session that was used to subscribe. + v_ <- atomically $ ifM (activeClientSession c tSess sessId) (TM.lookupDelete tSess $ smpClients c) (pure Nothing) + mapM_ (closeClient_ c) v_ + notifySub connId $ ERR e where - resubscribe :: AM () - resubscribe = do - cs <- readTVarIO $ RQ.getConnections $ activeSubs c - rs <- lift . subscribeQueues c $ L.toList qs - let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs - liftIO $ do - let conns = filter (`M.notMember` cs) okConns - unless (null conns) $ notifySub "" $ UP srv conns - let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs - liftIO $ mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs - forM_ (listToMaybe tempErrs) $ \(_, err) -> do - when (null okConns && M.null cs && null finalErrs) . liftIO $ - closeClient c smpClients tSess - throwError err - notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO () - notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd) + handleNotify :: AM' () -> AM' () + handleNotify = E.handleAny $ notifySub "" . ERR . INTERNAL . show + notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> AM' () + notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd) getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient -getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId, srv, _) = do - unlessM (readTVarIO active) . throwError $ INACTIVE - atomically (getSessVar workerSeq tSess ntfClients) +getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(_, srv, _) = do + unlessM (readTVarIO active) $ throwE INACTIVE + ts <- liftIO getCurrentTime + atomically (getSessVar workerSeq tSess ntfClients ts) >>= either (newProtocolClient c tSess ntfClients connectClient) - (waitForProtocolClient c tSess) + (waitForProtocolClient c tSess ntfClients) where connectClient :: NtfClientVar -> AM NtfClient connectClient v = do @@ -673,17 +765,17 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId, clientDisconnected :: NtfClientVar -> NtfClient -> IO () clientDisconnected v client = do atomically $ removeSessVar v tSess ntfClients - incClientStat c userId client "DISCONNECT" "" - atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client) + atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient -getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId, srv, _) = do - unlessM (readTVarIO active) . throwError $ INACTIVE - atomically (getSessVar workerSeq tSess xftpClients) +getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(_, srv, _) = do + unlessM (readTVarIO active) $ throwE INACTIVE + ts <- liftIO getCurrentTime + atomically (getSessVar workerSeq tSess xftpClients ts) >>= either (newProtocolClient c tSess xftpClients connectClient) - (waitForProtocolClient c tSess) + (waitForProtocolClient c tSess xftpClients) where connectClient :: XFTPClientVar -> AM XFTPClient connectClient v = do @@ -696,18 +788,29 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId clientDisconnected :: XFTPClientVar -> XFTPClient -> IO () clientDisconnected v client = do atomically $ removeSessVar v tSess xftpClients - incClientStat c userId client "DISCONNECT" "" - atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client) + atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv -waitForProtocolClient :: ProtocolTypeI (ProtoType msg) => AgentClient -> TransportSession msg -> ClientVar msg -> AM (Client msg) -waitForProtocolClient c (_, srv, _) v = do +waitForProtocolClient :: + (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => + AgentClient -> + TransportSession msg -> + TMap (TransportSession msg) (ClientVar msg) -> + ClientVar msg -> + AM (Client msg) +waitForProtocolClient c tSess@(_, srv, _) clients v = do NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) - liftEither $ case client_ of - Just (Right smpClient) -> Right smpClient - Just (Left e) -> Left e - Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT + case client_ of + Just (Right smpClient) -> pure smpClient + Just (Left (e, ts_)) -> case ts_ of + Nothing -> throwE e + Just ts -> + ifM + ((ts <) <$> liftIO getCurrentTime) + (atomically (removeSessVar v tSess clients) >> getProtocolServerClient c tSess) + (throwE e) + Nothing -> throwE $ BROKER (B.unpack $ strEncode srv) TIMEOUT -- clientConnected arg is only passed for SMP server newProtocolClient :: @@ -724,18 +827,25 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v = Right client -> do logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")" atomically $ putTMVar (sessionVar v) (Right client) - liftIO $ incClientStat c userId client "CLIENT" "OK" - atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent CONNECT client) + atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent CONNECT client) pure client Left e -> do - liftIO $ incServerStat c userId srv "CLIENT" $ strEncode e - atomically $ do - removeSessVar v tSess clients - putTMVar (sessionVar v) (Left e) - throwError e -- signal error to caller + ei <- asks $ persistErrorInterval . config + if ei == 0 + then atomically $ do + removeSessVar v tSess clients + putTMVar (sessionVar v) (Left (e, Nothing)) + else do + ts <- addUTCTime ei <$> liftIO getCurrentTime + atomically $ putTMVar (sessionVar v) (Left (e, Just ts)) + throwE e -- signal error to caller -hostEvent :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> Client msg -> ACommand 'Agent 'AENone -hostEvent event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost +hostEvent :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> AEvent 'AENone) -> Client msg -> AEvent 'AENone +hostEvent event = hostEvent' event . protocolClient +{-# INLINE hostEvent #-} + +hostEvent' :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> AEvent 'AENone) -> ProtoClient msg -> AEvent 'AENone +hostEvent' event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost getClientConfig :: AgentClient -> (AgentConfig -> ProtocolClientConfig v) -> AM' (ProtocolClientConfig v) getClientConfig c cfgSel = do @@ -746,43 +856,22 @@ getClientConfig c cfgSel = do getNetworkConfig :: AgentClient -> STM NetworkConfig getNetworkConfig c = do (slowCfg, fastCfg) <- readTVar (useNetworkConfig c) - UserNetworkState {networkType} <- readTVar (userNetworkState c) + UserNetworkInfo {networkType} <- readTVar $ userNetworkInfo c pure $ case networkType of UNCellular -> slowCfg UNNone -> slowCfg _ -> fastCfg -waitForUserNetwork :: AgentClient -> AM' () -waitForUserNetwork AgentClient {userNetworkState} = - readTVarIO userNetworkState >>= mapM_ waitWhileOffline . offline - where - waitWhileOffline UNSOffline {offlineDelay = d} = - unlessM (liftIO $ waitOnline d False) $ do - -- network delay reached, increase delay - ts' <- liftIO getCurrentTime - ni <- asks $ userNetworkInterval . config - atomically $ do - ns@UserNetworkState {offline} <- readTVar userNetworkState - forM_ offline $ \UNSOffline {offlineDelay = d', offlineFrom = ts} -> - -- Using `min` to avoid multiple updates in a short period of time - -- and to reset `offlineDelay` if network went `on` and `off` again. - writeTVar userNetworkState $! - let d'' = nextRetryDelay (diffToMicroseconds $ diffUTCTime ts' ts) (min d d') ni - in ns {offline = Just UNSOffline {offlineDelay = d'', offlineFrom = ts}} - waitOnline :: Int64 -> Bool -> IO Bool - waitOnline t online' - | t <= 0 = pure online' - | otherwise = - registerDelay (fromIntegral maxWait) - >>= atomically . onlineOrDelay - >>= waitOnline (t - maxWait) - where - maxWait = min t $ fromIntegral (maxBound :: Int) - onlineOrDelay delay = do - online <- isNothing . offline <$> readTVar userNetworkState - expired <- readTVar delay - unless (online || expired) retry - pure online +-- returns fast network config +getNetworkConfig' :: AgentClient -> IO NetworkConfig +getNetworkConfig' = fmap snd . readTVarIO . useNetworkConfig +{-# INLINE getNetworkConfig' #-} + +waitForUserNetwork :: AgentClient -> IO () +waitForUserNetwork c = + unlessM (atomically $ isNetworkOnline c) $ do + delay <- registerDelay $ userNetworkInterval $ config $ agentEnv c + atomically $ unlessM (isNetworkOnline c) $ unlessM (readTVar delay) retry closeAgentClient :: AgentClient -> IO () closeAgentClient c = do @@ -790,6 +879,7 @@ closeAgentClient c = do closeProtocolServerClients c smpClients closeProtocolServerClients c ntfClients closeProtocolServerClients c xftpClients + atomically $ writeTVar (smpProxiedRelays c) M.empty atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect clearWorkers smpDeliveryWorkers >>= mapM_ (cancelWorker . fst) clearWorkers asyncCmdWorkers >>= mapM_ cancelWorker @@ -833,6 +923,16 @@ reconnectServerClients :: ProtocolServerClient v err msg => AgentClient -> (Agen reconnectServerClients c clientsSel = readTVarIO (clientsSel c) >>= mapM_ (forkIO . closeClient_ c) +reconnectSMPServer :: AgentClient -> UserId -> SMPServer -> IO () +reconnectSMPServer c userId srv = do + cs <- readTVarIO $ smpClients c + let vs = M.foldrWithKey srvClient [] cs + mapM_ (forkIO . closeClient_ c) vs + where + srvClient (userId', srv', _) v + | userId == userId' && srv == srv' = (v :) + | otherwise = id + closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO () closeClient c clientSel tSess = atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c) @@ -842,7 +942,7 @@ closeClient_ c v = do NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c E.handle (\BlockedIndefinitelyOnSTM -> pure ()) $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case - Just (Right client) -> closeProtocolServerClient client `catchAll_` pure () + Just (Right client) -> closeProtocolServerClient (protocolClient client) `catchAll_` pure () _ -> pure () closeXFTPServerClient :: AgentClient -> UserId -> XFTPServer -> FileDigest -> IO () @@ -866,15 +966,15 @@ withInvLock' :: AgentClient -> ByteString -> String -> AM' a -> AM' a withInvLock' AgentClient {invLocks} = withLockMap invLocks {-# INLINE withInvLock' #-} -withConnLocks :: AgentClient -> [ConnId] -> String -> AM' a -> AM' a -withConnLocks AgentClient {connLocks} = withLocksMap_ connLocks . filter (not . B.null) +withConnLocks :: AgentClient -> Set ConnId -> String -> AM' a -> AM' a +withConnLocks AgentClient {connLocks} = withLocksMap_ connLocks {-# INLINE withConnLocks #-} withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a withLockMap = withGetLock . getMapLock {-# INLINE withLockMap #-} -withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> [k] -> String -> m a -> m a +withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> String -> m a -> m a withLocksMap_ = withGetLocks . getMapLock {-# INLINE withLocksMap_ #-} @@ -883,42 +983,153 @@ getMapLock locks key = TM.lookup key locks >>= maybe newLock pure where newLock = createLock >>= \l -> TM.insert key l locks $> l -withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> AM a) -> AM a -withClient_ c tSess@(userId, srv, _) statCmd action = do +withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> AM a) -> AM a +withClient_ c tSess@(_, srv, _) action = do cl <- getProtocolServerClient c tSess - (action cl <* stat cl "OK") `catchAgentError` logServerError cl + action cl `catchAgentError` logServerError where - stat cl = liftIO . incClientStat c userId cl statCmd - logServerError :: Client msg -> AgentErrorType -> AM a + logServerError :: AgentErrorType -> AM a + logServerError e = do + logServer "<--" c srv "" $ bshow e + throwE e + +withProxySession :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a +withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do + (cl, sess_) <- getSMPProxyClient c proxySrv_ destSess + logServer ("--> " <> proxySrv cl <> " >") c destSrv entId cmdStr + case sess_ of + Right sess -> do + r <- action (cl, sess) `catchAgentError` logServerError cl + logServer ("<-- " <> proxySrv cl <> " <") c destSrv entId "OK" + pure r + Left e -> logServerError cl e + where + proxySrv = showServer . protocolClientServer' . protocolClient + logServerError :: SMPConnectedClient -> AgentErrorType -> AM a logServerError cl e = do - logServer "<--" c srv "" $ strEncode e - stat cl $ strEncode e - throwError e + logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ bshow e + throwE e withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> AM a) -> AM a withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do logServer "-->" c srv entId cmdStr - res <- withClient_ c tSess cmdStr action + res <- withClient_ c tSess action logServer "<--" c srv entId "OK" return res -withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a -withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer client) $ action client +withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a +withClient c tSess action = withClient_ c tSess $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client {-# INLINE withClient #-} withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a -withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer client) $ action client +withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client {-# INLINE withLogClient #-} withSMPClient :: SMPQueueRec q => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a withSMPClient c q cmdStr action = do tSess <- liftIO $ mkSMPTransportSession c q - withLogClient c tSess (queueId q) cmdStr action + withLogClient c tSess (queueId q) cmdStr $ action . connectedClient -withSMPClient_ :: SMPQueueRec q => AgentClient -> q -> ByteString -> (SMPClient -> AM a) -> AM a -withSMPClient_ c q cmdStr action = do - tSess <- liftIO $ mkSMPTransportSession c q - withLogClient_ c tSess (queueId q) cmdStr action +sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer) +sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg = + sendOrProxySMPCommand c userId destSrv cmdStr senderId sendViaProxy sendDirectly + where + sendViaProxy smp proxySess = do + atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts + atomically $ incSMPServerStat c userId (protocolClientServer' smp) sentProxiedAttempts + proxySMPMessage smp proxySess spKey_ senderId msgFlags msg + sendDirectly smp = do + atomically $ incSMPServerStat c userId destSrv sentDirectAttempts + sendSMPMessage smp spKey_ senderId msgFlags msg + +sendOrProxySMPCommand :: + AgentClient -> + UserId -> + SMPServer -> + ByteString -> + SMP.SenderId -> + (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) -> + (SMPClient -> ExceptT SMPClientError IO ()) -> + AM (Maybe SMPServer) +sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDirectly = do + sess <- liftIO $ mkTransportSession c userId destSrv senderId + ifM (atomically shouldUseProxy) (sendViaProxy Nothing sess) (sendDirectly sess $> Nothing) + where + shouldUseProxy = do + cfg <- getNetworkConfig c + case smpProxyMode cfg of + SPMAlways -> pure True + SPMUnknown -> unknownServer + SPMUnprotected + | ipAddressProtected cfg destSrv -> pure False + | otherwise -> unknownServer + SPMNever -> pure False + directAllowed = do + cfg <- getNetworkConfig c + pure $ case smpProxyFallback cfg of + SPFAllow -> True + SPFAllowProtected -> ipAddressProtected cfg destSrv + SPFProhibit -> False + unknownServer = maybe True (notElem destSrv . knownSrvs) <$> TM.lookup userId (smpServers c) + sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer) + sendViaProxy proxySrv_ destSess@(_, _, qId) = do + r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do + r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess + let proxySrv = protocolClientServer' smp + case r' of + Right () -> pure $ Just proxySrv + Left proxyErr -> do + case proxyErr of + ProxyProtocolError (SMP.PROXY SMP.NO_SESSION) -> do + atomically deleteRelaySession + case proxySrv_ of + Just _ -> proxyError + -- sendViaProxy is called recursively here to re-create the session via the same server + -- to avoid failure in interactive calls that don't retry after the session disconnection. + Nothing -> sendViaProxy (Just $ ProtoServerWithAuth proxySrv prBasicAuth) destSess + _ -> proxyError + where + proxyError = + throwE + PROXY + { proxyServer = protocolClientServer smp, + relayServer = B.unpack $ strEncode destSrv, + proxyErr + } + -- checks that the current proxied relay session is the same one that was used to send the message and removes it + deleteRelaySession = + ( TM.lookup destSess (smpProxiedRelays c) + $>>= \(ProtoServerWithAuth srv _) -> tryReadSessVar (userId, srv, qId) (smpClients c) + ) + >>= \case + Just (Right (SMPConnectedClient smp' prs)) + | sameClient smp' -> + tryReadSessVar destSrv prs >>= \case + Just (Right proxySess') | sameProxiedRelay proxySess' -> TM.delete destSrv prs + _ -> pure () + _ -> pure () + sameClient smp' = sessionId (thParams smp) == sessionId (thParams smp') + sameProxiedRelay proxySess' = prSessionId proxySess == prSessionId proxySess' + case r of + Right r' -> do + atomically $ incSMPServerStat c userId destSrv sentViaProxy + forM_ r' $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied + pure r' + Left e + | serverHostError e -> ifM (atomically directAllowed) (sendDirectly destSess $> Nothing) (throwE e) + | otherwise -> throwE e + sendDirectly tSess = + withLogClient_ c tSess senderId ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do + r <- tryAgentError $ liftClient SMP (clientServer smp) $ sendCmdDirectly smp + case r of + Right () -> atomically $ incSMPServerStat c userId destSrv sentDirect + Left e -> throwE e + +ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool +ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts _ _) = do + isJust socksProxy || (hostMode == HMOnion && any isOnionHost hosts) + where + isOnionHost = \case THOnionHost _ -> True; _ -> False withNtfClient :: AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a withNtfClient c srv = withLogClient c (0, srv, Nothing) @@ -934,15 +1145,15 @@ withXFTPClient c (userId, srv, entityId) cmdStr action = do tSess <- liftIO $ mkTransportSession c userId srv entityId withLogClient c tSess entityId cmdStr action -liftClient :: (Show err, Encoding err) => (err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> AM a +liftClient :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> AM a liftClient protocolError_ = liftError . protocolClientError protocolError_ {-# INLINE liftClient #-} -protocolClientError :: (Show err, Encoding err) => (err -> AgentErrorType) -> HostName -> ProtocolClientError err -> AgentErrorType +protocolClientError :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ProtocolClientError err -> AgentErrorType protocolClientError protocolError_ host = \case - PCEProtocolError e -> protocolError_ e + PCEProtocolError e -> protocolError_ host e PCEResponseError e -> BROKER host $ RESPONSE $ B.unpack $ smpEncode e - PCEUnexpectedResponse _ -> BROKER host UNEXPECTED + PCEUnexpectedResponse e -> BROKER host $ UNEXPECTED $ B.unpack e PCEResponseTimeout -> BROKER host TIMEOUT PCENetworkError -> BROKER host NETWORK PCEIncompatibleHost -> BROKER host HOST @@ -982,14 +1193,16 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case Right smp -> do rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g - (sKey, _) <- atomically $ C.generateAuthKeyPair sa g + (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do - SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe - liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey + SMP.QIK {rcvId, sndId, sndSecure} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe True + liftError (testErr TSSecureQueue) $ + if sndSecure + then secureSndSMPQueue smp spKey sndId sKey + else secureSMPQueue smp rpKey rcvId sKey liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp - incClientStat c userId smp "SMP_TEST" "OK" pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok Left e -> pure (Just $ testErr TSConnect e) where @@ -1019,10 +1232,9 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk g xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath - unless (digest == rcvDigest) $ throwError $ ProtocolTestFailure TSCompareFile $ XFTP DIGEST + unless (digest == rcvDigest) $ throwE $ ProtocolTestFailure TSCompareFile $ XFTP (B.unpack $ strEncode srv) DIGEST liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId ok <- tcpTimeout xftpNetworkConfig `timeout` X.closeXFTPClient xftp - incClientStat c userId xftp "XFTP_TEST" "OK" pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok Left e -> pure (Just $ testErr TSConnect e) where @@ -1061,7 +1273,6 @@ runNTFServerTest c userId (ProtoServerWithAuth srv _) = do (tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf npKey (NewNtfTkn deviceToken nKey dhKey) liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf npKey tknId ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient ntf - incClientStat c userId ntf "NTF_TEST" "OK" pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok Left e -> pure (Just $ testErr TSConnect e) where @@ -1094,8 +1305,8 @@ getSessionMode :: AgentClient -> IO TransportSessionMode getSessionMode = atomically . fmap sessionMode . getNetworkConfig {-# INLINE getSessionMode #-} -newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri) -newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do +newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> SenderCanSecure -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) +newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode senderCanSecure = do C.AuthAlg a <- asks (rcvAuthAlg . config) g <- asks random rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g @@ -1103,8 +1314,9 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g logServer "-->" c srv "" "NEW" tSess <- liftIO $ mkTransportSession c userId srv connId - QIK {rcvId, sndId, rcvPublicDhKey} <- - withClient c tSess "NEW" $ \smp -> createSMPQueue smp rKeys dhKey auth subMode + (sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <- + withClient c tSess $ \(SMPConnectedClient smp _) -> + (sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode senderCanSecure liftIO . logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] let rq = RcvQueue @@ -1117,6 +1329,7 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do e2ePrivKey, e2eDhSecret = Nothing, sndId, + sndSecure, status = New, dbQueueId = DBNewQueue, primary = True, @@ -1126,34 +1339,54 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do clientNtfCreds = Nothing, deleteErrors = 0 } - pure (rq, SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey) + qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey sndSecure + pure (rq, qUri, tSess, sessId) -processSubResult :: AgentClient -> RcvQueue -> Either SMPClientError () -> IO (Either SMPClientError ()) -processSubResult c rq r = do - case r of - Left e -> - unless (temporaryClientError e) . atomically $ do - RQ.deleteQueue rq (pendingSubs c) - TM.insert (RQ.qKey rq) e (removedSubs c) - _ -> addSubscription c rq - pure r +processSubResult :: AgentClient -> RcvQueue -> Either SMPClientError () -> STM () +processSubResult c rq@RcvQueue {userId, server, connId} = \case + Left e -> + unless (temporaryClientError e) $ do + incSMPServerStat c userId server connSubErrs + failSubscription c rq e + Right () -> + ifM + (hasPendingSubscription c connId) + (incSMPServerStat c userId server connSubscribed >> addSubscription c rq) + (incSMPServerStat c userId server connSubIgnored) temporaryAgentError :: AgentErrorType -> Bool temporaryAgentError = \case - BROKER _ NETWORK -> True - BROKER _ TIMEOUT -> True + BROKER _ e -> tempBrokerError e + SMP _ (SMP.PROXY (SMP.BROKER e)) -> tempBrokerError e + XFTP _ XFTP.TIMEOUT -> True + PROXY _ _ (ProxyProtocolError (SMP.PROXY (SMP.BROKER e))) -> tempBrokerError e + PROXY _ _ (ProxyProtocolError (SMP.PROXY SMP.NO_SESSION)) -> True INACTIVE -> True _ -> False -{-# INLINE temporaryAgentError #-} + where + tempBrokerError = \case + NETWORK -> True + TIMEOUT -> True + _ -> False temporaryOrHostError :: AgentErrorType -> Bool -temporaryOrHostError = \case - BROKER _ HOST -> True - e -> temporaryAgentError e +temporaryOrHostError e = temporaryAgentError e || serverHostError e {-# INLINE temporaryOrHostError #-} +serverHostError :: AgentErrorType -> Bool +serverHostError = \case + BROKER _ e -> brokerHostError e + SMP _ (SMP.PROXY (SMP.BROKER e)) -> brokerHostError e + PROXY _ _ (ProxyProtocolError (SMP.PROXY (SMP.BROKER e))) -> brokerHostError e + _ -> False + where + brokerHostError = \case + HOST -> True + SMP.TRANSPORT TEVersion -> True + _ -> False + -- | Subscribe to queues. The list of results can have a different order. -subscribeQueues :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())] +subscribeQueues :: AgentClient -> [RcvQueue] -> AM' ([(RcvQueue, Either AgentErrorType ())], Maybe SessionId) subscribeQueues c qs = do (errs, qs') <- partitionEithers <$> mapM checkQueue qs atomically $ do @@ -1161,24 +1394,48 @@ subscribeQueues c qs = do RQ.batchAddQueues (pendingSubs c) qs' env <- ask -- only "checked" queues are subscribed - (errs <>) <$> sendTSessionBatches "SUB" 90 id (subscribeQueues_ env) c qs' + session <- newTVarIO Nothing + rs <- sendTSessionBatches "SUB" id (subscribeQueues_ env session) c qs' + (errs <> rs,) <$> readTVarIO session where checkQueue rq = do prohibited <- atomically $ hasGetLock c rq - pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED) else Right rq - subscribeQueues_ :: Env -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ()) - subscribeQueues_ env smp qs' = do + pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq + subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ()) + subscribeQueues_ env session smp qs' = do + let (userId, srv, _) = transportSession' smp + atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs' rs <- sendBatch subscribeSMPQueues smp qs' - mapM_ (uncurry $ processSubResult c) rs - when (any temporaryClientError . lefts . map snd $ L.toList rs) $ - runReaderT (resubscribeSMPSession c $ transportSession' smp) env - pure rs + active <- + atomically $ + ifM + (activeClientSession c tSess sessId) + (writeTVar session (Just sessId) >> processSubResults rs $> True) + (incSMPServerStat' c userId srv connSubIgnored (length rs) $> False) + if active + then when (hasTempErrors rs) resubscribe $> rs + else do + logWarn "subcription batch result for replaced SMP client, resubscribing" + resubscribe $> L.map (second $ \_ -> Left PCENetworkError) rs + where + tSess = transportSession' smp + sessId = sessionId $ thParams smp + hasTempErrors = any (either temporaryClientError (const False) . snd) + processSubResults :: NonEmpty (RcvQueue, Either SMPClientError ()) -> STM () + processSubResults = mapM_ $ uncurry $ processSubResult c + resubscribe = resubscribeSMPSession c tSess `runReaderT` env -type BatchResponses e r = (NonEmpty (RcvQueue, Either e r)) +activeClientSession :: AgentClient -> SMPTransportSession -> SessionId -> STM Bool +activeClientSession c tSess sessId = sameSess <$> tryReadSessVar tSess (smpClients c) + where + sameSess = \case + Just (Right (SMPConnectedClient smp _)) -> sessId == sessionId (thParams smp) + _ -> False --- statBatchSize is not used to batch the commands, only for traffic statistics -sendTSessionBatches :: forall q r. ByteString -> Int -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> AM' [(RcvQueue, Either AgentErrorType r)] -sendTSessionBatches statCmd statBatchSize toRQ action c qs = +type BatchResponses e r = NonEmpty (RcvQueue, Either e r) + +sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> AM' [(RcvQueue, Either AgentErrorType r)] +sendTSessionBatches statCmd toRQ action c qs = concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues) where batchQueues :: AM' [(SMPTransportSession, NonEmpty q)] @@ -1190,35 +1447,54 @@ sendTSessionBatches statCmd statBatchSize toRQ action c qs = let tSess = mkSMPTSession (toRQ q) mode in M.alter (Just . maybe [q] (q <|)) tSess m sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses AgentErrorType r) - sendClientBatch (tSess@(userId, srv, _), qs') = + sendClientBatch (tSess@(_, srv, _), qs') = tryAgentError' (getSMPServerClient c tSess) >>= \case Left e -> pure $ L.map ((,Left e) . toRQ) qs' - Right smp -> liftIO $ do + Right (SMPConnectedClient smp _) -> liftIO $ do logServer "-->" c srv (bshow (length qs') <> " queues") statCmd - rs <- L.map agentError <$> action smp qs' - statBatch - pure rs + L.map agentError <$> action smp qs' where agentError = second . first $ protocolClientError SMP $ clientServer smp - statBatch = - let n = (length qs - 1) `div` statBatchSize + 1 - in incClientStatN c userId smp n statCmd "OK" sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ()) sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs) where queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId) -addSubscription :: AgentClient -> RcvQueue -> IO () -addSubscription c rq@RcvQueue {connId} = atomically $ do +addSubscription :: AgentClient -> RcvQueue -> STM () +addSubscription c rq@RcvQueue {connId} = do modifyTVar' (subscrConns c) $ S.insert connId RQ.addQueue rq $ activeSubs c RQ.deleteQueue rq $ pendingSubs c +failSubscription :: AgentClient -> RcvQueue -> SMPClientError -> STM () +failSubscription c rq e = do + RQ.deleteQueue rq (pendingSubs c) + TM.insert (RQ.qKey rq) e (removedSubs c) + +addPendingSubscription :: AgentClient -> RcvQueue -> STM () +addPendingSubscription c rq@RcvQueue {connId} = do + modifyTVar' (subscrConns c) $ S.insert connId + RQ.addQueue rq $ pendingSubs c + +addNewQueueSubscription :: AgentClient -> RcvQueue -> SMPTransportSession -> SessionId -> AM' () +addNewQueueSubscription c rq tSess sessId = do + same <- + atomically $ + ifM + (activeClientSession c tSess sessId) + (True <$ addSubscription c rq) + (False <$ addPendingSubscription c rq) + unless same $ resubscribeSMPSession c tSess + hasActiveSubscription :: AgentClient -> ConnId -> STM Bool hasActiveSubscription c connId = RQ.hasConn connId $ activeSubs c {-# INLINE hasActiveSubscription #-} +hasPendingSubscription :: AgentClient -> ConnId -> STM Bool +hasPendingSubscription c connId = RQ.hasConn connId $ pendingSubs c +{-# INLINE hasPendingSubscription #-} + removeSubscription :: AgentClient -> ConnId -> STM () removeSubscription c connId = do modifyTVar' (subscrConns c) $ S.delete connId @@ -1240,23 +1516,21 @@ showServer ProtocolServer {host, port} = {-# INLINE showServer #-} logSecret :: ByteString -> ByteString -logSecret bs = encode $ B.take 3 bs +logSecret bs = B64.encode $ B.take 3 bs {-# INLINE logSecret #-} -sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM () -sendConfirmation c sq@SndQueue {sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = - withSMPClient_ c sq "SEND " $ \smp -> do - let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation - msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg - liftClient SMP (clientServer smp) $ sendSMPMessage smp Nothing sndId (SMP.MsgFlags {notification = True}) msg -sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database" +sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer) +sendConfirmation c sq@SndQueue {userId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do + let (privHdr, spKey) = if sndSecure then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation sndPublicKey, Nothing) + clientMsg = SMP.ClientMessage privHdr agentConfirmation + msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg + sendOrProxySMPMessage c userId server "" spKey sndId (MsgFlags {notification = True}) msg +sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database" -sendInvitation :: AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM () +sendInvitation :: AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer) sendInvitation c userId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do - tSess <- liftIO $ mkTransportSession c userId smpServer senderId - withLogClient_ c tSess senderId "SEND " $ \smp -> do - msg <- mkInvitation - liftClient SMP (clientServer smp) $ sendSMPMessage smp Nothing senderId MsgFlags {notification = True} msg + msg <- mkInvitation + sendOrProxySMPMessage c userId smpServer "" Nothing senderId (MsgFlags {notification = True}) msg where mkInvitation :: AM ByteString -- this is only encrypted with per-queue E2E, not with double ratchet @@ -1291,13 +1565,21 @@ secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey = withSMPClient c rq "KEY " $ \smp -> secureSMPQueue smp rcvPrivateKey rcvId senderKey +secureSndQueue :: AgentClient -> SndQueue -> AM () +secureSndQueue c SndQueue {userId, server, sndId, sndPrivateKey, sndPublicKey} = + void $ sendOrProxySMPCommand c userId server "SKEY " sndId secureViaProxy secureDirectly + where + -- TODO track statistics + secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey + secureDirectly smp = secureSndSMPQueue smp sndPrivateKey sndId sndPublicKey + enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey) enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey = withSMPClient c rq "NKEY " $ \smp -> enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey enableQueuesNtfs :: AgentClient -> [(RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)] -> AM' [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))] -enableQueuesNtfs = sendTSessionBatches "NKEY" 90 fst3 enableQueues_ +enableQueuesNtfs = sendTSessionBatches "NKEY" fst3 enableQueues_ where fst3 (x, _, _) = x enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey))) @@ -1311,7 +1593,7 @@ disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} = disableSMPQueueNotifications smp rcvPrivateKey rcvId disableQueuesNtfs :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())] -disableQueuesNtfs = sendTSessionBatches "NDEL" 90 id $ sendBatch disableSMPQueuesNtfs +disableQueuesNtfs = sendTSessionBatches "NDEL" id $ sendBatch disableSMPQueuesNtfs sendAck :: AgentClient -> RcvQueue -> MsgId -> AM () sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do @@ -1338,18 +1620,44 @@ deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do deleteSMPQueue smp rcvPrivateKey rcvId deleteQueues :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())] -deleteQueues = sendTSessionBatches "DEL" 90 id $ sendBatch deleteSMPQueues +deleteQueues c = sendTSessionBatches "DEL" id deleteQueues_ c + where + deleteQueues_ smp rqs = do + let (userId, srv, _) = transportSession' smp + atomically $ incSMPServerStat' c userId srv connDelAttempts $ length rqs + rs <- sendBatch deleteSMPQueues smp rqs + let successes = foldl' (\n (_, r) -> if isRight r then n + 1 else n) 0 rs + atomically $ incSMPServerStat' c userId srv connDeleted successes + pure rs -sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM () -sendAgentMessage c sq@SndQueue {sndId, sndPrivateKey} msgFlags agentMsg = - withSMPClient_ c sq "SEND " $ \smp -> do - let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg - msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg - liftClient SMP (clientServer smp) $ sendSMPMessage smp (Just sndPrivateKey) sndId msgFlags msg +sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer) +sendAgentMessage c sq@SndQueue {userId, server, sndId, sndPrivateKey} msgFlags agentMsg = do + let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg + msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg + sendOrProxySMPMessage c userId server "" (Just sndPrivateKey) sndId msgFlags msg + +data ServerQueueInfo = ServerQueueInfo + { server :: SMPServer, + rcvId :: Text, + sndId :: Text, + ntfId :: Maybe Text, + status :: Text, + info :: QueueInfo + } + deriving (Show) + +getQueueInfo :: AgentClient -> RcvQueue -> AM ServerQueueInfo +getQueueInfo c rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientNtfCreds} = + withSMPClient c rq "QUE" $ \smp -> do + info <- getSMPQueueInfo smp rcvPrivateKey rcvId + let ntfId = enc . (\ClientNtfCreds {notifierId} -> notifierId) <$> clientNtfCreds + pure ServerQueueInfo {server, rcvId = enc rcvId, sndId = enc sndId, ntfId, status = serializeQueueStatus status, info} + where + enc = decodeLatin1 . B64.encode agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519) agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey = - withClient c (0, ntfServer, Nothing) "TNEW" $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey) + withClient c (0, ntfServer, Nothing) $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey) agentNtfVerifyToken :: AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> AM () agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code = @@ -1392,10 +1700,10 @@ agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do rKeys <- xftpRcvKeys n (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random - let fileInfo = FileInfo {sndKey, size = fromIntegral chunkSize, digest = chunkDigest} + let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv "" "FNEW" tSess <- liftIO $ mkTransportSession c userId srv chunkDigest - (sndId, rIds) <- withClient c tSess "FNEW" $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth + (sndId, rIds) <- withClient c tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth logServer "<--" c srv "" $ B.unwords ["SIDS", logSecret sndId] pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys} @@ -1418,7 +1726,7 @@ xftpRcvKeys n = do rKeys <- atomically . replicateM n . C.generateAuthKeyPair C.SEd25519 =<< asks random case L.nonEmpty rKeys of Just rKeys' -> pure rKeys' - _ -> throwError $ INTERNAL "non-positive number of recipients" + _ -> throwE $ INTERNAL "non-positive number of recipients" xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey) xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys @@ -1455,7 +1763,7 @@ agentCbDecrypt dhSecret nonce msg = cryptoError :: C.CryptoError -> AgentErrorType cryptoError = \case - C.CryptoLargeMsgError -> CMD LARGE + C.CryptoLargeMsgError -> CMD LARGE "CryptoLargeMsgError" C.CryptoHeaderError _ -> AGENT A_MESSAGE -- parsing error C.CERatchetDuplicateMessage -> AGENT A_DUPLICATE C.AESDecryptError -> c DECRYPT_AES @@ -1480,7 +1788,7 @@ withWork c doWork getWork action = Left e -> notifyErr INTERNAL e where noWork = liftIO $ noWorkToDo doWork - notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ err $ show e) + notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e) noWorkToDo :: TMVar () -> IO () noWorkToDo = void . atomically . tryTakeTMVar @@ -1523,7 +1831,7 @@ suspendOperation c op endedAction = do notifySuspended :: AgentClient -> STM () notifySuspended c = do -- unsafeIOToSTM $ putStrLn "notifySuspended" - writeTBQueue (subQ c) ("", "", APC SAENone SUSPENDED) + writeTBQueue (subQ c) ("", "", AEvt SAENone SUSPENDED) writeTVar (agentState c) ASSuspended endOperation :: AgentClient -> AgentOperation -> STM () -> STM () @@ -1566,10 +1874,16 @@ withStore :: AgentClient -> (DB.Connection -> IO (Either StoreError a)) -> AM a withStore c action = do st <- asks store withExceptT storeError . ExceptT . liftIO . agentOperationBracket c AODatabase (\_ -> pure ()) $ - withTransaction st action `E.catch` handleInternal "" + withTransaction st action `E.catches` handleDBErrors where - handleInternal :: String -> E.SomeException -> IO (Either StoreError a) - handleInternal ctxStr e = pure . Left . SEInternal . B.pack $ show e <> ctxStr + handleDBErrors :: [E.Handler IO (Either StoreError a)] + handleDBErrors = + [ E.Handler $ \(e :: SQL.SQLError) -> + let se = SQL.sqlError e + busy = se == SQL.ErrorBusy || se == SQL.ErrorLocked + in pure . Left . (if busy then SEDatabaseBusy else SEInternal) $ bshow se, + E.Handler $ \(E.SomeException e) -> pure . Left $ SEInternal $ bshow e + ] withStoreBatch :: Traversable t => AgentClient -> (DB.Connection -> t (IO (Either AgentErrorType a))) -> AM' (t (Either AgentErrorType a)) withStoreBatch c actions = do @@ -1592,37 +1906,15 @@ storeError = \case SEConnDuplicate -> CONN DUPLICATE SEBadConnType CRcv -> CONN SIMPLEX SEBadConnType CSnd -> CONN SIMPLEX - SEInvitationNotFound -> CMD PROHIBITED + SEInvitationNotFound -> CMD PROHIBITED "SEInvitationNotFound" -- this error is never reported as store error, -- it is used to wrap agent operations when "transaction-like" store access is needed -- NOTE: network IO should NOT be used inside AgentStoreMonad SEAgentError e -> e + SEDatabaseBusy e -> CRITICAL True $ B.unpack e e -> INTERNAL $ show e -incStat :: AgentClient -> Int -> AgentStatsKey -> STM () -incStat AgentClient {agentStats} n k = do - TM.lookup k agentStats >>= \case - Just v -> modifyTVar' v (+ n) - _ -> newTVar n >>= \v -> TM.insert k v agentStats - -incClientStat :: ProtocolServerClient v err msg => AgentClient -> UserId -> Client msg -> ByteString -> ByteString -> IO () -incClientStat c userId pc = incClientStatN c userId pc 1 -{-# INLINE incClientStat #-} - -incServerStat :: AgentClient -> UserId -> ProtocolServer p -> ByteString -> ByteString -> IO () -incServerStat c userId ProtocolServer {host} cmd res = do - threadDelay 100000 - atomically $ incStat c 1 statsKey - where - statsKey = AgentStatsKey {userId, host = strEncode $ L.head host, clientTs = "", cmd, res} - -incClientStatN :: ProtocolServerClient v err msg => AgentClient -> UserId -> Client msg -> Int -> ByteString -> ByteString -> IO () -incClientStatN c userId pc n cmd res = do - atomically $ incStat c n statsKey - where - statsKey = AgentStatsKey {userId, host = strEncode $ clientTransportHost pc, clientTs = strEncode $ clientSessionTs pc, cmd, res} - -userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMap UserId (NonEmpty (ProtoServerWithAuth p)) +userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMap UserId (UserServers p) userServers c = case protocolTypeI @p of SPSMP -> smpServers c SPXFTP -> xftpServers c @@ -1644,8 +1936,8 @@ getNextServer c userId usedSrvs = withUserServers c userId $ \srvs -> withUserServers :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> (NonEmpty (ProtoServerWithAuth p) -> AM a) -> AM a withUserServers c userId action = atomically (TM.lookup userId $ userServers c) >>= \case - Just srvs -> action srvs - _ -> throwError $ INTERNAL "unknown userId - no user servers" + Just srvs -> action $ enabledSrvs srvs + _ -> throwE $ INTERNAL "unknown userId - no user servers" withNextSrv :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> TVar [ProtocolServer p] -> [ProtocolServer p] -> (ProtoServerWithAuth p -> AM a) -> AM a withNextSrv c userId usedSrvs initUsed action = do @@ -1653,11 +1945,120 @@ withNextSrv c userId usedSrvs initUsed action = do srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId used atomically $ do srvs_ <- TM.lookup userId $ userServers c - let unused = maybe [] ((\\ used) . map protoServer . L.toList) srvs_ + let unused = maybe [] ((\\ used) . map protoServer . L.toList . enabledSrvs) srvs_ used' = if null unused then initUsed else srv : used writeTVar usedSrvs $! used' action srvAuth +incSMPServerStat :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> STM () +incSMPServerStat c userId srv sel = incSMPServerStat' c userId srv sel 1 + +incSMPServerStat' :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> Int -> STM () +incSMPServerStat' AgentClient {smpServersStats} userId srv sel n = do + TM.lookup (userId, srv) smpServersStats >>= \case + Just v -> modifyTVar' (sel v) (+ n) + Nothing -> do + newStats <- newAgentSMPServerStats + modifyTVar' (sel newStats) (+ n) + TM.insert (userId, srv) newStats smpServersStats + +incXFTPServerStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> STM () +incXFTPServerStat c userId srv sel = incXFTPServerStat_ c userId srv sel 1 +{-# INLINE incXFTPServerStat #-} + +incXFTPServerStat' :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> Int -> STM () +incXFTPServerStat' = incXFTPServerStat_ +{-# INLINE incXFTPServerStat' #-} + +incXFTPServerSizeStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int64) -> Int64 -> STM () +incXFTPServerSizeStat = incXFTPServerStat_ +{-# INLINE incXFTPServerSizeStat #-} + +incXFTPServerStat_ :: Num n => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar n) -> n -> STM () +incXFTPServerStat_ AgentClient {xftpServersStats} userId srv sel n = do + TM.lookup (userId, srv) xftpServersStats >>= \case + Just v -> modifyTVar' (sel v) (+ n) + Nothing -> do + newStats <- newAgentXFTPServerStats + modifyTVar' (sel newStats) (+ n) + TM.insert (userId, srv) newStats xftpServersStats + +data AgentServersSummary = AgentServersSummary + { smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData, + xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData, + statsStartedAt :: UTCTime, + smpServersSessions :: Map (UserId, SMPServer) ServerSessions, + smpServersSubs :: Map (UserId, SMPServer) SMPServerSubs, + xftpServersSessions :: Map (UserId, XFTPServer) ServerSessions, + xftpRcvInProgress :: [XFTPServer], + xftpSndInProgress :: [XFTPServer], + xftpDelInProgress :: [XFTPServer] + } + deriving (Show) + +data SMPServerSubs = SMPServerSubs + { ssActive :: Int, -- based on activeSubs + ssPending :: Int -- based on pendingSubs + } + deriving (Show) + +data ServerSessions = ServerSessions + { ssConnected :: Int, + ssErrors :: Int, + ssConnecting :: Int + } + deriving (Show) + +getAgentServersSummary :: AgentClient -> IO AgentServersSummary +getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt, agentEnv} = do + sss <- mapM getAgentSMPServerStats =<< readTVarIO smpServersStats + xss <- mapM getAgentXFTPServerStats =<< readTVarIO xftpServersStats + statsStartedAt <- readTVarIO srvStatsStartedAt + smpServersSessions <- countSessions =<< readTVarIO (smpClients c) + smpServersSubs <- getServerSubs + xftpServersSessions <- countSessions =<< readTVarIO (xftpClients c) + xftpRcvInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpRcvWorkers + xftpSndInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpSndWorkers + xftpDelInProgress <- getXFTPWorkerSrvs xftpDelWorkers + pure + AgentServersSummary + { smpServersStats = sss, + xftpServersStats = xss, + statsStartedAt, + smpServersSessions, + smpServersSubs, + xftpServersSessions, + xftpRcvInProgress, + xftpSndInProgress, + xftpDelInProgress + } + where + getServerSubs = do + subs <- M.foldrWithKey' (addSub incActive) M.empty <$> readTVarIO (getRcvQueues $ activeSubs c) + M.foldrWithKey' (addSub incPending) subs <$> readTVarIO (getRcvQueues $ pendingSubs c) + where + addSub f (userId, srv, _) _ = M.alter (Just . f . fromMaybe SMPServerSubs {ssActive = 0, ssPending = 0}) (userId, srv) + incActive ss = ss {ssActive = ssActive ss + 1} + incPending ss = ss {ssPending = ssPending ss + 1} + Env {xftpAgent = XFTPAgent {xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}} = agentEnv + getXFTPWorkerSrvs workers = foldM addSrv [] . M.toList =<< readTVarIO workers + where + addSrv acc (srv, Worker {doWork}) = do + hasWork <- atomically $ not <$> isEmptyTMVar doWork + pure $ if hasWork then srv : acc else acc + countSessions :: Map (TransportSession msg) (ClientVar msg) -> IO (Map (UserId, ProtoServer msg) ServerSessions) + countSessions = foldM addClient M.empty . M.toList + where + addClient !acc ((userId, srv, _), SessionVar {sessionVar}) = do + c_ <- atomically $ tryReadTMVar sessionVar + pure $ M.alter (Just . add c_) (userId, srv) acc + where + add c_ = modifySessions c_ . fromMaybe ServerSessions {ssConnected = 0, ssErrors = 0, ssConnecting = 0} + modifySessions c_ ss = case c_ of + Just (Right _) -> ss {ssConnected = ssConnected ss + 1} + Just (Left _) -> ss {ssErrors = ssErrors ss + 1} + Nothing -> ss {ssConnecting = ssConnecting ss + 1} + data SubInfo = SubInfo {userId :: UserId, server :: Text, rcvId :: Text, subError :: Maybe String} deriving (Show) @@ -1809,12 +2210,51 @@ getAgentWorkersSummary AgentClient {smpClients, ntfClients, xftpClients, smpDeli (pure WorkersSummary {numActive, numIdle = numIdle + 1, totalRestarts = totalRestarts + restartCount}) (pure WorkersSummary {numActive = numActive + 1, numIdle, totalRestarts = totalRestarts + restartCount}) +data AgentQueuesInfo = AgentQueuesInfo + { msgQInfo :: TBQueueInfo, + subQInfo :: TBQueueInfo, + smpClientsQueues :: Map Text (Int, UTCTime, ClientInfo) + } + deriving (Show) + +data ClientInfo + = ClientInfoQueues {sndQInfo :: TBQueueInfo, rcvQInfo :: TBQueueInfo} + | ClientInfoError {clientError :: (AgentErrorType, Maybe UTCTime)} + | ClientInfoConnecting + deriving (Show) + +getAgentQueuesInfo :: AgentClient -> IO AgentQueuesInfo +getAgentQueuesInfo AgentClient {msgQ, subQ, smpClients} = do + msgQInfo <- atomically $ getTBQueueInfo msgQ + subQInfo <- atomically $ getTBQueueInfo subQ + smpClientsMap <- readTVarIO smpClients + let smpClientsMap' = M.mapKeys (decodeLatin1 . strEncode) smpClientsMap + smpClientsQueues <- mapM getClientQueuesInfo smpClientsMap' + pure AgentQueuesInfo {msgQInfo, subQInfo, smpClientsQueues} + where + getClientQueuesInfo :: SMPClientVar -> IO (Int, UTCTime, ClientInfo) + getClientQueuesInfo SessionVar {sessionVar, sessionVarId, sessionVarTs} = do + clientInfo <- + atomically (tryReadTMVar sessionVar) >>= \case + Just (Right c) -> do + (sndQInfo, rcvQInfo) <- getProtocolClientQueuesInfo $ protocolClient c + pure ClientInfoQueues {sndQInfo, rcvQInfo} + Just (Left e) -> pure $ ClientInfoError e + Nothing -> pure ClientInfoConnecting + pure (sessionVarId, sessionVarTs, clientInfo) + $(J.deriveJSON defaultJSON ''AgentLocks) $(J.deriveJSON (enumJSON $ dropPrefix "TS") ''ProtocolTestStep) $(J.deriveJSON defaultJSON ''ProtocolTestFailure) +$(J.deriveJSON defaultJSON ''ServerSessions) + +$(J.deriveJSON defaultJSON ''SMPServerSubs) + +$(J.deriveJSON defaultJSON ''AgentServersSummary) + $(J.deriveJSON defaultJSON ''SubInfo) $(J.deriveJSON defaultJSON ''SubscriptionsInfo) @@ -1827,6 +2267,12 @@ $(J.deriveJSON defaultJSON {J.fieldLabelModifier = takeWhile (/= '_')} ''AgentWo $(J.deriveJSON defaultJSON ''AgentWorkersSummary) +$(J.deriveJSON (sumTypeJSON $ dropPrefix "ClientInfo") ''ClientInfo) + +$(J.deriveJSON defaultJSON ''AgentQueuesInfo) + $(J.deriveJSON (enumJSON $ dropPrefix "UN") ''UserNetworkType) $(J.deriveJSON defaultJSON ''UserNetworkInfo) + +$(J.deriveJSON defaultJSON ''ServerQueueInfo) diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index f91144fdc..0f88508b9 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -7,6 +7,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} @@ -15,7 +16,12 @@ module Simplex.Messaging.Agent.Env.SQLite AM, AgentConfig (..), InitialAgentServers (..), + ServerCfg (..), + UserServers (..), NetworkConfig (..), + presetServerCfg, + enabledServerCfg, + mkUserServers, defaultAgentConfig, defaultReconnectInterval, tryAgentError, @@ -39,10 +45,14 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson.TH as JQ import Data.ByteArray (ScrubbedBytes) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as L import Data.Map (Map) +import Data.Maybe (fromMaybe) import Data.Time.Clock (NominalDiffTime, nominalDay) import Data.Time.Clock.System (SystemTime (..)) import Data.Word (Word16) @@ -54,13 +64,13 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Client -import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Notifications.Transport (NTFVersion) import Simplex.Messaging.Notifications.Types -import Simplex.Messaging.Protocol (NtfServer, VersionRangeSMPC, XFTPServer, XFTPServerWithAuth, supportedSMPClientVRange) +import Simplex.Messaging.Parsers (defaultJSON) +import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth, ProtocolServer, ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SMPVersion, TLS, Transport (..)) @@ -75,12 +85,38 @@ type AM' a = ReaderT Env IO a type AM a = ExceptT AgentErrorType (ReaderT Env IO) a data InitialAgentServers = InitialAgentServers - { smp :: Map UserId (NonEmpty SMPServerWithAuth), + { smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)), ntf :: [NtfServer], - xftp :: Map UserId (NonEmpty XFTPServerWithAuth), + xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)), netCfg :: NetworkConfig } +data ServerCfg p = ServerCfg + { server :: ProtoServerWithAuth p, + preset :: Bool, + tested :: Maybe Bool, + enabled :: Bool + } + deriving (Show) + +enabledServerCfg :: ProtoServerWithAuth p -> ServerCfg p +enabledServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = True} + +presetServerCfg :: Bool -> ProtoServerWithAuth p -> ServerCfg p +presetServerCfg enabled server = ServerCfg {server, preset = True, tested = Nothing, enabled} + +data UserServers p = UserServers + { enabledSrvs :: NonEmpty (ProtoServerWithAuth p), + knownSrvs :: NonEmpty (ProtocolServer p) + } + +-- This function sets all servers as enabled in case all passed servers are disabled. +mkUserServers :: NonEmpty (ServerCfg p) -> UserServers p +mkUserServers srvs = UserServers {enabledSrvs, knownSrvs} + where + enabledSrvs = L.map (\ServerCfg {server} -> server) $ fromMaybe srvs $ L.nonEmpty $ L.filter (\ServerCfg {enabled} -> enabled) srvs + knownSrvs = L.map (\ServerCfg {server = ProtoServerWithAuth srv _} -> srv) srvs + data AgentConfig = AgentConfig { tcpPort :: Maybe ServiceName, rcvAuthAlg :: C.AuthAlg, @@ -92,20 +128,22 @@ data AgentConfig = AgentConfig xftpCfg :: XFTPClientConfig, reconnectInterval :: RetryInterval, messageRetryInterval :: RetryInterval2, - userNetworkInterval :: RetryInterval, + userNetworkInterval :: Int, + userOfflineDelay :: NominalDiffTime, messageTimeout :: NominalDiffTime, connDeleteDeliveryTimeout :: NominalDiffTime, helloTimeout :: NominalDiffTime, quotaExceededTimeout :: NominalDiffTime, + persistErrorInterval :: NominalDiffTime, initialCleanupDelay :: Int64, cleanupInterval :: Int64, + initialLogStatsDelay :: Int64, + logStatsInterval :: Int64, cleanupStepInterval :: Int, maxWorkerRestartsPerMin :: Int, - maxSubscriptionTimeouts :: Int, storedMsgDataTTL :: NominalDiffTime, rcvFilesTTL :: NominalDiffTime, sndFilesTTL :: NominalDiffTime, - xftpNotifyErrsOnRetry :: Bool, xftpConsecutiveRetries :: Int, xftpMaxRecipientsPerRequest :: Int, deleteErrorCount :: Int, @@ -147,14 +185,6 @@ defaultMessageRetryInterval = } } -defaultUserNetworkInterval :: RetryInterval -defaultUserNetworkInterval = - RetryInterval - { initialInterval = 1200_000000, -- 20 minutes - increaseAfter = 0, - maxInterval = 7200_000000 -- 2 hours - } - defaultAgentConfig :: AgentConfig defaultAgentConfig = AgentConfig @@ -170,22 +200,22 @@ defaultAgentConfig = xftpCfg = defaultXFTPClientConfig, reconnectInterval = defaultReconnectInterval, messageRetryInterval = defaultMessageRetryInterval, - userNetworkInterval = defaultUserNetworkInterval, + userNetworkInterval = 1800_000000, -- 30 minutes, should be less than Int32 max value + userOfflineDelay = 2, -- if network offline event happens in less than 2 seconds after it was set online, it is ignored messageTimeout = 2 * nominalDay, connDeleteDeliveryTimeout = 2 * nominalDay, helloTimeout = 2 * nominalDay, quotaExceededTimeout = 7 * nominalDay, + persistErrorInterval = 3, -- seconds initialCleanupDelay = 30 * 1000000, -- 30 seconds cleanupInterval = 30 * 60 * 1000000, -- 30 minutes + initialLogStatsDelay = 10 * 1000000, -- 10 seconds + logStatsInterval = 10 * 1000000, -- 10 seconds cleanupStepInterval = 200000, -- 200ms maxWorkerRestartsPerMin = 5, - -- 3 consecutive subscription timeouts will result in alert to the user - -- this is a fallback, as the timeout set to 3x of expected timeout, to avoid potential locking. - maxSubscriptionTimeouts = 3, storedMsgDataTTL = 21 * nominalDay, rcvFilesTTL = 2 * nominalDay, sndFilesTTL = nominalDay, - xftpNotifyErrsOnRetry = True, xftpConsecutiveRetries = 3, xftpMaxRecipientsPerRequest = 200, deleteErrorCount = 10, @@ -301,3 +331,12 @@ updateRestartCount :: SystemTime -> RestartCount -> RestartCount updateRestartCount t (RestartCount minute count) = do let min' = systemSeconds t `div` 60 in RestartCount min' $ if minute == min' then count + 1 else 1 + +$(pure []) + +instance ProtocolTypeI p => ToJSON (ServerCfg p) where + toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg) + toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg) + +instance ProtocolTypeI p => FromJSON (ServerCfg p) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerCfg) diff --git a/src/Simplex/Messaging/Agent/Lock.hs b/src/Simplex/Messaging/Agent/Lock.hs index c0647b844..69b8169e2 100644 --- a/src/Simplex/Messaging/Agent/Lock.hs +++ b/src/Simplex/Messaging/Agent/Lock.hs @@ -12,6 +12,8 @@ import Control.Monad (void) import Control.Monad.Except (ExceptT (..), runExceptT) import Control.Monad.IO.Unlift import Data.Functor (($>)) +import Data.Set (Set) +import qualified Data.Set as S import UnliftIO.Async (forConcurrently) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -39,13 +41,11 @@ withGetLock getLock key name a = (atomically . takeTMVar) (const a) -withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> [k] -> String -> m a -> m a +withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> String -> m a -> m a withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const where - holdLocks = forConcurrently keys $ \key -> atomically $ getPutLock getLock key name - -- only this withGetLocks would be holding the locks, - -- so it's safe to combine all lock releases into one transaction - releaseLocks = atomically . mapM_ takeTMVar + holdLocks = forConcurrently (S.toList keys) $ \key -> atomically $ getPutLock getLock key name + releaseLocks = mapM_ (atomically . takeTMVar) -- getLock and putTMVar can be in one transaction on the assumption that getLock doesn't write in case the lock already exists, -- and in case it is created and added to some shared resource (we use TMap) it also helps avoid contention for the newly created lock. diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index ae0066328..a239768b0 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -29,11 +29,10 @@ import Data.Time (UTCTime, addUTCTime, getCurrentTime) import Data.Time.Clock (diffUTCTime) import Simplex.Messaging.Agent.Client import Simplex.Messaging.Agent.Env.SQLite -import Simplex.Messaging.Agent.Protocol (ACommand (..), APartyCmd (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..)) +import Simplex.Messaging.Agent.Protocol (AEvent (..), AEvt (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..)) import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite -import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..)) import Simplex.Messaging.Notifications.Types @@ -161,7 +160,7 @@ runNtfWorker c srv Worker {doWork} = do logInfo $ "runNtfWorker, nextSub " <> tshow nextSub ri <- asks $ reconnectInterval . config withRetryInterval ri $ \_ loop -> do - lift $ waitForUserNetwork c + liftIO $ waitForUserNetwork c processSub nextSub `catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show) processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> AM () @@ -245,7 +244,7 @@ runNtfSMPWorker c srv Worker {doWork} = do logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub ri <- asks $ reconnectInterval . config withRetryInterval ri $ \_ loop -> do - lift $ waitForUserNetwork c + liftIO $ waitForUserNetwork c processSub nextSub `catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show) processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> AM () @@ -307,7 +306,7 @@ workerInternalError c connId internalErrStr = do -- TODO change error notifyInternalError :: MonadIO m => AgentClient -> ConnId -> String -> m () -notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, APC SAEConn $ ERR $ INTERNAL internalErrStr) +notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AEvt SAEConn $ ERR $ INTERNAL internalErrStr) {-# INLINE notifyInternalError #-} getNtfToken :: AM' (Maybe NtfToken) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 98db26ab4..b123fc1ec 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -41,6 +41,7 @@ module Simplex.Messaging.Agent.Protocol ratchetSyncSMPAgentVersion, deliveryRcptsSMPAgentVersion, pqdrSMPAgentVersion, + sndAuthKeySMPAgentVersion, currentSMPAgentVersion, supportedSMPAgentVRange, e2eEncConnInfoLength, @@ -49,18 +50,15 @@ module Simplex.Messaging.Agent.Protocol -- * SMP agent protocol types ConnInfo, ACommand (..), - APartyCmd (..), + AEvent (..), + AEvt (..), ACommandTag (..), + AEventTag (..), + AEvtTag (..), aCommandTag, - aPartyCmdTag, - ACmd (..), - APartyCmdTag (..), - ACmdTag (..), - AParty (..), + aEventTag, AEntity (..), - SAParty (..), SAEntity (..), - APartyI (..), AEntityI (..), MsgHash, MsgMeta (..), @@ -108,6 +106,7 @@ module Simplex.Messaging.Agent.Protocol CRClientData, ServiceScheme, simplexChat, + connReqUriP', AgentErrorType (..), CommandErrorType (..), ConnectionErrorType (..), @@ -116,11 +115,7 @@ module Simplex.Messaging.Agent.Protocol AgentCryptoError (..), cryptoErrToSyncState, ATransmission, - ATransmissionOrError, - ARawTransmission, ConnId, - RcvFileId, - SndFileId, ConfirmationId, InvitationId, MsgIntegrity (..), @@ -136,34 +131,21 @@ module Simplex.Messaging.Agent.Protocol serializeCommand, connMode, connMode', - networkCommandP, dbCommandP, - commandP, connModeT, serializeQueueStatus, queueStatusT, agentMessageType, extraSMPServerHosts, updateSMPServerHosts, - checkParty, - - -- * TCP transport functions - tPut, - tGet, - tPutRaw, - tGetRaw, ) where import Control.Applicative (optional, (<|>)) -import Control.Monad (unless) -import Control.Monad.Except (runExceptT, throwError) -import Control.Monad.IO.Class import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) @@ -175,11 +157,9 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) -import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (UTCTime) import Data.Time.Clock.System (SystemTime) -import Data.Time.ISO8601 import Data.Type.Equality import Data.Typeable () import Data.Word (Word16, Word32) @@ -188,24 +168,26 @@ import Database.SQLite.Simple.ToField import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol (FileParty (..)) import Simplex.FileTransfer.Transport (XFTPErrorType) +import Simplex.FileTransfer.Types (FileErrorType) import Simplex.Messaging.Agent.QueryString +import Simplex.Messaging.Client (ProxyClientError) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet ( InitialKeys (..), PQEncryption (..), - pattern PQEncOff, PQSupport, - pattern PQSupportOn, - pattern PQSupportOff, RcvE2ERatchetParams, RcvE2ERatchetParamsUri, - SndE2ERatchetParams + SndE2ERatchetParams, + pattern PQSupportOff, + pattern PQSupportOn, ) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol ( AProtocolType, + BrokerErrorType (..), EntityId, ErrorType, MsgBody, @@ -213,33 +195,32 @@ import Simplex.Messaging.Protocol MsgId, NMsgMeta, ProtocolServer (..), + SMPClientVersion, SMPMsgMeta, SMPServer, SMPServerWithAuth, SndPublicAuthKey, SubscriptionMode, - SMPClientVersion, - VersionSMPC, VersionRangeSMPC, + VersionSMPC, initialSMPClientVersion, legacyEncodeServer, legacyServerP, legacyStrEncodeServer, noAuthSrv, sameSrvAddr, + sndAuthKeySMPClientVersion, srvHostnamesSMPClientVersion, pattern ProtoServerWithAuth, pattern SMPServer, ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme -import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP) import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts_ (..)) import Simplex.Messaging.Util import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal import Simplex.RemoteControl.Types -import Text.Read import UnliftIO.Exception (Exception) -- SMP agent protocol version history: @@ -248,6 +229,7 @@ import UnliftIO.Exception (Exception) -- 3 - support ratchet renegotiation (6/30/2023) -- 4 - delivery receipts (7/13/2023) -- 5 - post-quantum double ratchet (3/14/2024) +-- 6 - secure reply queues with provided keys (6/14/2024) data SMPAgentVersion @@ -272,11 +254,17 @@ deliveryRcptsSMPAgentVersion = VersionSMPA 4 pqdrSMPAgentVersion :: VersionSMPA pqdrSMPAgentVersion = VersionSMPA 5 +sndAuthKeySMPAgentVersion :: VersionSMPA +sndAuthKeySMPAgentVersion = VersionSMPA 6 + +minSupportedSMPAgentVersion :: VersionSMPA +minSupportedSMPAgentVersion = duplexHandshakeSMPAgentVersion + currentSMPAgentVersion :: VersionSMPA -currentSMPAgentVersion = VersionSMPA 5 +currentSMPAgentVersion = VersionSMPA 6 supportedSMPAgentVRange :: VersionRangeSMPA -supportedSMPAgentVRange = mkVersionRange duplexHandshakeSMPAgentVersion currentSMPAgentVersion +supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPAgentVersion -- it is shorter to allow all handshake headers, -- including E2E (double-ratchet) parameters and @@ -293,41 +281,13 @@ e2eEncAgentMsgLength v = \case PQSupportOn | v >= pqdrSMPAgentVersion -> 13634 _ -> 15856 --- | Raw (unparsed) SMP agent protocol transmission. -type ARawTransmission = (ByteString, ByteString, ByteString) - --- | Parsed SMP agent protocol transmission. -type ATransmission p = (ACorrId, EntityId, APartyCmd p) - --- | SMP agent protocol transmission or transmission error. -type ATransmissionOrError p = (ACorrId, EntityId, Either AgentErrorType (APartyCmd p)) +-- | SMP agent event +type ATransmission = (ACorrId, EntityId, AEvt) type UserId = Int64 type ACorrId = ByteString --- | SMP agent protocol participants. -data AParty = Agent | Client - deriving (Eq, Show) - --- | Singleton types for SMP agent protocol participants. -data SAParty :: AParty -> Type where - SAgent :: SAParty Agent - SClient :: SAParty Client - -deriving instance Show (SAParty p) - -instance TestEquality SAParty where - testEquality SAgent SAgent = Just Refl - testEquality SClient SClient = Just Refl - testEquality _ _ = Nothing - -class APartyI (p :: AParty) where sAParty :: SAParty p - -instance APartyI Agent where sAParty = SAgent - -instance APartyI Client where sAParty = SClient - data AEntity = AEConn | AERcvFile | AESndFile | AENone deriving (Eq, Show) @@ -356,153 +316,144 @@ instance AEntityI AESndFile where sAEntity = SAESndFile instance AEntityI AENone where sAEntity = SAENone -data ACmd = forall p e. (APartyI p, AEntityI e) => ACmd (SAParty p) (SAEntity e) (ACommand p e) +data AEvt = forall e. AEntityI e => AEvt (SAEntity e) (AEvent e) -deriving instance Show ACmd - -data APartyCmd p = forall e. AEntityI e => APC (SAEntity e) (ACommand p e) - -instance Eq (APartyCmd p) where - APC e cmd == APC e' cmd' = case testEquality e e' of - Just Refl -> cmd == cmd' +instance Eq AEvt where + AEvt e evt == AEvt e' evt' = case testEquality e e' of + Just Refl -> evt == evt' Nothing -> False -deriving instance Show (APartyCmd p) +deriving instance Show AEvt type ConnInfo = ByteString --- | Parameterized type for SMP agent protocol commands and responses from all participants. -data ACommand (p :: AParty) (e :: AEntity) where - NEW :: Bool -> AConnectionMode -> InitialKeys -> SubscriptionMode -> ACommand Client AEConn -- response INV - INV :: AConnectionRequestUri -> ACommand Agent AEConn - JOIN :: Bool -> AConnectionRequestUri -> PQSupport -> SubscriptionMode -> ConnInfo -> ACommand Client AEConn -- response OK - CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake - LET :: ConfirmationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client - REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender - ACPT :: InvitationId -> PQSupport -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client - RJCT :: InvitationId -> ACommand Client AEConn - INFO :: PQSupport -> ConnInfo -> ACommand Agent AEConn - CON :: PQEncryption -> ACommand Agent AEConn -- notification that connection is established - SUB :: ACommand Client AEConn - END :: ACommand Agent AEConn - CONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone - DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone - DOWN :: SMPServer -> [ConnId] -> ACommand Agent AENone - UP :: SMPServer -> [ConnId] -> ACommand Agent AENone - SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent AEConn - RSYNC :: RatchetSyncState -> Maybe AgentCryptoError -> ConnectionStats -> ACommand Agent AEConn - SEND :: PQEncryption -> MsgFlags -> MsgBody -> ACommand Client AEConn - MID :: AgentMsgId -> PQEncryption -> ACommand Agent AEConn - SENT :: AgentMsgId -> ACommand Agent AEConn - MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn - MERRS :: NonEmpty AgentMsgId -> AgentErrorType -> ACommand Agent AEConn - MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent AEConn - MSGNTF :: SMPMsgMeta -> ACommand Agent AEConn - ACK :: AgentMsgId -> Maybe MsgReceiptInfo -> ACommand Client AEConn - RCVD :: MsgMeta -> NonEmpty MsgReceipt -> ACommand Agent AEConn - QCONT :: ACommand Agent AEConn - SWCH :: ACommand Client AEConn - OFF :: ACommand Client AEConn - DEL :: ACommand Client AEConn - DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> ACommand Agent AEConn - DEL_CONN :: ACommand Agent AEConn - DEL_USER :: Int64 -> ACommand Agent AENone - CHK :: ACommand Client AEConn - STAT :: ConnectionStats -> ACommand Agent AEConn - OK :: ACommand Agent AEConn - ERR :: AgentErrorType -> ACommand Agent AEConn - SUSPENDED :: ACommand Agent AENone - -- XFTP commands and responses - RFPROG :: Int64 -> Int64 -> ACommand Agent AERcvFile - RFDONE :: FilePath -> ACommand Agent AERcvFile - RFERR :: AgentErrorType -> ACommand Agent AERcvFile - SFPROG :: Int64 -> Int64 -> ACommand Agent AESndFile - SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> ACommand Agent AESndFile - SFERR :: AgentErrorType -> ACommand Agent AESndFile +-- | Parameterized type for SMP agent events +data AEvent (e :: AEntity) where + INV :: AConnectionRequestUri -> AEvent AEConn + CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake + REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender + INFO :: PQSupport -> ConnInfo -> AEvent AEConn + CON :: PQEncryption -> AEvent AEConn -- notification that connection is established + END :: AEvent AEConn + CONNECT :: AProtocolType -> TransportHost -> AEvent AENone + DISCONNECT :: AProtocolType -> TransportHost -> AEvent AENone + DOWN :: SMPServer -> [ConnId] -> AEvent AENone + UP :: SMPServer -> [ConnId] -> AEvent AENone + SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent AEConn + RSYNC :: RatchetSyncState -> Maybe AgentCryptoError -> ConnectionStats -> AEvent AEConn + SENT :: AgentMsgId -> Maybe SMPServer -> AEvent AEConn + MWARN :: AgentMsgId -> AgentErrorType -> AEvent AEConn + MERR :: AgentMsgId -> AgentErrorType -> AEvent AEConn + MERRS :: NonEmpty AgentMsgId -> AgentErrorType -> AEvent AEConn + MSG :: MsgMeta -> MsgFlags -> MsgBody -> AEvent AEConn + MSGNTF :: SMPMsgMeta -> AEvent AEConn + RCVD :: MsgMeta -> NonEmpty MsgReceipt -> AEvent AEConn + QCONT :: AEvent AEConn + DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> AEvent AEConn + DEL_CONN :: AEvent AEConn + DEL_USER :: Int64 -> AEvent AENone + STAT :: ConnectionStats -> AEvent AEConn + OK :: AEvent AEConn + ERR :: AgentErrorType -> AEvent AEConn + SUSPENDED :: AEvent AENone + RFPROG :: Int64 -> Int64 -> AEvent AERcvFile + RFDONE :: FilePath -> AEvent AERcvFile + RFERR :: AgentErrorType -> AEvent AERcvFile + RFWARN :: AgentErrorType -> AEvent AERcvFile + SFPROG :: Int64 -> Int64 -> AEvent AESndFile + SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent AESndFile + SFERR :: AgentErrorType -> AEvent AESndFile + SFWARN :: AgentErrorType -> AEvent AESndFile -deriving instance Eq (ACommand p e) +deriving instance Eq (AEvent e) -deriving instance Show (ACommand p e) +deriving instance Show (AEvent e) -data ACmdTag = forall p e. (APartyI p, AEntityI e) => ACmdTag (SAParty p) (SAEntity e) (ACommandTag p e) +data AEvtTag = forall e. AEntityI e => AEvtTag (SAEntity e) (AEventTag e) -data APartyCmdTag p = forall e. AEntityI e => APCT (SAEntity e) (ACommandTag p e) - -instance Eq (APartyCmdTag p) where - APCT e cmd == APCT e' cmd' = case testEquality e e' of - Just Refl -> cmd == cmd' +instance Eq AEvtTag where + AEvtTag e evt == AEvtTag e' evt' = case testEquality e e' of + Just Refl -> evt == evt' Nothing -> False -deriving instance Show (APartyCmdTag p) +deriving instance Show AEvtTag -data ACommandTag (p :: AParty) (e :: AEntity) where - NEW_ :: ACommandTag Client AEConn - INV_ :: ACommandTag Agent AEConn - JOIN_ :: ACommandTag Client AEConn - CONF_ :: ACommandTag Agent AEConn - LET_ :: ACommandTag Client AEConn - REQ_ :: ACommandTag Agent AEConn - ACPT_ :: ACommandTag Client AEConn - RJCT_ :: ACommandTag Client AEConn - INFO_ :: ACommandTag Agent AEConn - CON_ :: ACommandTag Agent AEConn - SUB_ :: ACommandTag Client AEConn - END_ :: ACommandTag Agent AEConn - CONNECT_ :: ACommandTag Agent AENone - DISCONNECT_ :: ACommandTag Agent AENone - DOWN_ :: ACommandTag Agent AENone - UP_ :: ACommandTag Agent AENone - SWITCH_ :: ACommandTag Agent AEConn - RSYNC_ :: ACommandTag Agent AEConn - SEND_ :: ACommandTag Client AEConn - MID_ :: ACommandTag Agent AEConn - SENT_ :: ACommandTag Agent AEConn - MERR_ :: ACommandTag Agent AEConn - MERRS_ :: ACommandTag Agent AEConn - MSG_ :: ACommandTag Agent AEConn - MSGNTF_ :: ACommandTag Agent AEConn - ACK_ :: ACommandTag Client AEConn - RCVD_ :: ACommandTag Agent AEConn - QCONT_ :: ACommandTag Agent AEConn - SWCH_ :: ACommandTag Client AEConn - OFF_ :: ACommandTag Client AEConn - DEL_ :: ACommandTag Client AEConn - DEL_RCVQ_ :: ACommandTag Agent AEConn - DEL_CONN_ :: ACommandTag Agent AEConn - DEL_USER_ :: ACommandTag Agent AENone - CHK_ :: ACommandTag Client AEConn - STAT_ :: ACommandTag Agent AEConn - OK_ :: ACommandTag Agent AEConn - ERR_ :: ACommandTag Agent AEConn - SUSPENDED_ :: ACommandTag Agent AENone +data ACommand + = NEW Bool AConnectionMode InitialKeys SubscriptionMode -- response INV + | JOIN Bool AConnectionRequestUri PQSupport SubscriptionMode ConnInfo + | LET ConfirmationId ConnInfo -- ConnInfo is from client + | ACK AgentMsgId (Maybe MsgReceiptInfo) + | SWCH + | DEL + deriving (Eq, Show) + +data ACommandTag + = NEW_ + | JOIN_ + | LET_ + | ACK_ + | SWCH_ + | DEL_ + deriving (Show) + +data AEventTag (e :: AEntity) where + INV_ :: AEventTag AEConn + CONF_ :: AEventTag AEConn + REQ_ :: AEventTag AEConn + INFO_ :: AEventTag AEConn + CON_ :: AEventTag AEConn + END_ :: AEventTag AEConn + CONNECT_ :: AEventTag AENone + DISCONNECT_ :: AEventTag AENone + DOWN_ :: AEventTag AENone + UP_ :: AEventTag AENone + SWITCH_ :: AEventTag AEConn + RSYNC_ :: AEventTag AEConn + SENT_ :: AEventTag AEConn + MWARN_ :: AEventTag AEConn + MERR_ :: AEventTag AEConn + MERRS_ :: AEventTag AEConn + MSG_ :: AEventTag AEConn + MSGNTF_ :: AEventTag AEConn + RCVD_ :: AEventTag AEConn + QCONT_ :: AEventTag AEConn + DEL_RCVQ_ :: AEventTag AEConn + DEL_CONN_ :: AEventTag AEConn + DEL_USER_ :: AEventTag AENone + STAT_ :: AEventTag AEConn + OK_ :: AEventTag AEConn + ERR_ :: AEventTag AEConn + SUSPENDED_ :: AEventTag AENone -- XFTP commands and responses - RFDONE_ :: ACommandTag Agent AERcvFile - RFPROG_ :: ACommandTag Agent AERcvFile - RFERR_ :: ACommandTag Agent AERcvFile - SFPROG_ :: ACommandTag Agent AESndFile - SFDONE_ :: ACommandTag Agent AESndFile - SFERR_ :: ACommandTag Agent AESndFile + RFDONE_ :: AEventTag AERcvFile + RFPROG_ :: AEventTag AERcvFile + RFERR_ :: AEventTag AERcvFile + RFWARN_ :: AEventTag AERcvFile + SFPROG_ :: AEventTag AESndFile + SFDONE_ :: AEventTag AESndFile + SFERR_ :: AEventTag AESndFile + SFWARN_ :: AEventTag AESndFile -deriving instance Eq (ACommandTag p e) +deriving instance Eq (AEventTag e) -deriving instance Show (ACommandTag p e) +deriving instance Show (AEventTag e) -aPartyCmdTag :: APartyCmd p -> APartyCmdTag p -aPartyCmdTag (APC e cmd) = APCT e $ aCommandTag cmd - -aCommandTag :: ACommand p e -> ACommandTag p e +aCommandTag :: ACommand -> ACommandTag aCommandTag = \case NEW {} -> NEW_ - INV _ -> INV_ JOIN {} -> JOIN_ - CONF {} -> CONF_ LET {} -> LET_ + ACK {} -> ACK_ + SWCH -> SWCH_ + DEL -> DEL_ + +aEventTag :: AEvent e -> AEventTag e +aEventTag = \case + INV _ -> INV_ + CONF {} -> CONF_ REQ {} -> REQ_ - ACPT {} -> ACPT_ - RJCT _ -> RJCT_ INFO {} -> INFO_ CON _ -> CON_ - SUB -> SUB_ END -> END_ CONNECT {} -> CONNECT_ DISCONNECT {} -> DISCONNECT_ @@ -510,23 +461,17 @@ aCommandTag = \case UP {} -> UP_ SWITCH {} -> SWITCH_ RSYNC {} -> RSYNC_ - SEND {} -> SEND_ - MID {} -> MID_ - SENT _ -> SENT_ + SENT {} -> SENT_ + MWARN {} -> MWARN_ MERR {} -> MERR_ MERRS {} -> MERRS_ MSG {} -> MSG_ MSGNTF {} -> MSGNTF_ - ACK {} -> ACK_ RCVD {} -> RCVD_ QCONT -> QCONT_ - SWCH -> SWCH_ - OFF -> OFF_ - DEL -> DEL_ DEL_RCVQ {} -> DEL_RCVQ_ DEL_CONN -> DEL_CONN_ DEL_USER _ -> DEL_USER_ - CHK -> CHK_ STAT _ -> STAT_ OK -> OK_ ERR _ -> ERR_ @@ -534,54 +479,18 @@ aCommandTag = \case RFPROG {} -> RFPROG_ RFDONE {} -> RFDONE_ RFERR {} -> RFERR_ + RFWARN {} -> RFWARN_ SFPROG {} -> SFPROG_ SFDONE {} -> SFDONE_ SFERR {} -> SFERR_ + SFWARN {} -> SFWARN_ data QueueDirection = QDRcv | QDSnd deriving (Eq, Show) -instance StrEncoding QueueDirection where - strEncode = \case - QDRcv -> "rcv" - QDSnd -> "snd" - strP = - A.takeTill (== ' ') >>= \case - "rcv" -> pure QDRcv - "snd" -> pure QDSnd - _ -> fail "bad QueueDirection" - -instance ToJSON QueueDirection where - toEncoding = strToJEncoding - toJSON = strToJSON - -instance FromJSON QueueDirection where - parseJSON = strParseJSON "QueueDirection" - data SwitchPhase = SPStarted | SPConfirmed | SPSecured | SPCompleted deriving (Eq, Show) -instance StrEncoding SwitchPhase where - strEncode = \case - SPStarted -> "started" - SPConfirmed -> "confirmed" - SPSecured -> "secured" - SPCompleted -> "completed" - strP = - A.takeTill (== ' ') >>= \case - "started" -> pure SPStarted - "confirmed" -> pure SPConfirmed - "secured" -> pure SPSecured - "completed" -> pure SPCompleted - _ -> fail "bad SwitchPhase" - -instance ToJSON SwitchPhase where - toEncoding = strToJEncoding - toJSON = strToJSON - -instance FromJSON SwitchPhase where - parseJSON = strParseJSON "SwitchPhase" - data RcvSwitchStatus = RSSwitchStarted | RSSendingQADD @@ -682,31 +591,12 @@ data RcvQueueInfo = RcvQueueInfo } deriving (Eq, Show) -instance StrEncoding RcvQueueInfo where - strEncode RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} = - ("srv=" <> strEncode rcvServer) - <> maybe "" (\switch -> ";switch=" <> strEncode switch) rcvSwitchStatus - <> (";can_abort_switch=" <> strEncode canAbortSwitch) - strP = do - rcvServer <- "srv=" *> strP - rcvSwitchStatus <- optional $ ";switch=" *> strP - canAbortSwitch <- ";can_abort_switch=" *> strP - pure RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} - data SndQueueInfo = SndQueueInfo { sndServer :: SMPServer, sndSwitchStatus :: Maybe SndSwitchStatus } deriving (Eq, Show) -instance StrEncoding SndQueueInfo where - strEncode SndQueueInfo {sndServer, sndSwitchStatus} = - "srv=" <> strEncode sndServer <> maybe "" (\switch -> ";switch=" <> strEncode switch) sndSwitchStatus - strP = do - sndServer <- "srv=" *> strP - sndSwitchStatus <- optional $ ";switch=" *> strP - pure SndQueueInfo {sndServer, sndSwitchStatus} - data ConnectionStats = ConnectionStats { connAgentVersion :: VersionSMPA, rcvQueuesInfo :: [RcvQueueInfo], @@ -716,21 +606,6 @@ data ConnectionStats = ConnectionStats } deriving (Eq, Show) -instance StrEncoding ConnectionStats where - strEncode ConnectionStats {connAgentVersion, rcvQueuesInfo, sndQueuesInfo, ratchetSyncState, ratchetSyncSupported} = - ("agent_version=" <> strEncode connAgentVersion) - <> (" rcv=" <> strEncodeList rcvQueuesInfo) - <> (" snd=" <> strEncodeList sndQueuesInfo) - <> (" sync=" <> strEncode ratchetSyncState) - <> (" sync_supported=" <> strEncode ratchetSyncSupported) - strP = do - connAgentVersion <- "agent_version=" *> strP - rcvQueuesInfo <- " rcv=" *> strListP - sndQueuesInfo <- " snd=" *> strListP - ratchetSyncState <- " sync=" *> strP - ratchetSyncSupported <- " sync_supported=" *> strP - pure ConnectionStats {connAgentVersion, rcvQueuesInfo, sndQueuesInfo, ratchetSyncState, ratchetSyncSupported} - data NotificationsMode = NMPeriodic | NMInstant deriving (Eq, Show) @@ -817,30 +692,9 @@ data MsgMeta = MsgMeta } deriving (Eq, Show) -instance StrEncoding MsgMeta where - strEncode MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId, pqEncryption} = - B.unwords - [ strEncode integrity, - "R=" <> bshow rmId <> "," <> showTs rTs, - "B=" <> encode bmId <> "," <> showTs bTs, - "S=" <> bshow sndMsgId, - "PQ=" <> strEncode pqEncryption - ] - where - showTs = B.pack . formatISO8601Millis - strP = do - integrity <- strP - recipient <- " R=" *> partyMeta A.decimal - broker <- " B=" *> partyMeta base64P - sndMsgId <- " S=" *> A.decimal - pqEncryption <- " PQ=" *> strP - pure MsgMeta {integrity, recipient, broker, sndMsgId, pqEncryption} - where - partyMeta idParser = (,) <$> idParser <* A.char ',' <*> tsISO8601P - data SMPConfirmation = SMPConfirmation { -- | sender's public key to use for authentication of sender's commands at the recepient's server - senderKey :: SndPublicAuthKey, + senderKey :: Maybe SndPublicAuthKey, -- | sender's DH public key for simple per-queue e2e encryption e2ePubKey :: C.PublicKeyX25519, -- | sender's information to be associated with the connection, e.g. sender's profile information @@ -908,7 +762,7 @@ instance Encoding AgentMsgEnvelope where -- AgentRatchetInfo is not encrypted with double ratchet, but with per-queue E2E encryption data AgentMessage = -- used by the initiating party when confirming reply queue - AgentConnInfo ConnInfo + AgentConnInfo ConnInfo | -- AgentConnInfoReply is used by accepting party in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation. -- It made removed REPLY message unnecessary. AgentConnInfoReply (NonEmpty SMPQueueInfo) ConnInfo @@ -930,12 +784,12 @@ instance Encoding AgentMessage where 'M' -> AgentMessage <$> smpP <*> smpP _ -> fail "bad AgentMessage" +-- internal type for storing message type in the database data AgentMessageType = AM_CONN_INFO | AM_CONN_INFO_REPLY | AM_RATCHET_INFO | AM_HELLO_ - | AM_REPLY_ | AM_A_MSG_ | AM_A_RCVD_ | AM_QCONT_ @@ -952,7 +806,6 @@ instance Encoding AgentMessageType where AM_CONN_INFO_REPLY -> "D" AM_RATCHET_INFO -> "S" AM_HELLO_ -> "H" - AM_REPLY_ -> "R" AM_A_MSG_ -> "M" AM_A_RCVD_ -> "V" AM_QCONT_ -> "QC" @@ -967,7 +820,6 @@ instance Encoding AgentMessageType where 'D' -> pure AM_CONN_INFO_REPLY 'S' -> pure AM_RATCHET_INFO 'H' -> pure AM_HELLO_ - 'R' -> pure AM_REPLY_ 'M' -> pure AM_A_MSG_ 'V' -> pure AM_A_RCVD_ 'Q' -> @@ -1148,15 +1000,7 @@ instance Encoding AMessageReceipt where (agentMsgId, msgHash, Large rcptInfo) <- smpP pure AMessageReceipt {agentMsgId, msgHash, rcptInfo} -instance StrEncoding MsgReceipt where - strEncode MsgReceipt {agentMsgId, msgRcptStatus} = - strEncode agentMsgId <> ":" <> strEncode msgRcptStatus - strP = do - agentMsgId <- strP <* A.char ':' - msgRcptStatus <- strP - pure MsgReceipt {agentMsgId, msgRcptStatus} - -instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where +instance ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where strEncode = \case CRInvitationUri crData e2eParams -> crEncode "invitation" crData (Just e2eParams) CRContactUri crData -> crEncode "contact" crData Nothing @@ -1167,37 +1011,46 @@ instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) whe where queryStr = strEncode . QSP QEscape $ - [("v", strEncode crAgentVRange), ("smp", strEncode crSmpQueues)] + -- semicolon is used to separate SMP queues because comma is used to separate server address hostnames + [("v", strEncode crAgentVRange), ("smp", B.intercalate ";" $ map strEncode $ L.toList crSmpQueues)] <> maybe [] (\e2e -> [("e2e", strEncode e2e)]) e2eParams <> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData - strP = do - ACR m cr <- strP - case testEquality m $ sConnectionMode @m of - Just Refl -> pure cr - _ -> fail "bad connection request mode" + strP = connReqUriP' (Just SSSimplex) + +connReqUriP' :: forall m. ConnectionModeI m => Maybe ServiceScheme -> Parser (ConnectionRequestUri m) +connReqUriP' overrideScheme = do + ACR m cr <- connReqUriP overrideScheme + case testEquality m $ sConnectionMode @m of + Just Refl -> pure cr + _ -> fail "bad connection request mode" instance StrEncoding AConnectionRequestUri where strEncode (ACR _ cr) = strEncode cr - strP = do - _crScheme :: ServiceScheme <- strP - crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?" - query <- strP - aVRange <- queryParam "v" query - crSmpQueues <- queryParam "smp" query - let crClientData = safeDecodeUtf8 <$> queryParamStr "data" query - let crData = ConnReqUriData {crScheme = SSSimplex, crAgentVRange = aVRange, crSmpQueues, crClientData} - case crMode of - CMInvitation -> do - crE2eParams <- queryParam "e2e" query - pure . ACR SCMInvitation $ CRInvitationUri crData crE2eParams - -- contact links are adjusted to the minimum version supported by the agent - -- to preserve compatibility with the old links published online - CMContact -> pure . ACR SCMContact $ CRContactUri crData {crAgentVRange = adjustAgentVRange aVRange} - where - crModeP = "invitation" $> CMInvitation <|> "contact" $> CMContact - adjustAgentVRange vr = - let v = max duplexHandshakeSMPAgentVersion $ minVersion vr - in fromMaybe vr $ safeVersionRange v (max v $ maxVersion vr) + strP = connReqUriP (Just SSSimplex) + +connReqUriP :: Maybe ServiceScheme -> Parser AConnectionRequestUri +connReqUriP overrideScheme = do + crScheme <- (`fromMaybe` overrideScheme) <$> strP + crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?" + query <- strP + aVRange <- queryParam "v" query + crSmpQueues <- queryParamParser queuesP "smp" query + let crClientData = safeDecodeUtf8 <$> queryParamStr "data" query + crData = ConnReqUriData {crScheme, crAgentVRange = aVRange, crSmpQueues, crClientData} + case crMode of + CMInvitation -> do + crE2eParams <- queryParam "e2e" query + pure . ACR SCMInvitation $ CRInvitationUri crData crE2eParams + -- contact links are adjusted to the minimum version supported by the agent + -- to preserve compatibility with the old links published online + CMContact -> pure . ACR SCMContact $ CRContactUri crData {crAgentVRange = adjustAgentVRange aVRange} + where + crModeP = "invitation" $> CMInvitation <|> "contact" $> CMContact + -- semicolon is used to separate SMP queues because comma is used to separate server address hostnames + queuesP = L.fromList <$> (strDecode <$?> A.takeTill (== ';')) `A.sepBy1'` A.char ';' + adjustAgentVRange vr = + let v = max minSupportedSMPAgentVersion $ minVersion vr + in fromMaybe vr $ safeVersionRange v (max v $ maxVersion vr) instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where parseJSON = strParseJSON "ConnectionRequestUri" @@ -1236,10 +1089,6 @@ connModeT = \case -- | SMP agent connection ID. type ConnId = ByteString -type RcvFileId = ByteString - -type SndFileId = ByteString - type ConfirmationId = ByteString type InvitationId = ByteString @@ -1278,14 +1127,16 @@ data SMPQueueInfo = SMPQueueInfo {clientVersion :: VersionSMPC, queueAddress :: deriving (Eq, Show) instance Encoding SMPQueueInfo where - smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey}) + smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}) + | clientVersion >= sndAuthKeySMPClientVersion && sndSecure = smpEncode (clientVersion, smpServer, senderId, dhPublicKey, sndSecure) | clientVersion > initialSMPClientVersion = smpEncode (clientVersion, smpServer, senderId, dhPublicKey) | otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey) smpP = do clientVersion <- smpP smpServer <- if clientVersion > initialSMPClientVersion then smpP else updateSMPServerHosts <$> legacyServerP (senderId, dhPublicKey) <- smpP - pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey} + sndSecure <- fromMaybe False <$> optional smpP + pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} -- This instance seems contrived and there was a temptation to split a common part of both types. -- But this is created to allow backward and forward compatibility where SMPQueueUri @@ -1300,6 +1151,7 @@ instance VersionRangeI SMPClientVersion SMPQueueUri where type VersionT SMPClientVersion SMPQueueUri = SMPQueueInfo versionRange = clientVRange toVersionT (SMPQueueUri _vr addr) v = SMPQueueInfo v addr + toVersionRange (SMPQueueUri _vr addr) vr = SMPQueueUri vr addr -- | SMP queue information sent out-of-band. -- @@ -1310,7 +1162,8 @@ data SMPQueueUri = SMPQueueUri {clientVRange :: VersionRangeSMPC, queueAddress : data SMPQueueAddress = SMPQueueAddress { smpServer :: SMPServer, senderId :: SMP.SenderId, - dhPublicKey :: C.PublicKeyX25519 + dhPublicKey :: C.PublicKeyX25519, + sndSecure :: Bool } deriving (Eq, Show) @@ -1337,37 +1190,42 @@ sameQAddress (srv, qId) (srv', qId') = sameSrvAddr srv srv' && qId == qId' {-# INLINE sameQAddress #-} instance StrEncoding SMPQueueUri where - strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey}) + strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey, sndSecure}) | minVersion vr >= srvHostnamesSMPClientVersion = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams | otherwise = legacyStrEncodeServer srv <> "/" <> strEncode qId <> "#/?" <> query (queryParams <> srvParam) where query = strEncode . QSP QEscape - queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] + queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] <> [("k", "s") | sndSecure] srvParam = [("srv", strEncode $ TransportHosts_ hs) | not (null hs)] hs = L.tail $ host srv strP = do srv@ProtocolServer {host = h :| host} <- strP <* A.char '/' senderId <- strP <* optional (A.char '/') <* A.char '#' - (vr, hs, dhPublicKey) <- unversioned <|> versioned + (vr, hs, dhPublicKey, sndSecure) <- versioned <|> unversioned let srv' = srv {host = h :| host <> hs} smpServer = if maxVersion vr < srvHostnamesSMPClientVersion then updateSMPServerHosts srv' else srv' - pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey} + pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} where - unversioned = (versionToRange initialSMPClientVersion,[],) <$> strP <* A.endOfInput + unversioned = (versionToRange initialSMPClientVersion,[],,False) <$> strP <* A.endOfInput versioned = do dhKey_ <- optional strP query <- optional (A.char '/') *> A.char '?' *> strP vr <- queryParam "v" query dhKey <- maybe (queryParam "dh" query) pure dhKey_ hs_ <- queryParam_ "srv" query - pure (vr, maybe [] thList_ hs_, dhKey) + let sndSecure = queryParamStr "k" query == Just "s" + pure (vr, maybe [] thList_ hs_, dhKey, sndSecure) instance Encoding SMPQueueUri where - smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey}) = - smpEncode (clientVRange, smpServer, senderId, dhPublicKey) + smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}) + | maxVersion clientVRange >= sndAuthKeySMPClientVersion && sndSecure = + smpEncode (clientVRange, smpServer, senderId, dhPublicKey, sndSecure) + | otherwise = + smpEncode (clientVRange, smpServer, senderId, dhPublicKey) smpP = do (clientVRange, smpServer, senderId, dhPublicKey) <- smpP - pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey} + sndSecure <- fromMaybe False <$> optional smpP + pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} data ConnectionRequestUri (m :: ConnectionMode) where CRInvitationUri :: ConnReqUriData -> RcvE2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation @@ -1382,9 +1240,9 @@ deriving instance Show (ConnectionRequestUri m) data AConnectionRequestUri = forall m. ConnectionModeI m => ACR (SConnectionMode m) (ConnectionRequestUri m) instance Eq AConnectionRequestUri where - ACR m cr == ACR m' cr' = case testEquality m m' of - Just Refl -> cr == cr' - _ -> False + ACR m cr == ACR m' cr' = case testEquality m m' of + Just Refl -> cr == cr' + _ -> False deriving instance Show AConnectionRequestUri @@ -1465,15 +1323,19 @@ instance StrEncoding MsgErrorType where -- | Error type used in errors sent to agent clients. data AgentErrorType = -- | command or response error - CMD {cmdErr :: CommandErrorType} + CMD {cmdErr :: CommandErrorType, errContext :: String} | -- | connection errors CONN {connErr :: ConnectionErrorType} | -- | SMP protocol errors forwarded to agent clients - SMP {smpErr :: ErrorType} + SMP {serverAddress :: String, smpErr :: ErrorType} | -- | NTF protocol errors forwarded to agent clients - NTF {ntfErr :: ErrorType} + NTF {serverAddress :: String, ntfErr :: ErrorType} | -- | XFTP protocol errors forwarded to agent clients - XFTP {xftpErr :: XFTPErrorType} + XFTP {serverAddress :: String, xftpErr :: XFTPErrorType} + | -- | XFTP agent errors + FILE {fileErr :: FileErrorType} + | -- | SMP proxy errors + PROXY {proxyServer :: String, relayServer :: String, proxyErr :: ProxyClientError} | -- | XRCP protocol errors forwarded to agent clients RCP {rcpErr :: RCErrorType} | -- | SMP server errors @@ -1516,28 +1378,12 @@ data ConnectionErrorType NOT_AVAILABLE deriving (Eq, Read, Show, Exception) --- | SMP server errors. -data BrokerErrorType - = -- | invalid server response (failed to parse) - RESPONSE {smpErr :: String} - | -- | unexpected response - UNEXPECTED - | -- | network error - NETWORK - | -- | no compatible server host (e.g. onion when public is required, or vice versa) - HOST - | -- | handshake or other transport error - TRANSPORT {transportErr :: TransportError} - | -- | command response timeout - TIMEOUT - deriving (Eq, Read, Show, Exception) - -- | Errors of another SMP agent. data SMPAgentError = -- | client or agent message that failed to parse A_MESSAGE | -- | prohibited SMP/agent message - A_PROHIBITED + A_PROHIBITED {prohibitedErr :: String} | -- | incompatible version of SMP client, agent or encryption protocols A_VERSION | -- | cannot decrypt message @@ -1564,60 +1410,6 @@ data AgentCryptoError RATCHET_SYNC deriving (Eq, Read, Show, Exception) -instance StrEncoding AgentCryptoError where - strP = - "DECRYPT_AES" $> DECRYPT_AES - <|> "DECRYPT_CB" $> DECRYPT_CB - <|> "RATCHET_HEADER" $> RATCHET_HEADER - <|> "RATCHET_EARLIER " *> (RATCHET_EARLIER <$> strP) - <|> "RATCHET_SKIPPED " *> (RATCHET_SKIPPED <$> strP) - <|> "RATCHET_SYNC" $> RATCHET_SYNC - strEncode = \case - DECRYPT_AES -> "DECRYPT_AES" - DECRYPT_CB -> "DECRYPT_CB" - RATCHET_HEADER -> "RATCHET_HEADER" - RATCHET_EARLIER n -> "RATCHET_EARLIER " <> strEncode n - RATCHET_SKIPPED n -> "RATCHET_SKIPPED " <> strEncode n - RATCHET_SYNC -> "RATCHET_SYNC" - -instance StrEncoding AgentErrorType where - strP = - "CMD " *> (CMD <$> parseRead1) - <|> "CONN " *> (CONN <$> parseRead1) - <|> "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) - <|> "AGENT CRYPTO " *> (AGENT . A_CRYPTO <$> parseRead A.takeByteString) - <|> "AGENT QUEUE " *> (AGENT . A_QUEUE <$> parseRead A.takeByteString) - <|> "AGENT " *> (AGENT <$> parseRead1) - <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString) - <|> "CRITICAL " *> (CRITICAL <$> parseRead1 <* A.space <*> parseRead A.takeByteString) - <|> "INACTIVE" $> INACTIVE - where - textP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ') - strEncode = \case - CMD e -> "CMD " <> bshow e - CONN e -> "CONN " <> bshow e - 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 - AGENT (A_CRYPTO e) -> "AGENT CRYPTO " <> bshow e - AGENT (A_QUEUE e) -> "AGENT QUEUE " <> bshow e - AGENT e -> "AGENT " <> bshow e - INTERNAL e -> "INTERNAL " <> bshow e - CRITICAL restart e -> "CRITICAL " <> bshow restart <> " " <> bshow e - INACTIVE -> "INACTIVE" - where - text = encodeUtf8 . T.pack - cryptoErrToSyncState :: AgentCryptoError -> RatchetSyncState cryptoErrToSyncState = \case DECRYPT_AES -> RSAllowed @@ -1627,187 +1419,38 @@ cryptoErrToSyncState = \case RATCHET_SKIPPED _ -> RSRequired RATCHET_SYNC -> RSRequired --- | SMP agent command and response parser for commands passed via network (only parses binary length) -networkCommandP :: Parser ACmd -networkCommandP = commandP A.takeByteString - -- | SMP agent command and response parser for commands stored in db (fully parses binary bodies) -dbCommandP :: Parser ACmd +dbCommandP :: Parser ACommand dbCommandP = commandP $ A.take =<< (A.decimal <* "\n") -instance StrEncoding ACmdTag where - strEncode (ACmdTag _ _ cmd) = strEncode cmd +instance StrEncoding ACommandTag where strP = A.takeTill (== ' ') >>= \case - "NEW" -> t NEW_ - "INV" -> ct INV_ - "JOIN" -> t JOIN_ - "CONF" -> ct CONF_ - "LET" -> t LET_ - "REQ" -> ct REQ_ - "ACPT" -> t ACPT_ - "RJCT" -> t RJCT_ - "INFO" -> ct INFO_ - "CON" -> ct CON_ - "SUB" -> t SUB_ - "END" -> ct END_ - "CONNECT" -> nt CONNECT_ - "DISCONNECT" -> nt DISCONNECT_ - "DOWN" -> nt DOWN_ - "UP" -> nt UP_ - "SWITCH" -> ct SWITCH_ - "RSYNC" -> ct RSYNC_ - "SEND" -> t SEND_ - "MID" -> ct MID_ - "SENT" -> ct SENT_ - "MERR" -> ct MERR_ - "MERRS" -> ct MERRS_ - "MSG" -> ct MSG_ - "MSGNTF" -> ct MSGNTF_ - "ACK" -> t ACK_ - "RCVD" -> ct RCVD_ - "QCONT" -> ct QCONT_ - "SWCH" -> t SWCH_ - "OFF" -> t OFF_ - "DEL" -> t DEL_ - "DEL_RCVQ" -> ct DEL_RCVQ_ - "DEL_CONN" -> ct DEL_CONN_ - "DEL_USER" -> nt DEL_USER_ - "CHK" -> t CHK_ - "STAT" -> ct STAT_ - "OK" -> ct OK_ - "ERR" -> ct ERR_ - "SUSPENDED" -> nt SUSPENDED_ - "RFPROG" -> at SAERcvFile RFPROG_ - "RFDONE" -> at SAERcvFile RFDONE_ - "RFERR" -> at SAERcvFile RFERR_ - "SFPROG" -> at SAESndFile SFPROG_ - "SFDONE" -> at SAESndFile SFDONE_ - "SFERR" -> at SAESndFile SFERR_ - _ -> fail "bad ACmdTag" - where - t = pure . ACmdTag SClient SAEConn - at e = pure . ACmdTag SAgent e - ct = at SAEConn - nt = at SAENone - -instance APartyI p => StrEncoding (APartyCmdTag p) where - strEncode (APCT _ cmd) = strEncode cmd - strP = (\(ACmdTag _ e t) -> checkParty $ APCT e t) <$?> strP - -instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where + "NEW" -> pure NEW_ + "JOIN" -> pure JOIN_ + "LET" -> pure LET_ + "ACK" -> pure ACK_ + "SWCH" -> pure SWCH_ + "DEL" -> pure DEL_ + _ -> fail "bad ACommandTag" strEncode = \case NEW_ -> "NEW" - INV_ -> "INV" JOIN_ -> "JOIN" - CONF_ -> "CONF" LET_ -> "LET" - REQ_ -> "REQ" - ACPT_ -> "ACPT" - RJCT_ -> "RJCT" - INFO_ -> "INFO" - CON_ -> "CON" - SUB_ -> "SUB" - END_ -> "END" - CONNECT_ -> "CONNECT" - DISCONNECT_ -> "DISCONNECT" - DOWN_ -> "DOWN" - UP_ -> "UP" - SWITCH_ -> "SWITCH" - RSYNC_ -> "RSYNC" - SEND_ -> "SEND" - MID_ -> "MID" - SENT_ -> "SENT" - MERR_ -> "MERR" - MERRS_ -> "MERRS" - MSG_ -> "MSG" - MSGNTF_ -> "MSGNTF" ACK_ -> "ACK" - RCVD_ -> "RCVD" - QCONT_ -> "QCONT" SWCH_ -> "SWCH" - OFF_ -> "OFF" DEL_ -> "DEL" - DEL_RCVQ_ -> "DEL_RCVQ" - DEL_CONN_ -> "DEL_CONN" - DEL_USER_ -> "DEL_USER" - CHK_ -> "CHK" - STAT_ -> "STAT" - OK_ -> "OK" - ERR_ -> "ERR" - SUSPENDED_ -> "SUSPENDED" - RFPROG_ -> "RFPROG" - RFDONE_ -> "RFDONE" - RFERR_ -> "RFERR" - SFPROG_ -> "SFPROG" - SFDONE_ -> "SFDONE" - SFERR_ -> "SFERR" - strP = (\(APCT _ t) -> checkEntity t) <$?> strP -checkParty :: forall t p p'. (APartyI p, APartyI p') => t p' -> Either String (t p) -checkParty x = case testEquality (sAParty @p) (sAParty @p') of - Just Refl -> Right x - Nothing -> Left "bad party" - -checkEntity :: forall t e e'. (AEntityI e, AEntityI e') => t e' -> Either String (t e) -checkEntity x = case testEquality (sAEntity @e) (sAEntity @e') of - Just Refl -> Right x - Nothing -> Left "bad entity" - --- | SMP agent command and response parser -commandP :: Parser ByteString -> Parser ACmd +commandP :: Parser ByteString -> Parser ACommand commandP binaryP = strP >>= \case - ACmdTag SClient e cmd -> - ACmd SClient e <$> case cmd of - NEW_ -> s (NEW <$> strP_ <*> strP_ <*> pqIKP <*> (strP <|> pure SMP.SMSubscribe)) - JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> pqSupP <*> (strP_ <|> pure SMP.SMSubscribe) <*> binaryP) - LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP) - ACPT_ -> s (ACPT <$> A.takeTill (== ' ') <* A.space <*> pqSupP <*> binaryP) - RJCT_ -> s (RJCT <$> A.takeByteString) - SUB_ -> pure SUB - SEND_ -> s (SEND <$> pqEncP <*> smpP <* A.space <*> binaryP) - ACK_ -> s (ACK <$> A.decimal <*> optional (A.space *> binaryP)) - SWCH_ -> pure SWCH - OFF_ -> pure OFF - DEL_ -> pure DEL - CHK_ -> pure CHK - ACmdTag SAgent e cmd -> - ACmd SAgent e <$> case cmd of - INV_ -> s (INV <$> strP) - CONF_ -> s (CONF <$> A.takeTill (== ' ') <* A.space <*> pqSupP <*> strListP <* A.space <*> binaryP) - REQ_ -> s (REQ <$> A.takeTill (== ' ') <* A.space <*> pqSupP <*> strP_ <*> binaryP) - INFO_ -> s (INFO <$> pqSupP <*> binaryP) - CON_ -> s (CON <$> strP) - END_ -> pure END - CONNECT_ -> s (CONNECT <$> strP_ <*> strP) - DISCONNECT_ -> s (DISCONNECT <$> strP_ <*> strP) - DOWN_ -> s (DOWN <$> strP_ <*> connections) - UP_ -> s (UP <$> strP_ <*> connections) - SWITCH_ -> s (SWITCH <$> strP_ <*> strP_ <*> strP) - RSYNC_ -> s (RSYNC <$> strP_ <*> strP <*> strP) - MID_ -> s (MID <$> A.decimal <*> _strP) - SENT_ -> s (SENT <$> A.decimal) - MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP) - MERRS_ -> s (MERRS <$> strP_ <*> strP) - MSG_ -> s (MSG <$> strP <* A.space <*> smpP <* A.space <*> binaryP) - MSGNTF_ -> s (MSGNTF <$> strP) - RCVD_ -> s (RCVD <$> strP <* A.space <*> strP) - QCONT_ -> pure QCONT - DEL_RCVQ_ -> s (DEL_RCVQ <$> strP_ <*> strP_ <*> strP) - DEL_CONN_ -> pure DEL_CONN - DEL_USER_ -> s (DEL_USER <$> strP) - STAT_ -> s (STAT <$> strP) - OK_ -> pure OK - ERR_ -> s (ERR <$> strP) - SUSPENDED_ -> pure SUSPENDED - RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal) - RFDONE_ -> s (RFDONE <$> strP) - RFERR_ -> s (RFERR <$> strP) - SFPROG_ -> s (SFPROG <$> A.decimal <* A.space <*> A.decimal) - SFDONE_ -> s (sfDone . safeDecodeUtf8 <$?> binaryP) - SFERR_ -> s (SFERR <$> strP) + NEW_ -> s (NEW <$> strP_ <*> strP_ <*> pqIKP <*> (strP <|> pure SMP.SMSubscribe)) + JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> pqSupP <*> (strP_ <|> pure SMP.SMSubscribe) <*> binaryP) + LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP) + ACK_ -> s (ACK <$> A.decimal <*> optional (A.space *> binaryP)) + SWCH_ -> pure SWCH + DEL_ -> pure DEL where s :: Parser a -> Parser a s p = A.space *> p @@ -1815,154 +1458,23 @@ commandP binaryP = pqIKP = strP_ <|> pure (IKNoPQ PQSupportOff) pqSupP :: Parser PQSupport pqSupP = strP_ <|> pure PQSupportOff - pqEncP :: Parser PQEncryption - pqEncP = strP_ <|> pure PQEncOff - connections :: Parser [ConnId] - connections = strP `A.sepBy'` A.char ',' - sfDone :: Text -> Either String (ACommand 'Agent 'AESndFile) - sfDone t = - let ds = T.splitOn fdSeparator t - in case ds of - [] -> Left "no sender file description" - sd : rds -> SFDONE <$> strDecode (encodeUtf8 sd) <*> mapM (strDecode . encodeUtf8) rds - -parseCommand :: ByteString -> Either AgentErrorType ACmd -parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX -- | Serialize SMP agent command. -serializeCommand :: ACommand p e -> ByteString +serializeCommand :: ACommand -> ByteString serializeCommand = \case NEW ntfs cMode pqIK subMode -> s (NEW_, ntfs, cMode, pqIK, subMode) - INV cReq -> s (INV_, cReq) JOIN ntfs cReq pqSup subMode cInfo -> s (JOIN_, ntfs, cReq, pqSup, subMode, Str $ serializeBinary cInfo) - CONF confId pqSup srvs cInfo -> B.unwords [s CONF_, confId, s pqSup, strEncodeList srvs, serializeBinary cInfo] LET confId cInfo -> B.unwords [s LET_, confId, serializeBinary cInfo] - REQ invId pqSup srvs cInfo -> B.unwords [s REQ_, invId, s pqSup, s srvs, serializeBinary cInfo] - ACPT invId pqSup cInfo -> B.unwords [s ACPT_, invId, s pqSup, serializeBinary cInfo] - RJCT invId -> B.unwords [s RJCT_, invId] - INFO pqSup cInfo -> B.unwords [s INFO_, s pqSup, serializeBinary cInfo] - SUB -> s SUB_ - END -> s END_ - CONNECT p h -> s (CONNECT_, p, h) - DISCONNECT p h -> s (DISCONNECT_, p, h) - DOWN srv conns -> B.unwords [s DOWN_, s srv, connections conns] - UP srv conns -> B.unwords [s UP_, s srv, connections conns] - SWITCH dir phase srvs -> s (SWITCH_, dir, phase, srvs) - RSYNC rrState cryptoErr cstats -> s (RSYNC_, rrState, cryptoErr, cstats) - SEND pqEnc msgFlags msgBody -> B.unwords [s SEND_, s pqEnc, smpEncode msgFlags, serializeBinary msgBody] - MID mId pqEnc -> s (MID_, mId, pqEnc) - SENT mId -> s (SENT_, mId) - MERR mId e -> s (MERR_, mId, e) - MERRS mIds e -> s (MERRS_, mIds, e) - MSG msgMeta msgFlags msgBody -> B.unwords [s MSG_, s msgMeta, smpEncode msgFlags, serializeBinary msgBody] - MSGNTF smpMsgMeta -> s (MSGNTF_, smpMsgMeta) ACK mId rcptInfo_ -> s (ACK_, mId) <> maybe "" (B.cons ' ' . serializeBinary) rcptInfo_ - RCVD msgMeta rcpts -> s (RCVD_, msgMeta, rcpts) - QCONT -> s QCONT_ SWCH -> s SWCH_ - OFF -> s OFF_ DEL -> s DEL_ - DEL_RCVQ srv rcvId err_ -> s (DEL_RCVQ_, srv, rcvId, err_) - DEL_CONN -> s DEL_CONN_ - DEL_USER userId -> s (DEL_USER_, userId) - CHK -> s CHK_ - STAT srvs -> s (STAT_, srvs) - CON pqEnc -> s (CON_, pqEnc) - ERR e -> s (ERR_, e) - OK -> s OK_ - SUSPENDED -> s SUSPENDED_ - RFPROG rcvd total -> s (RFPROG_, rcvd, total) - RFDONE fPath -> s (RFDONE_, fPath) - RFERR e -> s (RFERR_, e) - SFPROG sent total -> s (SFPROG_, sent, total) - SFDONE sd rds -> B.unwords [s SFDONE_, serializeBinary (sfDone sd rds)] - SFERR e -> s (SFERR_, e) where s :: StrEncoding a => a -> ByteString s = strEncode - connections :: [ConnId] -> ByteString - connections = B.intercalate "," . map strEncode - sfDone sd rds = B.intercalate fdSeparator $ strEncode sd : map strEncode rds serializeBinary :: ByteString -> ByteString serializeBinary body = bshow (B.length body) <> "\n" <> body --- | Send raw (unparsed) SMP agent protocol transmission to TCP connection. -tPutRaw :: Transport c => c -> ARawTransmission -> IO () -tPutRaw h (corrId, entity, command) = do - putLn h corrId - putLn h entity - putLn h command - --- | Receive raw (unparsed) SMP agent protocol transmission from TCP connection. -tGetRaw :: Transport c => c -> IO ARawTransmission -tGetRaw h = (,,) <$> getLn h <*> getLn h <*> getLn h - --- | Send SMP agent protocol command (or response) to TCP connection. -tPut :: Transport c => c -> ATransmission p -> IO () -tPut h (corrId, connId, APC _ cmd) = - tPutRaw h (corrId, connId, serializeCommand cmd) - --- | Receive client and agent transmissions from TCP connection. -tGet :: forall c p. Transport c => SAParty p -> c -> IO (ATransmissionOrError p) -tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody - where - tParseLoadBody :: ARawTransmission -> IO (ATransmissionOrError p) - tParseLoadBody t@(corrId, entId, command) = do - let cmd = parseCommand command >>= fromParty >>= tConnId t - fullCmd <- either (return . Left) cmdWithMsgBody cmd - return (corrId, entId, fullCmd) - - fromParty :: ACmd -> Either AgentErrorType (APartyCmd p) - fromParty (ACmd (p :: p1) e cmd) = case testEquality party p of - Just Refl -> Right $ APC e cmd - _ -> Left $ CMD PROHIBITED - - tConnId :: ARawTransmission -> APartyCmd p -> Either AgentErrorType (APartyCmd p) - tConnId (_, entId, _) (APC e cmd) = - APC e <$> case cmd of - -- NEW, JOIN and ACPT have optional connection ID - NEW {} -> Right cmd - JOIN {} -> Right cmd - ACPT {} -> Right cmd - -- ERROR response does not always have connection ID - ERR _ -> Right cmd - CONNECT {} -> Right cmd - DISCONNECT {} -> Right cmd - DOWN {} -> Right cmd - UP {} -> Right cmd - SUSPENDED {} -> Right cmd - -- other responses must have connection ID - _ - | B.null entId -> Left $ CMD NO_CONN - | otherwise -> Right cmd - - cmdWithMsgBody :: APartyCmd p -> IO (Either AgentErrorType (APartyCmd p)) - cmdWithMsgBody (APC e cmd) = - APC e <$$> case cmd of - SEND pqEnc msgFlags body -> SEND pqEnc msgFlags <$$> getBody body - MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body - JOIN ntfs qUri pqSup subMode cInfo -> JOIN ntfs qUri pqSup subMode <$$> getBody cInfo - CONF confId pqSup srvs cInfo -> CONF confId pqSup srvs <$$> getBody cInfo - LET confId cInfo -> LET confId <$$> getBody cInfo - REQ invId pqSup srvs cInfo -> REQ invId pqSup srvs <$$> getBody cInfo - ACPT invId pqSup cInfo -> ACPT invId pqSup <$$> getBody cInfo - INFO pqSup cInfo -> INFO pqSup <$$> getBody cInfo - _ -> pure $ Right cmd - - getBody :: ByteString -> IO (Either AgentErrorType ByteString) - getBody binary = - case B.unpack binary of - ':' : body -> return . Right $ B.pack body - str -> case readMaybe str :: Maybe Int of - Just size -> runExceptT $ do - body <- liftIO $ cGet h size - unless (B.length body == size) $ throwError $ CMD SIZE - s <- liftIO $ getLn h - unless (B.null s) $ throwError $ CMD SIZE - pure body - Nothing -> return . Left $ CMD SYNTAX - $(J.deriveJSON defaultJSON ''RcvQueueInfo) $(J.deriveJSON defaultJSON ''SndQueueInfo) @@ -1977,10 +1489,12 @@ $(J.deriveJSON (sumTypeJSON id) ''CommandErrorType) $(J.deriveJSON (sumTypeJSON id) ''ConnectionErrorType) -$(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType) - $(J.deriveJSON (sumTypeJSON id) ''AgentCryptoError) $(J.deriveJSON (sumTypeJSON id) ''SMPAgentError) $(J.deriveJSON (sumTypeJSON id) ''AgentErrorType) + +$(J.deriveJSON (enumJSON $ dropPrefix "QD") ''QueueDirection) + +$(J.deriveJSON (enumJSON $ dropPrefix "SP") ''SwitchPhase) diff --git a/src/Simplex/Messaging/Agent/QueryString.hs b/src/Simplex/Messaging/Agent/QueryString.hs index fee552a01..9dc0e94a9 100644 --- a/src/Simplex/Messaging/Agent/QueryString.hs +++ b/src/Simplex/Messaging/Agent/QueryString.hs @@ -24,9 +24,12 @@ instance StrEncoding QueryStringParams where strP = QSP QEscape . Q.parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n') queryParam :: StrEncoding a => ByteString -> QueryStringParams -> Parser a -queryParam name q = +queryParam = queryParamParser strP + +queryParamParser :: Parser a -> ByteString -> QueryStringParams -> Parser a +queryParamParser p name q = case queryParamStr name q of - Just p -> either fail pure $ parseAll strP p + Just s -> either fail pure $ parseAll p s _ -> fail $ "no qs param " <> B.unpack name queryParam_ :: StrEncoding a => ByteString -> QueryStringParams -> Parser (Maybe a) diff --git a/src/Simplex/Messaging/Agent/Server.hs b/src/Simplex/Messaging/Agent/Server.hs deleted file mode 100644 index 368c0a23d..000000000 --- a/src/Simplex/Messaging/Agent/Server.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Simplex.Messaging.Agent.Server - ( -- * SMP agent over TCP - runSMPAgent, - runSMPAgentBlocking, - ) -where - -import Control.Logger.Simple (logInfo) -import Control.Monad -import Control.Monad.Reader -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Text.Encoding (decodeUtf8) -import Network.Socket (ServiceName) -import Simplex.Messaging.Agent -import Simplex.Messaging.Agent.Client (newAgentClient) -import Simplex.Messaging.Agent.Env.SQLite -import Simplex.Messaging.Agent.Protocol -import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore) -import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), simplexMQVersion) -import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, loadTLSServerParams, runTransportServer) -import Simplex.Messaging.Util (bshow) -import UnliftIO.Async (race_) -import qualified UnliftIO.Exception as E -import UnliftIO.STM - --- | Runs an SMP agent as a TCP service using passed configuration. --- --- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs -runSMPAgent :: ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> IO () -runSMPAgent t cfg initServers store = - runSMPAgentBlocking t cfg initServers store 0 =<< newEmptyTMVarIO - --- | Runs an SMP agent as a TCP service using passed configuration with signalling. --- --- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True) --- and when it is disconnected from the TCP socket once the server thread is killed (False). -runSMPAgentBlocking :: ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> Int -> TMVar Bool -> IO () -runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers store initClientId started = - case tcpPort of - Just port -> newSMPAgentEnv cfg store >>= smpAgent t port - Nothing -> E.throwIO $ userError "no agent port" - where - smpAgent :: forall c. Transport c => TProxy c -> ServiceName -> Env -> IO () - smpAgent _ port env = do - -- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation - tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile - clientId <- newTVarIO initClientId - runTransportServer started port tlsServerParams defaultTransportServerConfig $ \(h :: c) -> do - putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion - cId <- atomically $ stateTVar clientId $ \i -> (i + 1, i + 1) - c <- atomically $ newAgentClient cId initServers env - logConnection c True - race_ (connectClient h c) (runAgentClient c `runReaderT` env) - `E.finally` (disconnectAgentClient c) - -connectClient :: Transport c => c -> AgentClient -> IO () -connectClient h c = race_ (send h c) (receive h c) - -receive :: forall c. Transport c => c -> AgentClient -> IO () -receive h c@AgentClient {rcvQ, subQ} = forever $ do - (corrId, entId, cmdOrErr) <- tGet SClient h - case cmdOrErr of - Right cmd -> write rcvQ (corrId, entId, cmd) - Left e -> write subQ (corrId, entId, APC SAEConn $ ERR e) - where - write :: TBQueue (ATransmission p) -> ATransmission p -> IO () - write q t = do - logClient c "-->" t - atomically $ writeTBQueue q t - -send :: Transport c => c -> AgentClient -> IO () -send h c@AgentClient {subQ} = forever $ do - t <- atomically $ readTBQueue subQ - tPut h t - logClient c "<--" t - -logClient :: AgentClient -> ByteString -> ATransmission a -> IO () -logClient AgentClient {clientId} dir (corrId, connId, APC _ cmd) = do - logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, connId, B.takeWhile (/= ' ') $ serializeCommand cmd] diff --git a/src/Simplex/Messaging/Agent/Stats.hs b/src/Simplex/Messaging/Agent/Stats.hs new file mode 100644 index 000000000..424052d74 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Stats.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Messaging.Agent.Stats where + +import qualified Data.Aeson.TH as J +import Data.Int (Int64) +import Data.Map (Map) +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +import Simplex.Messaging.Agent.Protocol (UserId) +import Simplex.Messaging.Parsers (defaultJSON, fromTextField_) +import Simplex.Messaging.Protocol (SMPServer, XFTPServer) +import Simplex.Messaging.Util (decodeJSON, encodeJSON) +import UnliftIO.STM + +data AgentSMPServerStats = AgentSMPServerStats + { sentDirect :: TVar Int, -- successfully sent messages + sentViaProxy :: TVar Int, -- successfully sent messages via proxy + sentProxied :: TVar Int, -- successfully sent messages to other destination server via this as proxy + sentDirectAttempts :: TVar Int, -- direct sending attempts (min 1 for each sent message) + sentViaProxyAttempts :: TVar Int, -- proxy sending attempts + sentProxiedAttempts :: TVar Int, -- attempts sending to other destination server via this as proxy + sentAuthErrs :: TVar Int, -- send AUTH errors + sentQuotaErrs :: TVar Int, -- send QUOTA permanent errors (message expired) + sentExpiredErrs :: TVar Int, -- send expired errors + sentOtherErrs :: TVar Int, -- other send permanent errors (excluding above) + recvMsgs :: TVar Int, -- total messages received + recvDuplicates :: TVar Int, -- duplicate messages received + recvCryptoErrs :: TVar Int, -- message decryption errors + recvErrs :: TVar Int, -- receive errors + ackMsgs :: TVar Int, -- total messages acknowledged + ackAttempts :: TVar Int, -- acknowledgement attempts + ackNoMsgErrs :: TVar Int, -- NO_MSG ack errors + ackOtherErrs :: TVar Int, -- other permanent ack errors (temporary accounted for in attempts) + -- conn stats are accounted for rcv queue server + connCreated :: TVar Int, -- total connections created + connSecured :: TVar Int, -- connections secured + connCompleted :: TVar Int, -- connections completed + connDeleted :: TVar Int, -- total connections deleted + connDelAttempts :: TVar Int, -- total connection deletion attempts + connDelErrs :: TVar Int, -- permanent connection deletion errors (temporary accounted for in attempts) + connSubscribed :: TVar Int, -- total successful subscription + connSubAttempts :: TVar Int, -- subscription attempts + connSubIgnored :: TVar Int, -- subscription results ignored (client switched to different session or it was not pending) + connSubErrs :: TVar Int -- permanent subscription errors (temporary accounted for in attempts) + } + +data AgentSMPServerStatsData = AgentSMPServerStatsData + { _sentDirect :: Int, + _sentViaProxy :: Int, + _sentProxied :: Int, + _sentDirectAttempts :: Int, + _sentViaProxyAttempts :: Int, + _sentProxiedAttempts :: Int, + _sentAuthErrs :: Int, + _sentQuotaErrs :: Int, + _sentExpiredErrs :: Int, + _sentOtherErrs :: Int, + _recvMsgs :: Int, + _recvDuplicates :: Int, + _recvCryptoErrs :: Int, + _recvErrs :: Int, + _ackMsgs :: Int, + _ackAttempts :: Int, + _ackNoMsgErrs :: Int, + _ackOtherErrs :: Int, + _connCreated :: Int, + _connSecured :: Int, + _connCompleted :: Int, + _connDeleted :: Int, + _connDelAttempts :: Int, + _connDelErrs :: Int, + _connSubscribed :: Int, + _connSubAttempts :: Int, + _connSubIgnored :: Int, + _connSubErrs :: Int + } + deriving (Show) + +newAgentSMPServerStats :: STM AgentSMPServerStats +newAgentSMPServerStats = do + sentDirect <- newTVar 0 + sentViaProxy <- newTVar 0 + sentProxied <- newTVar 0 + sentDirectAttempts <- newTVar 0 + sentViaProxyAttempts <- newTVar 0 + sentProxiedAttempts <- newTVar 0 + sentAuthErrs <- newTVar 0 + sentQuotaErrs <- newTVar 0 + sentExpiredErrs <- newTVar 0 + sentOtherErrs <- newTVar 0 + recvMsgs <- newTVar 0 + recvDuplicates <- newTVar 0 + recvCryptoErrs <- newTVar 0 + recvErrs <- newTVar 0 + ackMsgs <- newTVar 0 + ackAttempts <- newTVar 0 + ackNoMsgErrs <- newTVar 0 + ackOtherErrs <- newTVar 0 + connCreated <- newTVar 0 + connSecured <- newTVar 0 + connCompleted <- newTVar 0 + connDeleted <- newTVar 0 + connDelAttempts <- newTVar 0 + connDelErrs <- newTVar 0 + connSubscribed <- newTVar 0 + connSubAttempts <- newTVar 0 + connSubIgnored <- newTVar 0 + connSubErrs <- newTVar 0 + pure + AgentSMPServerStats + { sentDirect, + sentViaProxy, + sentProxied, + sentDirectAttempts, + sentViaProxyAttempts, + sentProxiedAttempts, + sentAuthErrs, + sentQuotaErrs, + sentExpiredErrs, + sentOtherErrs, + recvMsgs, + recvDuplicates, + recvCryptoErrs, + recvErrs, + ackMsgs, + ackAttempts, + ackNoMsgErrs, + ackOtherErrs, + connCreated, + connSecured, + connCompleted, + connDeleted, + connDelAttempts, + connDelErrs, + connSubscribed, + connSubAttempts, + connSubIgnored, + connSubErrs + } + +newAgentSMPServerStatsData :: AgentSMPServerStatsData +newAgentSMPServerStatsData = + AgentSMPServerStatsData + { _sentDirect = 0, + _sentViaProxy = 0, + _sentProxied = 0, + _sentDirectAttempts = 0, + _sentViaProxyAttempts = 0, + _sentProxiedAttempts = 0, + _sentAuthErrs = 0, + _sentQuotaErrs = 0, + _sentExpiredErrs = 0, + _sentOtherErrs = 0, + _recvMsgs = 0, + _recvDuplicates = 0, + _recvCryptoErrs = 0, + _recvErrs = 0, + _ackMsgs = 0, + _ackAttempts = 0, + _ackNoMsgErrs = 0, + _ackOtherErrs = 0, + _connCreated = 0, + _connSecured = 0, + _connCompleted = 0, + _connDeleted = 0, + _connDelAttempts = 0, + _connDelErrs = 0, + _connSubscribed = 0, + _connSubAttempts = 0, + _connSubIgnored = 0, + _connSubErrs = 0 + } + +newAgentSMPServerStats' :: AgentSMPServerStatsData -> STM AgentSMPServerStats +newAgentSMPServerStats' s = do + sentDirect <- newTVar $ _sentDirect s + sentViaProxy <- newTVar $ _sentViaProxy s + sentProxied <- newTVar $ _sentProxied s + sentDirectAttempts <- newTVar $ _sentDirectAttempts s + sentViaProxyAttempts <- newTVar $ _sentViaProxyAttempts s + sentProxiedAttempts <- newTVar $ _sentProxiedAttempts s + sentAuthErrs <- newTVar $ _sentAuthErrs s + sentQuotaErrs <- newTVar $ _sentQuotaErrs s + sentExpiredErrs <- newTVar $ _sentExpiredErrs s + sentOtherErrs <- newTVar $ _sentOtherErrs s + recvMsgs <- newTVar $ _recvMsgs s + recvDuplicates <- newTVar $ _recvDuplicates s + recvCryptoErrs <- newTVar $ _recvCryptoErrs s + recvErrs <- newTVar $ _recvErrs s + ackMsgs <- newTVar $ _ackMsgs s + ackAttempts <- newTVar $ _ackAttempts s + ackNoMsgErrs <- newTVar $ _ackNoMsgErrs s + ackOtherErrs <- newTVar $ _ackOtherErrs s + connCreated <- newTVar $ _connCreated s + connSecured <- newTVar $ _connSecured s + connCompleted <- newTVar $ _connCompleted s + connDeleted <- newTVar $ _connDeleted s + connDelAttempts <- newTVar $ _connDelAttempts s + connDelErrs <- newTVar $ _connDelErrs s + connSubscribed <- newTVar $ _connSubscribed s + connSubAttempts <- newTVar $ _connSubAttempts s + connSubIgnored <- newTVar $ _connSubIgnored s + connSubErrs <- newTVar $ _connSubErrs s + pure + AgentSMPServerStats + { sentDirect, + sentViaProxy, + sentProxied, + sentDirectAttempts, + sentViaProxyAttempts, + sentProxiedAttempts, + sentAuthErrs, + sentQuotaErrs, + sentExpiredErrs, + sentOtherErrs, + recvMsgs, + recvDuplicates, + recvCryptoErrs, + recvErrs, + ackMsgs, + ackAttempts, + ackNoMsgErrs, + ackOtherErrs, + connCreated, + connSecured, + connCompleted, + connDeleted, + connDelAttempts, + connDelErrs, + connSubscribed, + connSubAttempts, + connSubIgnored, + connSubErrs + } + +-- as this is used to periodically update stats in db, +-- this is not STM to decrease contention with stats updates +getAgentSMPServerStats :: AgentSMPServerStats -> IO AgentSMPServerStatsData +getAgentSMPServerStats s = do + _sentDirect <- readTVarIO $ sentDirect s + _sentViaProxy <- readTVarIO $ sentViaProxy s + _sentProxied <- readTVarIO $ sentProxied s + _sentDirectAttempts <- readTVarIO $ sentDirectAttempts s + _sentViaProxyAttempts <- readTVarIO $ sentViaProxyAttempts s + _sentProxiedAttempts <- readTVarIO $ sentProxiedAttempts s + _sentAuthErrs <- readTVarIO $ sentAuthErrs s + _sentQuotaErrs <- readTVarIO $ sentQuotaErrs s + _sentExpiredErrs <- readTVarIO $ sentExpiredErrs s + _sentOtherErrs <- readTVarIO $ sentOtherErrs s + _recvMsgs <- readTVarIO $ recvMsgs s + _recvDuplicates <- readTVarIO $ recvDuplicates s + _recvCryptoErrs <- readTVarIO $ recvCryptoErrs s + _recvErrs <- readTVarIO $ recvErrs s + _ackMsgs <- readTVarIO $ ackMsgs s + _ackAttempts <- readTVarIO $ ackAttempts s + _ackNoMsgErrs <- readTVarIO $ ackNoMsgErrs s + _ackOtherErrs <- readTVarIO $ ackOtherErrs s + _connCreated <- readTVarIO $ connCreated s + _connSecured <- readTVarIO $ connSecured s + _connCompleted <- readTVarIO $ connCompleted s + _connDeleted <- readTVarIO $ connDeleted s + _connDelAttempts <- readTVarIO $ connDelAttempts s + _connDelErrs <- readTVarIO $ connDelErrs s + _connSubscribed <- readTVarIO $ connSubscribed s + _connSubAttempts <- readTVarIO $ connSubAttempts s + _connSubIgnored <- readTVarIO $ connSubIgnored s + _connSubErrs <- readTVarIO $ connSubErrs s + pure + AgentSMPServerStatsData + { _sentDirect, + _sentViaProxy, + _sentProxied, + _sentDirectAttempts, + _sentViaProxyAttempts, + _sentProxiedAttempts, + _sentAuthErrs, + _sentQuotaErrs, + _sentExpiredErrs, + _sentOtherErrs, + _recvMsgs, + _recvDuplicates, + _recvCryptoErrs, + _recvErrs, + _ackMsgs, + _ackAttempts, + _ackNoMsgErrs, + _ackOtherErrs, + _connCreated, + _connSecured, + _connCompleted, + _connDeleted, + _connDelAttempts, + _connDelErrs, + _connSubscribed, + _connSubAttempts, + _connSubIgnored, + _connSubErrs + } + +addSMPStatsData :: AgentSMPServerStatsData -> AgentSMPServerStatsData -> AgentSMPServerStatsData +addSMPStatsData sd1 sd2 = + AgentSMPServerStatsData + { _sentDirect = _sentDirect sd1 + _sentDirect sd2, + _sentViaProxy = _sentViaProxy sd1 + _sentViaProxy sd2, + _sentProxied = _sentProxied sd1 + _sentProxied sd2, + _sentDirectAttempts = _sentDirectAttempts sd1 + _sentDirectAttempts sd2, + _sentViaProxyAttempts = _sentViaProxyAttempts sd1 + _sentViaProxyAttempts sd2, + _sentProxiedAttempts = _sentProxiedAttempts sd1 + _sentProxiedAttempts sd2, + _sentAuthErrs = _sentAuthErrs sd1 + _sentAuthErrs sd2, + _sentQuotaErrs = _sentQuotaErrs sd1 + _sentQuotaErrs sd2, + _sentExpiredErrs = _sentExpiredErrs sd1 + _sentExpiredErrs sd2, + _sentOtherErrs = _sentOtherErrs sd1 + _sentOtherErrs sd2, + _recvMsgs = _recvMsgs sd1 + _recvMsgs sd2, + _recvDuplicates = _recvDuplicates sd1 + _recvDuplicates sd2, + _recvCryptoErrs = _recvCryptoErrs sd1 + _recvCryptoErrs sd2, + _recvErrs = _recvErrs sd1 + _recvErrs sd2, + _ackMsgs = _ackMsgs sd1 + _ackMsgs sd2, + _ackAttempts = _ackAttempts sd1 + _ackAttempts sd2, + _ackNoMsgErrs = _ackNoMsgErrs sd1 + _ackNoMsgErrs sd2, + _ackOtherErrs = _ackOtherErrs sd1 + _ackOtherErrs sd2, + _connCreated = _connCreated sd1 + _connCreated sd2, + _connSecured = _connSecured sd1 + _connSecured sd2, + _connCompleted = _connCompleted sd1 + _connCompleted sd2, + _connDeleted = _connDeleted sd1 + _connDeleted sd2, + _connDelAttempts = _connDelAttempts sd1 + _connDelAttempts sd2, + _connDelErrs = _connDelErrs sd1 + _connDelErrs sd2, + _connSubscribed = _connSubscribed sd1 + _connSubscribed sd2, + _connSubAttempts = _connSubAttempts sd1 + _connSubAttempts sd2, + _connSubIgnored = _connSubIgnored sd1 + _connSubIgnored sd2, + _connSubErrs = _connSubErrs sd1 + _connSubErrs sd2 + } + +data AgentXFTPServerStats = AgentXFTPServerStats + { uploads :: TVar Int, -- total replicas uploaded to server + uploadsSize :: TVar Int64, -- total size of uploaded replicas in KB + uploadAttempts :: TVar Int, -- upload attempts + uploadErrs :: TVar Int, -- upload errors + downloads :: TVar Int, -- total replicas downloaded from server + downloadsSize :: TVar Int64, -- total size of downloaded replicas in KB + downloadAttempts :: TVar Int, -- download attempts + downloadAuthErrs :: TVar Int, -- download AUTH errors + downloadErrs :: TVar Int, -- other download errors (excluding above) + deletions :: TVar Int, -- total replicas deleted from server + deleteAttempts :: TVar Int, -- delete attempts + deleteErrs :: TVar Int -- delete errors + } + +data AgentXFTPServerStatsData = AgentXFTPServerStatsData + { _uploads :: Int, + _uploadsSize :: Int64, + _uploadAttempts :: Int, + _uploadErrs :: Int, + _downloads :: Int, + _downloadsSize :: Int64, + _downloadAttempts :: Int, + _downloadAuthErrs :: Int, + _downloadErrs :: Int, + _deletions :: Int, + _deleteAttempts :: Int, + _deleteErrs :: Int + } + deriving (Show) + +newAgentXFTPServerStats :: STM AgentXFTPServerStats +newAgentXFTPServerStats = do + uploads <- newTVar 0 + uploadsSize <- newTVar 0 + uploadAttempts <- newTVar 0 + uploadErrs <- newTVar 0 + downloads <- newTVar 0 + downloadsSize <- newTVar 0 + downloadAttempts <- newTVar 0 + downloadAuthErrs <- newTVar 0 + downloadErrs <- newTVar 0 + deletions <- newTVar 0 + deleteAttempts <- newTVar 0 + deleteErrs <- newTVar 0 + pure + AgentXFTPServerStats + { uploads, + uploadsSize, + uploadAttempts, + uploadErrs, + downloads, + downloadsSize, + downloadAttempts, + downloadAuthErrs, + downloadErrs, + deletions, + deleteAttempts, + deleteErrs + } + +newAgentXFTPServerStatsData :: AgentXFTPServerStatsData +newAgentXFTPServerStatsData = + AgentXFTPServerStatsData + { _uploads = 0, + _uploadsSize = 0, + _uploadAttempts = 0, + _uploadErrs = 0, + _downloads = 0, + _downloadsSize = 0, + _downloadAttempts = 0, + _downloadAuthErrs = 0, + _downloadErrs = 0, + _deletions = 0, + _deleteAttempts = 0, + _deleteErrs = 0 + } + +newAgentXFTPServerStats' :: AgentXFTPServerStatsData -> STM AgentXFTPServerStats +newAgentXFTPServerStats' s = do + uploads <- newTVar $ _uploads s + uploadsSize <- newTVar $ _uploadsSize s + uploadAttempts <- newTVar $ _uploadAttempts s + uploadErrs <- newTVar $ _uploadErrs s + downloads <- newTVar $ _downloads s + downloadsSize <- newTVar $ _downloadsSize s + downloadAttempts <- newTVar $ _downloadAttempts s + downloadAuthErrs <- newTVar $ _downloadAuthErrs s + downloadErrs <- newTVar $ _downloadErrs s + deletions <- newTVar $ _deletions s + deleteAttempts <- newTVar $ _deleteAttempts s + deleteErrs <- newTVar $ _deleteErrs s + pure + AgentXFTPServerStats + { uploads, + uploadsSize, + uploadAttempts, + uploadErrs, + downloads, + downloadsSize, + downloadAttempts, + downloadAuthErrs, + downloadErrs, + deletions, + deleteAttempts, + deleteErrs + } + +-- as this is used to periodically update stats in db, +-- this is not STM to decrease contention with stats updates +getAgentXFTPServerStats :: AgentXFTPServerStats -> IO AgentXFTPServerStatsData +getAgentXFTPServerStats s = do + _uploads <- readTVarIO $ uploads s + _uploadsSize <- readTVarIO $ uploadsSize s + _uploadAttempts <- readTVarIO $ uploadAttempts s + _uploadErrs <- readTVarIO $ uploadErrs s + _downloads <- readTVarIO $ downloads s + _downloadsSize <- readTVarIO $ downloadsSize s + _downloadAttempts <- readTVarIO $ downloadAttempts s + _downloadAuthErrs <- readTVarIO $ downloadAuthErrs s + _downloadErrs <- readTVarIO $ downloadErrs s + _deletions <- readTVarIO $ deletions s + _deleteAttempts <- readTVarIO $ deleteAttempts s + _deleteErrs <- readTVarIO $ deleteErrs s + pure + AgentXFTPServerStatsData + { _uploads, + _uploadsSize, + _uploadAttempts, + _uploadErrs, + _downloads, + _downloadsSize, + _downloadAttempts, + _downloadAuthErrs, + _downloadErrs, + _deletions, + _deleteAttempts, + _deleteErrs + } + +addXFTPStatsData :: AgentXFTPServerStatsData -> AgentXFTPServerStatsData -> AgentXFTPServerStatsData +addXFTPStatsData sd1 sd2 = + AgentXFTPServerStatsData + { _uploads = _uploads sd1 + _uploads sd2, + _uploadsSize = _uploadsSize sd1 + _uploadsSize sd2, + _uploadAttempts = _uploadAttempts sd1 + _uploadAttempts sd2, + _uploadErrs = _uploadErrs sd1 + _uploadErrs sd2, + _downloads = _downloads sd1 + _downloads sd2, + _downloadsSize = _downloadsSize sd1 + _downloadsSize sd2, + _downloadAttempts = _downloadAttempts sd1 + _downloadAttempts sd2, + _downloadAuthErrs = _downloadAuthErrs sd1 + _downloadAuthErrs sd2, + _downloadErrs = _downloadErrs sd1 + _downloadErrs sd2, + _deletions = _deletions sd1 + _deletions sd2, + _deleteAttempts = _deleteAttempts sd1 + _deleteAttempts sd2, + _deleteErrs = _deleteErrs sd1 + _deleteErrs sd2 + } + +-- Type for gathering both smp and xftp stats across all users and servers, +-- to then be persisted to db as a single json. +data AgentPersistedServerStats = AgentPersistedServerStats + { smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData, + xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData + } + deriving (Show) + +$(J.deriveJSON defaultJSON ''AgentSMPServerStatsData) + +$(J.deriveJSON defaultJSON ''AgentXFTPServerStatsData) + +$(J.deriveJSON defaultJSON ''AgentPersistedServerStats) + +instance ToField AgentPersistedServerStats where + toField = toField . encodeJSON + +instance FromField AgentPersistedServerStats where + fromField = fromTextField_ decodeJSON diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index ce76d5c89..ae010a884 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -30,7 +30,7 @@ import Data.Type.Equality import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.Ratchet (RatchetX448, PQEncryption, PQSupport) +import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport, RatchetX448) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol ( MsgBody, @@ -44,10 +44,10 @@ import Simplex.Messaging.Protocol RcvPrivateAuthKey, SndPrivateAuthKey, SndPublicAuthKey, + SenderCanSecure, VersionSMPC, ) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Util ((<$?>)) -- * Queue types @@ -84,6 +84,8 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue e2eDhSecret :: Maybe C.DhSecretX25519, -- | sender queue ID sndId :: SMP.SenderId, + -- | sender can secure the queue + sndSecure :: SenderCanSecure, -- | queue status status :: QueueStatus, -- | database queue ID (within connection) @@ -139,9 +141,11 @@ data StoredSndQueue (q :: QueueStored) = SndQueue server :: SMPServer, -- | sender queue ID sndId :: SMP.SenderId, + -- | sender can secure the queue + sndSecure :: SenderCanSecure, -- | key pair used by the sender to authorize transmissions -- TODO combine keys to key pair so that types match - sndPublicKey :: Maybe SndPublicAuthKey, + sndPublicKey :: SndPublicAuthKey, sndPrivateKey :: SndPrivateAuthKey, -- | DH public key used to negotiate per-queue e2e encryption e2ePubKey :: Maybe C.PublicKeyX25519, @@ -171,6 +175,12 @@ instance SMPQueue RcvQueue where queueId RcvQueue {rcvId} = rcvId {-# INLINE queueId #-} +instance SMPQueue NewRcvQueue where + qServer RcvQueue {server} = server + {-# INLINE qServer #-} + queueId RcvQueue {rcvId} = rcvId + {-# INLINE queueId #-} + instance SMPQueue SndQueue where qServer SndQueue {server} = server {-# INLINE qServer #-} @@ -344,20 +354,20 @@ instance StrEncoding AgentCmdType where _ -> fail "bad AgentCmdType" data AgentCommand - = AClientCommand (APartyCmd 'Client) + = AClientCommand ACommand | AInternalCommand InternalCommand instance StrEncoding AgentCommand where strEncode = \case - AClientCommand (APC _ cmd) -> strEncode (ACClient, Str $ serializeCommand cmd) + AClientCommand cmd -> strEncode (ACClient, Str $ serializeCommand cmd) AInternalCommand cmd -> strEncode (ACInternal, cmd) strP = strP_ >>= \case - ACClient -> AClientCommand <$> ((\(ACmd _ e cmd) -> checkParty $ APC e cmd) <$?> dbCommandP) + ACClient -> AClientCommand <$> dbCommandP ACInternal -> AInternalCommand <$> strP data AgentCommandTag - = AClientCommandTag (APartyCmdTag 'Client) + = AClientCommandTag ACommandTag | AInternalCommandTag InternalCommandTag deriving (Show) @@ -373,7 +383,7 @@ instance StrEncoding AgentCommandTag where data InternalCommand = ICAck SMP.RecipientId MsgId | ICAckDel SMP.RecipientId MsgId InternalId - | ICAllowSecure SMP.RecipientId SMP.SndPublicAuthKey + | ICAllowSecure SMP.RecipientId (Maybe SMP.SndPublicAuthKey) | ICDuplexSecure SMP.RecipientId SMP.SndPublicAuthKey | ICDeleteConn | ICDeleteRcvQueue SMP.RecipientId @@ -436,7 +446,7 @@ instance StrEncoding InternalCommandTag where agentCommandTag :: AgentCommand -> AgentCommandTag agentCommandTag = \case - AClientCommand cmd -> AClientCommandTag $ aPartyCmdTag cmd + AClientCommand cmd -> AClientCommandTag $ aCommandTag cmd AInternalCommand cmd -> AInternalCommandTag $ internalCmdTag cmd internalCmdTag :: InternalCommand -> InternalCommandTag @@ -593,6 +603,8 @@ type AsyncCmdId = Int64 data StoreError = -- | IO exceptions in store actions. SEInternal ByteString + | -- | Database busy + SEDatabaseBusy ByteString | -- | Failed to generate unique random ID SEUniqueID | -- | User ID not found @@ -634,4 +646,6 @@ data StoreError SEDeletedSndChunkReplicaNotFound | -- | Error when reading work item that suspends worker - do not use! SEWorkItemError ByteString + | -- | Servers stats not found. + SEServersStatsNotFound deriving (Eq, Show, Exception) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index b8b1c7c52..0727343e7 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -102,8 +102,10 @@ module Simplex.Messaging.Agent.Store.SQLite -- Messages updateRcvIds, createRcvMsg, + updateRcvMsgHash, updateSndIds, createSndMsg, + updateSndMsgHash, createSndMsgDelivery, getSndMsgViaRcpt, updateSndMsgRcpt, @@ -210,6 +212,10 @@ module Simplex.Messaging.Agent.Store.SQLite deleteDeletedSndChunkReplica, getPendingDelFilesServers, deleteDeletedSndChunkReplicasExpired, + -- Stats + updateServersStats, + getServersStats, + resetServersStats, -- * utilities withConnection, @@ -221,9 +227,11 @@ module Simplex.Messaging.Agent.Store.SQLite ) where +import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A @@ -261,6 +269,7 @@ import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) import Simplex.FileTransfer.Types import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State (..)) +import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite.Common import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -268,7 +277,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations (DownMigration (..), MTRE import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) -import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys, PQEncryption (..), PQSupport (..)) +import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -278,7 +287,7 @@ import Simplex.Messaging.Parsers (blobFieldParser, defaultJSON, dropPrefix, from import Simplex.Messaging.Protocol import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport.Client (TransportHost) -import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, safeDecodeUtf8, ($>>=), (<$$>)) +import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, safeDecodeUtf8, tshow, ($>>=), (<$$>)) import Simplex.Messaging.Version.Internal import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist) import System.Exit (exitFailure) @@ -286,6 +295,7 @@ import System.FilePath (takeDirectory) import System.IO (hFlush, stdout) import UnliftIO.Exception (bracketOnError, onException) import qualified UnliftIO.Exception as E +import UnliftIO.MVar import UnliftIO.STM -- * SQLite Store implementation @@ -381,8 +391,8 @@ connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> IO SQLiteStore connectSQLiteStore dbFilePath key keepKey = do dbNew <- not <$> doesFileExist dbFilePath dbConn <- dbBusyLoop (connectDB dbFilePath key) + dbConnection <- newMVar dbConn atomically $ do - dbConnection <- newTMVar dbConn dbKey <- newTVar $! storeKey key keepKey dbClosed <- newTVar False pure SQLiteStore {dbFilePath, dbKey, dbConnection, dbNew, dbClosed} @@ -420,14 +430,14 @@ openSQLiteStore st@SQLiteStore {dbClosed} key keepKey = openSQLiteStore_ :: SQLiteStore -> ScrubbedBytes -> Bool -> IO () openSQLiteStore_ SQLiteStore {dbConnection, dbFilePath, dbKey, dbClosed} key keepKey = bracketOnError - (atomically $ takeTMVar dbConnection) - (atomically . tryPutTMVar dbConnection) + (takeMVar dbConnection) + (tryPutMVar dbConnection) $ \DB.Connection {slow} -> do DB.Connection {conn} <- connectDB dbFilePath key atomically $ do - putTMVar dbConnection DB.Connection {conn, slow} writeTVar dbClosed False writeTVar dbKey $! storeKey key keepKey + putMVar dbConnection DB.Connection {conn, slow} reopenSQLiteStore :: SQLiteStore -> IO () reopenSQLiteStore st@SQLiteStore {dbKey, dbClosed} = @@ -803,7 +813,7 @@ setRcvQueueNtfCreds db connId clientNtfCreds = Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) Nothing -> (Nothing, Nothing, Nothing, Nothing) -type SMPConfirmationRow = (SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC) +type SMPConfirmationRow = (Maybe SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC) smpConfirmation :: SMPConfirmationRow -> SMPConfirmation smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) = @@ -950,10 +960,10 @@ updateRcvIds db connId = do pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash) createRcvMsg :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO () -createRcvMsg db connId rq rcvMsgData = do +createRcvMsg db connId rq rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalRcvId, internalHash} = do insertRcvMsgBase_ db connId rcvMsgData insertRcvMsgDetails_ db connId rq rcvMsgData - updateHashRcv_ db connId rcvMsgData + updateRcvMsgHash db connId sndMsgId internalRcvId internalHash updateSndIds :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash) updateSndIds db connId = do @@ -964,10 +974,10 @@ updateSndIds db connId = do pure (internalId, internalSndId, prevSndHash) createSndMsg :: DB.Connection -> ConnId -> SndMsgData -> IO () -createSndMsg db connId sndMsgData = do +createSndMsg db connId sndMsgData@SndMsgData {internalSndId, internalHash} = do insertSndMsgBase_ db connId sndMsgData insertSndMsgDetails_ db connId sndMsgData - updateHashSnd_ db connId sndMsgData + updateSndMsgHash db connId internalSndId internalHash createSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO () createSndMsgDelivery db connId SndQueue {dbQueueId} msgId = @@ -1043,7 +1053,7 @@ getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreErr getWorkItem itemName getId getItem markFailed = runExceptT $ handleErr "getId" getId >>= mapM tryGetItem where - tryGetItem itemId = ExceptT (getItem itemId) `catchStoreErrors` \e -> mark itemId >> throwError e + tryGetItem itemId = ExceptT (getItem itemId) `catchStoreErrors` \e -> mark itemId >> throwE e mark itemId = handleErr ("markFailed ID " <> bshow itemId) $ markFailed itemId catchStoreErrors = catchAllErrors (SEInternal . bshow) -- Errors caught by this function will suspend worker as if there is no more work, @@ -1272,12 +1282,16 @@ createCommand :: DB.Connection -> ACorrId -> ConnId -> Maybe SMPServer -> AgentC createCommand db corrId connId srv_ cmd = runExceptT $ do (host_, port_, serverKeyHash_) <- serverFields createdAt <- liftIO getCurrentTime - liftIO $ + liftIO . E.handle handleErr $ DB.execute db "INSERT INTO commands (host, port, corr_id, conn_id, command_tag, command, server_key_hash, created_at) VALUES (?,?,?,?,?,?,?,?)" - (host_, port_, corrId, connId, agentCommandTag cmd, cmd, serverKeyHash_, createdAt) + (host_, port_, corrId, connId, cmdTag, cmd, serverKeyHash_, createdAt) where + cmdTag = agentCommandTag cmd + handleErr e + | SQL.sqlError e == SQL.ErrorConstraint = logError $ "tried to create command " <> tshow cmdTag <> " for deleted connection" + | otherwise = E.throwIO e serverFields :: ExceptT StoreError IO (Maybe (NonEmpty TransportHost), Maybe ServiceName, Maybe C.KeyHash) serverFields = case srv_ of Just srv@(SMPServer host port _) -> @@ -1854,28 +1868,34 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> Maybe C.KeyHash -> IO RcvQueue insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do - qId <- newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId') + -- to preserve ID if the queue already exists. + -- possibly, it can be done in one query. + currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId) + qId <- maybe (newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId')) pure currQId_ DB.execute db [sql| INSERT INTO rcv_queues - (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); + (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); |] - ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, sndSecure, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId} -- * createSndConn helpers insertSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> Maybe C.KeyHash -> IO SndQueue insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do - qId <- newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId') + -- to preserve ID if the queue already exists. + -- possibly, it can be done in one query. + currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId) + qId <- maybe (newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId')) pure currQId_ DB.execute db [sql| INSERT OR REPLACE INTO snd_queues - (host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?); + (host, port, snd_id, snd_secure, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); |] - ((host server, port server, sndId, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + ((host server, port server, sndId, sndSecure, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId} newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored @@ -1997,7 +2017,7 @@ rcvQueueQuery :: Query rcvQueueQuery = [sql| SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, - q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status, + q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_secure, q.status, q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret FROM rcv_queues q @@ -2006,17 +2026,17 @@ rcvQueueQuery = |] toRcvQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus) - :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, SenderCanSecure) + :. (QueueStatus, DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> RcvQueue -toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = +toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure) :. (status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = let server = SMPServer host port keyHash smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_ clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} _ -> Nothing - in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} + in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue) getRcvQueueById db connId dbRcvId = @@ -2037,7 +2057,7 @@ sndQueueQuery :: Query sndQueueQuery = [sql| SELECT - c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, + c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.snd_secure, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version FROM snd_queues q @@ -2046,17 +2066,18 @@ sndQueueQuery = |] toSndQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, SenderCanSecure) :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) -> SndQueue toSndQueue - ( (userId, keyHash, connId, host, port, sndId) - :. (sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) + ( (userId, keyHash, connId, host, port, sndId, sndSecure) + :. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion) ) = let server = SMPServer host port keyHash - in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion} + sndPublicKey = fromMaybe (C.APublicAuthKey a (C.publicKey pk)) sndPubKey + in SndQueue {userId, connId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion} getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue) getSndQueueById db connId dbSndId = @@ -2135,10 +2156,10 @@ insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, interna ] DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, encryptedMsgHash) -updateHashRcv_ :: DB.Connection -> ConnId -> RcvMsgData -> IO () -updateHashRcv_ dbConn connId RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalHash, internalRcvId} = +updateRcvMsgHash :: DB.Connection -> ConnId -> AgentMsgId -> InternalRcvId -> MsgHash -> IO () +updateRcvMsgHash db connId sndMsgId internalRcvId internalHash = DB.executeNamed - dbConn + db -- last_internal_rcv_msg_id equality check prevents race condition in case next id was reserved [sql| UPDATE connections @@ -2214,10 +2235,10 @@ insertSndMsgDetails_ dbConn connId SndMsgData {..} = ":previous_msg_hash" := prevMsgHash ] -updateHashSnd_ :: DB.Connection -> ConnId -> SndMsgData -> IO () -updateHashSnd_ dbConn connId SndMsgData {..} = +updateSndMsgHash :: DB.Connection -> ConnId -> InternalSndId -> MsgHash -> IO () +updateSndMsgHash db connId internalSndId internalHash = DB.executeNamed - dbConn + db -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved [sql| UPDATE connections @@ -2269,20 +2290,20 @@ getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do firstRow fromOnly SEXFTPServerNotFound $ DB.query db "SELECT xftp_server_id FROM xftp_servers WHERE xftp_host = ? AND xftp_port = ? AND xftp_key_hash = ?" (host, port, keyHash) -createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> IO (Either StoreError RcvFileId) -createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file = runExceptT $ do - (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile db gVar userId fd prefixPath tmpPath file Nothing Nothing +createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) +createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file approvedRelays = runExceptT $ do + (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile db gVar userId fd prefixPath tmpPath file Nothing Nothing approvedRelays liftIO $ forM_ chunks $ \fc@FileChunk {replicas} -> do chunkId <- insertRcvFileChunk db fc rcvFileId forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId pure rcvFileEntityId -createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> IO (Either StoreError RcvFileId) -createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect" -createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile = runExceptT $ do - (dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing - (_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId) +createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) +createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect" +createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile approvedRelays = runExceptT $ do + (dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing approvedRelays + (_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId) approvedRelays liftIO $ forM_ redirectChunks $ \fc@FileChunk {replicas} -> do chunkId <- insertRcvFileChunk db fc redirectId @@ -2302,8 +2323,8 @@ createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redire chunks = [] } -insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> IO (Either StoreError (RcvFileId, DBRcvFileId)) -insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ = runExceptT $ do +insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> Bool -> IO (Either StoreError (RcvFileId, DBRcvFileId)) +insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ approvedRelays = runExceptT $ do let (redirectDigest_, redirectSize_) = case redirect of Just RedirectFileInfo {digest = d, size = s} -> (Just d, Just s) Nothing -> (Nothing, Nothing) @@ -2311,8 +2332,8 @@ insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSiz createWithRandomId gVar $ \rcvFileEntityId -> DB.execute db - "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" - ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_)) + "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size, approved_relays) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_, approvedRelays)) rcvFileId <- liftIO $ insertedRowId db pure (rcvFileEntityId, rcvFileId) @@ -2462,7 +2483,7 @@ deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO () deleteRcvFile' db rcvFileId = DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId) -getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFileChunk)) +getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool))) getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd) where @@ -2486,7 +2507,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d LIMIT 1 |] (host, port, keyHash, RFSReceiving, cutoffTs) - getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError RcvFileChunk) + getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool)) getChunkData (rcvFileChunkReplicaId, _fileId) = firstRow toChunk SEFileNotFound $ DB.query @@ -2494,7 +2515,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d [sql| SELECT f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, - r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries + r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries, + f.approved_relays FROM rcv_file_chunk_replicas r JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id @@ -2503,20 +2525,22 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d |] (Only rcvFileChunkReplicaId) where - toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int)) -> RcvFileChunk - toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries)) = - RcvFileChunk - { rcvFileId, - rcvFileEntityId, - userId, - rcvChunkId, - chunkNo, - chunkSize, - digest, - fileTmpPath, - chunkTmpPath, - replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}] - } + toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. Only Bool) -> (RcvFileChunk, Bool) + toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (Only approvedRelays)) = + ( RcvFileChunk + { rcvFileId, + rcvFileEntityId, + userId, + rcvChunkId, + chunkNo, + chunkSize, + digest, + fileTmpPath, + chunkTmpPath, + replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}] + }, + approvedRelays + ) getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile)) getNextRcvFileToDecrypt db ttl = @@ -3007,6 +3031,20 @@ deleteDeletedSndChunkReplicasExpired db ttl = do cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime DB.execute db "DELETE FROM deleted_snd_chunk_replicas WHERE created_at < ?" (Only cutoffTs) +updateServersStats :: DB.Connection -> AgentPersistedServerStats -> IO () +updateServersStats db stats = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE servers_stats SET servers_stats = ?, updated_at = ? WHERE servers_stats_id = 1" (stats, updatedAt) + +getServersStats :: DB.Connection -> IO (Either StoreError (UTCTime, Maybe AgentPersistedServerStats)) +getServersStats db = + firstRow id SEServersStatsNotFound $ + DB.query_ db "SELECT started_at, servers_stats FROM servers_stats WHERE servers_stats_id = 1" + +resetServersStats :: DB.Connection -> UTCTime -> IO () +resetServersStats db startedAt = + DB.execute db "UPDATE servers_stats SET servers_stats = NULL, started_at = ?, updated_at = ? WHERE servers_stats_id = 1" (startedAt, startedAt) + $(J.deriveJSON defaultJSON ''UpMigration) $(J.deriveToJSON (sumTypeJSON $ dropPrefix "ME") ''MigrationError) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs index 18c16cc8b..b9a9bd501 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs @@ -22,8 +22,8 @@ import Database.SQLite.Simple (SQLError) import qualified Database.SQLite.Simple as SQL import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import Simplex.Messaging.Util (diffToMilliseconds) -import UnliftIO.Exception (bracket) import qualified UnliftIO.Exception as E +import UnliftIO.MVar import UnliftIO.STM storeKey :: ScrubbedBytes -> Bool -> Maybe ScrubbedBytes @@ -32,16 +32,13 @@ storeKey key keepKey = if keepKey || BA.null key then Just key else Nothing data SQLiteStore = SQLiteStore { dbFilePath :: FilePath, dbKey :: TVar (Maybe ScrubbedBytes), - dbConnection :: TMVar DB.Connection, + dbConnection :: MVar DB.Connection, dbClosed :: TVar Bool, dbNew :: Bool } withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a -withConnection SQLiteStore {dbConnection} = - bracket - (atomically $ takeTMVar dbConnection) - (atomically . putTMVar dbConnection) +withConnection SQLiteStore {dbConnection} = withMVar dbConnection withConnection' :: SQLiteStore -> (SQL.Connection -> IO a) -> IO a withConnection' st action = withConnection st $ action . DB.conn @@ -71,9 +68,9 @@ dbBusyLoop action = loop 500 3000000 loop :: Int -> Int -> IO a loop t tLim = action `E.catch` \(e :: SQLError) -> - let se = SQL.sqlError e in - if tLim > t && (se == SQL.ErrorBusy || se == SQL.ErrorLocked) - then do - threadDelay t - loop (t * 9 `div` 8) (tLim - t) - else E.throwIO e + let se = SQL.sqlError e + in if tLim > t && (se == SQL.ErrorBusy || se == SQL.ErrorLocked) + then do + threadDelay t + loop (t * 9 `div` 8) (tLim - t) + else E.throwIO e diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 344a3f9ce..131561f4d 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -71,6 +71,9 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_deliver import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) import Simplex.Messaging.Transport.Client (TransportHost) @@ -110,7 +113,10 @@ schemaMigrations = ("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes), ("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect), ("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery), - ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem) + ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem), + ("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays), + ("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure), + ("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240417_rcv_files_approved_relays.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240417_rcv_files_approved_relays.hs new file mode 100644 index 000000000..9eb10c27a --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240417_rcv_files_approved_relays.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20240417_rcv_files_approved_relays :: Query +m20240417_rcv_files_approved_relays = + [sql| +ALTER TABLE rcv_files ADD COLUMN approved_relays INTEGER NOT NULL DEFAULT 0; +|] + +down_m20240417_rcv_files_approved_relays :: Query +down_m20240417_rcv_files_approved_relays = + [sql| +ALTER TABLE rcv_files DROP COLUMN approved_relays; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240624_snd_secure.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240624_snd_secure.hs new file mode 100644 index 000000000..7f82d4ecf --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240624_snd_secure.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20240624_snd_secure :: Query +m20240624_snd_secure = + [sql| +ALTER TABLE rcv_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0; +ALTER TABLE snd_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0; + +PRAGMA writable_schema=1; + +UPDATE sqlite_master +SET sql = replace(sql, 'sender_key BLOB NOT NULL,', 'sender_key BLOB,') +WHERE name = 'conn_confirmations' AND type = 'table'; + +PRAGMA writable_schema=0; +|] + +down_m20240624_snd_secure :: Query +down_m20240624_snd_secure = + [sql| +ALTER TABLE rcv_queues DROP COLUMN snd_secure; +ALTER TABLE snd_queues DROP COLUMN snd_secure; + +PRAGMA writable_schema=1; + +UPDATE sqlite_master +SET sql = replace(sql, 'sender_key BLOB,', 'sender_key BLOB NOT NULL,') +WHERE name = 'conn_confirmations' AND type = 'table'; + +PRAGMA writable_schema=0; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240702_servers_stats.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240702_servers_stats.hs new file mode 100644 index 000000000..5e283d8b1 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240702_servers_stats.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +-- servers_stats_id: dummy id, there should always only be one record with servers_stats_id = 1 +-- servers_stats: overall accumulated stats, past and session, reset to null on stats reset +-- started_at: starting point of tracking stats, reset on stats reset +m20240702_servers_stats :: Query +m20240702_servers_stats = + [sql| +CREATE TABLE servers_stats( + servers_stats_id INTEGER PRIMARY KEY, + servers_stats TEXT, + started_at TEXT NOT NULL DEFAULT(datetime('now')), + created_at TEXT NOT NULL DEFAULT(datetime('now')), + updated_at TEXT NOT NULL DEFAULT(datetime('now')) +); + +INSERT INTO servers_stats (servers_stats_id) VALUES (1); +|] + +down_m20240702_servers_stats :: Query +down_m20240702_servers_stats = + [sql| +DROP TABLE servers_stats; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 0818be904..80af08989 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -55,6 +55,7 @@ CREATE TABLE rcv_queues( server_key_hash BLOB, switch_status TEXT, deleted INTEGER NOT NULL DEFAULT 0, + snd_secure INTEGER NOT NULL DEFAULT 0, PRIMARY KEY(host, port, rcv_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE, @@ -77,6 +78,7 @@ CREATE TABLE snd_queues( replace_snd_queue_id INTEGER NULL, server_key_hash BLOB, switch_status TEXT, + snd_secure INTEGER NOT NULL DEFAULT 0, PRIMARY KEY(host, port, snd_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE @@ -132,7 +134,7 @@ CREATE TABLE conn_confirmations( confirmation_id BLOB NOT NULL PRIMARY KEY, conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, e2e_snd_pub_key BLOB NOT NULL, - sender_key BLOB NOT NULL, + sender_key BLOB, ratchet_state BLOB NOT NULL, sender_conn_info BLOB NOT NULL, accepted INTEGER NOT NULL, @@ -287,6 +289,7 @@ CREATE TABLE rcv_files( redirect_entity_id BLOB, redirect_size INTEGER, redirect_digest BLOB, + approved_relays INTEGER NOT NULL DEFAULT 0, UNIQUE(rcv_file_entity_id) ); CREATE TABLE rcv_file_chunks( @@ -393,6 +396,13 @@ CREATE TABLE processed_ratchet_key_hashes( created_at TEXT NOT NULL DEFAULT(datetime('now')), updated_at TEXT NOT NULL DEFAULT(datetime('now')) ); +CREATE TABLE servers_stats( + servers_stats_id INTEGER PRIMARY KEY, + servers_stats TEXT, + started_at TEXT NOT NULL DEFAULT(datetime('now')), + created_at TEXT NOT NULL DEFAULT(datetime('now')), + updated_at TEXT NOT NULL DEFAULT(datetime('now')) +); CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id); CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id); CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id); diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index cdf8d16f1..0a3a80d77 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -30,9 +30,11 @@ module Simplex.Messaging.Client TransportSession, ProtocolClient (thParams, sessionTs), SMPClient, + ProxiedRelay (..), getProtocolClient, closeProtocolClient, protocolClientServer, + protocolClientServer', transportHost', transportSession', @@ -45,6 +47,8 @@ module Simplex.Messaging.Client subscribeSMPQueueNotifications, subscribeSMPQueuesNtfs, secureSMPQueue, + secureSndSMPQueue, + proxySecureSndSMPQueue, enableSMPQueueNotifications, disableSMPQueueNotifications, enableSMPQueuesNtfs, @@ -54,14 +58,24 @@ module Simplex.Messaging.Client suspendSMPQueue, deleteSMPQueue, deleteSMPQueues, + connectSMPProxiedRelay, + proxySMPMessage, + forwardSMPTransmission, + getSMPQueueInfo, sendProtocolCommand, -- * Supporting types and client configuration ProtocolClientError (..), SMPClientError, + ProxyClientError (..), + unexpectedResponse, ProtocolClientConfig (..), NetworkConfig (..), TransportSessionMode (..), + HostMode (..), + SocksMode (..), + SMPProxyMode (..), + SMPProxyFallback (..), defaultClientConfig, defaultSMPClientConfig, defaultNetworkConfig, @@ -69,7 +83,9 @@ module Simplex.Messaging.Client chooseTransportHost, proxyUsername, temporaryClientError, - ServerTransmission, + smpProxyError, + ServerTransmissionBatch, + ServerTransmission (..), ClientCommand, -- * For testing @@ -77,18 +93,27 @@ module Simplex.Messaging.Client mkTransmission, authTransmission, smpClientStub, + + -- * For debugging + TBQueueInfo (..), + getTBQueueInfo, + getProtocolClientQueuesInfo, ) where +import Control.Applicative ((<|>)) +import Control.Concurrent (ThreadId, forkFinally, killThread, mkWeakThreadId) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Exception +import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import qualified Data.Aeson.TH as J +import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) @@ -96,30 +121,34 @@ import Data.Int (Int64) import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L -import Data.Maybe (fromMaybe) +import Data.Maybe (catMaybes, fromMaybe) import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime) +import qualified Data.X509 as X +import qualified Data.X509.Validation as XV import Network.Socket (ServiceName) import Numeric.Natural import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient) import Simplex.Messaging.Transport.KeepAlive import Simplex.Messaging.Transport.WebSockets (WS) -import Simplex.Messaging.Util (bshow, diffToMicroseconds, raceAny_, threadDelay', whenM) +import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tshow, whenM) import Simplex.Messaging.Version +import System.Mem.Weak (Weak, deRefWeak) import System.Timeout (timeout) -import UnliftIO (pooledMapConcurrentlyN) -- | 'SMPClient' is a handle used to send commands to a specific SMP server. -- -- Use 'getSMPClient' to connect to an SMP server and create a client handle. data ProtocolClient v err msg = ProtocolClient - { action :: Maybe (Async ()), + { action :: Maybe (Weak ThreadId), thParams :: THandleParams v 'TClient, sessionTs :: UTCTime, client_ :: PClient v err msg @@ -129,16 +158,16 @@ data PClient v err msg = PClient { connected :: TVar Bool, transportSession :: TransportSession msg, transportHost :: TransportHost, + tcpConnectTimeout :: Int, tcpTimeout :: Int, - rcvConcurrency :: Int, sendPings :: TVar Bool, lastReceived :: TVar UTCTime, timeoutErrorCount :: TVar Int, clientCorrId :: TVar ChaChaDRG, sentCommands :: TMap CorrId (Request err msg), - sndQ :: TBQueue (TVar Bool, ByteString), + sndQ :: TBQueue (Maybe (TVar Bool), ByteString), rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)), - msgQ :: Maybe (TBQueue (ServerTransmission v msg)) + msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg)) } smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> STM SMPClient @@ -159,6 +188,7 @@ smpClientStub g sessionId thVersion thAuth = do THandleParams { sessionId, thVersion, + thServerVRange = supportedServerSMPRelayVRange, thAuth, blockSize = smpBlockSize, implySessId = thVersion >= authCmdsSMPVersion, @@ -170,8 +200,8 @@ smpClientStub g sessionId thVersion thAuth = do { connected, transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing), transportHost = "localhost", + tcpConnectTimeout = 20_000_000, tcpTimeout = 15_000_000, - rcvConcurrency = 8, sendPings, lastReceived, timeoutErrorCount, @@ -188,8 +218,14 @@ type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg -- | Type for client command data type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg) --- | Type synonym for transmission from some SPM server queue. -type ServerTransmission v msg = (TransportSession msg, Version v, SessionId, Bool, EntityId, msg) +-- | Type synonym for transmission from SPM servers. +-- Batch response is presented as a single `ServerTransmissionBatch` tuple. +type ServerTransmissionBatch v err msg = (TransportSession msg, Version v, SessionId, NonEmpty (EntityId, ServerTransmission err msg)) + +data ServerTransmission err msg + = STEvent (Either (ProtocolClientError err) msg) + | STResponse (ProtoCommand msg) (Either (ProtocolClientError err) msg) + | STUnexpectedError (ProtocolClientError err) data HostMode = -- | prefer (or require) onion hosts when connecting via SOCKS proxy @@ -200,16 +236,30 @@ data HostMode HMPublic deriving (Eq, Show) +data SocksMode + = -- | always use SOCKS proxy when enabled + SMAlways + | -- | use SOCKS proxy only for .onion hosts when no public host is available + -- This mode is used in SMP proxy and in notifications server to minimize SOCKS proxy usage. + SMOnion + deriving (Eq, Show) + -- | network configuration for the client data NetworkConfig = NetworkConfig { -- | use SOCKS5 proxy socksProxy :: Maybe SocksProxy, + -- | when to use SOCKS proxy + socksMode :: SocksMode, -- | determines critera which host is chosen from the list hostMode :: HostMode, -- | if above criteria is not met, if the below setting is True return error, otherwise use the first host requiredHostMode :: Bool, -- | transport sessions are created per user or per entity sessionMode :: TransportSessionMode, + -- | SMP proxy mode + smpProxyMode :: SMPProxyMode, + -- | Fallback to direct connection when destination SMP relay does not support SMP proxy protocol extensions + smpProxyFallback :: SMPProxyFallback, -- | timeout for the initial client TCP/TLS connection (microseconds) tcpConnectTimeout :: Int, -- | timeout of protocol commands (microseconds) @@ -231,13 +281,56 @@ data NetworkConfig = NetworkConfig data TransportSessionMode = TSMUser | TSMEntity deriving (Eq, Show) +-- SMP proxy mode for sending messages +data SMPProxyMode + = SPMAlways + | SPMUnknown -- use with unknown relays + | SPMUnprotected -- use with unknown relays when IP address is not protected (i.e., when neither SOCKS proxy nor .onion address is used) + | SPMNever + deriving (Eq, Show) + +data SMPProxyFallback + = SPFAllow -- connect directly when chosen proxy or destination relay do not support proxy protocol. + | SPFAllowProtected -- connect directly only when IP address is protected (SOCKS proxy or .onion address is used). + | SPFProhibit -- prohibit direct connection to destination relay. + deriving (Eq, Show) + +instance StrEncoding SMPProxyMode where + strEncode = \case + SPMAlways -> "always" + SPMUnknown -> "unknown" + SPMUnprotected -> "unprotected" + SPMNever -> "never" + strP = + A.takeTill (== ' ') >>= \case + "always" -> pure SPMAlways + "unknown" -> pure SPMUnknown + "unprotected" -> pure SPMUnprotected + "never" -> pure SPMNever + _ -> fail "Invalid SMP proxy mode" + +instance StrEncoding SMPProxyFallback where + strEncode = \case + SPFAllow -> "yes" + SPFAllowProtected -> "protected" + SPFProhibit -> "no" + strP = + A.takeTill (== ' ') >>= \case + "yes" -> pure SPFAllow + "protected" -> pure SPFAllowProtected + "no" -> pure SPFProhibit + _ -> fail "Invalid SMP proxy fallback mode" + defaultNetworkConfig :: NetworkConfig defaultNetworkConfig = NetworkConfig { socksProxy = Nothing, + socksMode = SMAlways, hostMode = HMOnionViaSocks, requiredHostMode = False, sessionMode = TSMUser, + smpProxyMode = SPMNever, + smpProxyFallback = SPFAllow, tcpConnectTimeout = defaultTcpConnectTimeout, tcpTimeout = 15_000_000, tcpTimeoutPerKb = 5_000, @@ -248,9 +341,14 @@ defaultNetworkConfig = logTLSErrors = False } -transportClientConfig :: NetworkConfig -> TransportClientConfig -transportClientConfig NetworkConfig {socksProxy, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} = - TransportClientConfig {socksProxy, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing} +transportClientConfig :: NetworkConfig -> TransportHost -> TransportClientConfig +transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host = + TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing} + where + useSocksProxy SMAlways = socksProxy + useSocksProxy SMOnion = case host of + THOnionHost _ -> socksProxy + _ -> Nothing {-# INLINE transportClientConfig #-} -- | protocol client configuration. @@ -261,31 +359,35 @@ data ProtocolClientConfig v = ProtocolClientConfig defaultTransport :: (ServiceName, ATransport), -- | network configuration networkConfig :: NetworkConfig, + clientALPN :: Maybe [ALPN], -- | client-server protocol version range serverVRange :: VersionRange v, - -- | agree shared session secret (used in SMP proxy) + -- | agree shared session secret (used in SMP proxy for additional encryption layer) agreeSecret :: Bool } -- | Default protocol client configuration. -defaultClientConfig :: VersionRange v -> ProtocolClientConfig v -defaultClientConfig serverVRange = +defaultClientConfig :: Maybe [ALPN] -> VersionRange v -> ProtocolClientConfig v +defaultClientConfig clientALPN serverVRange = ProtocolClientConfig { qSize = 64, defaultTransport = ("443", transport @TLS), networkConfig = defaultNetworkConfig, + clientALPN, serverVRange, agreeSecret = False } {-# INLINE defaultClientConfig #-} defaultSMPClientConfig :: ProtocolClientConfig SMPVersion -defaultSMPClientConfig = defaultClientConfig supportedClientSMPRelayVRange +defaultSMPClientConfig = defaultClientConfig (Just supportedSMPHandshakes) supportedClientSMPRelayVRange {-# INLINE defaultSMPClientConfig #-} data Request err msg = Request { corrId :: CorrId, entityId :: EntityId, + command :: ProtoCommand msg, + pending :: TVar Bool, responseVar :: TMVar (Either (ProtocolClientError err) msg) } @@ -309,10 +411,14 @@ chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts publicHost = find (not . isOnionHost) hosts protocolClientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient v err msg -> String -protocolClientServer = B.unpack . strEncode . snd3 . transportSession . client_ +protocolClientServer = B.unpack . strEncode . protocolClientServer' +{-# INLINE protocolClientServer #-} + +protocolClientServer' :: ProtocolClient v err msg -> ProtoServer msg +protocolClientServer' = snd3 . transportSession . client_ where snd3 (_, s, _) = s -{-# INLINE protocolClientServer #-} +{-# INLINE protocolClientServer' #-} transportHost' :: ProtocolClient v err msg -> TransportHost transportHost' = transportHost . client_ @@ -332,15 +438,15 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId) -- -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. -getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmission v msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) -getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, agreeSecret} msgQ disconnected = do +getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) +getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do case chooseTransportHost networkConfig (host srv) of Right useHost -> (getCurrentTime >>= atomically . mkProtocolClient useHost >>= runClient useTransport useHost) `catch` \(e :: IOException) -> pure . Left $ PCEIOError e Left e -> pure $ Left e where - NetworkConfig {tcpConnectTimeout, tcpTimeout, rcvConcurrency, smpPingInterval} = networkConfig + NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig mkProtocolClient :: TransportHost -> UTCTime -> STM (PClient v err msg) mkProtocolClient transportHost ts = do connected <- newTVar False @@ -356,13 +462,13 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize { connected, transportSession, transportHost, + tcpConnectTimeout, tcpTimeout, sendPings, lastReceived, timeoutErrorCount, clientCorrId, sentCommands, - rcvConcurrency, sndQ, rcvQ, msgQ @@ -371,17 +477,16 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize runClient :: (ServiceName, ATransport) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) runClient (port', ATransport t) useHost c = do cVar <- newEmptyTMVarIO - let tcConfig = transportClientConfig networkConfig + let tcConfig = (transportClientConfig networkConfig useHost) {alpn = clientALPN} username = proxyUsername transportSession - action <- - async $ - runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar) - `finally` atomically (tryPutTMVar cVar $ Left PCENetworkError) + tId <- + runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar) + `forkFinally` \_ -> void (atomically . tryPutTMVar cVar $ Left PCENetworkError) c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar) case c_ of - Just (Right c') -> pure $ Right c' {action = Just action} + Just (Right c') -> mkWeakThreadId tId >>= \tId' -> pure $ Right c' {action = Just tId'} Just (Left e) -> pure $ Left e - Nothing -> cancel action $> Left PCENetworkError + Nothing -> killThread tId $> Left PCENetworkError useTransport :: (ServiceName, ATransport) useTransport = case port srv of @@ -401,12 +506,16 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize atomically $ do writeTVar (connected c) True putTMVar cVar $ Right c' - raceAny_ ([send c' th, process c', receive c' th] <> [ping c' | smpPingInterval > 0]) `finally` do + raceAny_ ([send c' th, process c', receive c' th] <> [monitor c' | smpPingInterval > 0]) `finally` do atomically $ writeTVar (connected c) False disconnected c' send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO () - send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= \(active, s) -> whenM (readTVarIO active) (void $ tPutLog h s) + send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= sendPending + where + sendPending (Nothing, s) = send_ s + sendPending (Just pending, s) = whenM (readTVarIO pending) $ send_ s + send_ = void . tPutLog h receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO () receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do @@ -414,8 +523,8 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize getCurrentTime >>= atomically . writeTVar lastReceived atomically $ writeTVar timeoutErrorCount 0 - ping :: ProtocolClient v err msg -> IO () - ping c@ProtocolClient {client_ = PClient {sendPings, lastReceived, timeoutErrorCount}} = loop smpPingInterval + monitor :: ProtocolClient v err msg -> IO () + monitor c@ProtocolClient {client_ = PClient {sendPings, lastReceived, timeoutErrorCount}} = loop smpPingInterval where loop :: Int64 -> IO () loop delay = do @@ -435,31 +544,48 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize maxCnt = smpPingCount networkConfig process :: ProtocolClient v err msg -> IO () - process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c) + process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= processMsgs c - processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO () - processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr)) - | isResponse = + processMsgs :: ProtocolClient v err msg -> NonEmpty (SignedTransmission err msg) -> IO () + processMsgs c ts = do + ts' <- catMaybes <$> mapM (processMsg c) (L.toList ts) + forM_ msgQ $ \q -> + mapM_ (atomically . writeTBQueue q . serverTransmission c) (L.nonEmpty ts') + + processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg)) + processMsg ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr)) + | B.null $ bs corrId = sendMsg $ STEvent clientResp + | otherwise = atomically (TM.lookup corrId sentCommands) >>= \case - Nothing -> sendMsg respOrErr - Just Request {entityId, responseVar} -> atomically $ do - TM.delete corrId sentCommands - putTMVar responseVar $ response entityId - | otherwise = sendMsg respOrErr + Nothing -> sendMsg $ STUnexpectedError unexpected + Just Request {entityId, command, pending, responseVar} -> do + wasPending <- + atomically $ do + TM.delete corrId sentCommands + ifM + (swapTVar pending False) + (True <$ tryPutTMVar responseVar (if entityId == entId then clientResp else Left unexpected)) + (pure False) + if wasPending + then pure Nothing + else sendMsg $ if entityId == entId then STResponse command clientResp else STUnexpectedError unexpected where - isResponse = not $ B.null $ bs corrId - response entityId - | entityId == entId = - case respOrErr of - Left e -> Left $ PCEResponseError e - Right r -> case protocolError r of - Just e -> Left $ PCEProtocolError e - _ -> Right r - | otherwise = Left . PCEUnexpectedResponse $ bshow respOrErr - sendMsg :: Either err msg -> IO () - sendMsg = \case - Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c isResponse entId msg) msgQ - Left e -> putStrLn $ "SMP client error: " <> show e + unexpected = unexpectedResponse respOrErr + clientResp = case respOrErr of + Left e -> Left $ PCEResponseError e + Right r -> case protocolError r of + Just e -> Left $ PCEProtocolError e + _ -> Right r + sendMsg :: ServerTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg)) + sendMsg t = case msgQ of + Just _ -> pure $ Just (entId, t) + Nothing -> + Nothing <$ case clientResp of + Left e -> logError $ "SMP client error: " <> tshow e + Right _ -> logWarn "SMP client unprocessed event" + +unexpectedResponse :: Show r => r -> ProtocolClientError err +unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show proxyUsername :: TransportSession msg -> ByteString proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_ @@ -467,7 +593,7 @@ proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" ( -- | Disconnects client from the server and terminates client threads. closeProtocolClient :: ProtocolClient v err msg -> IO () -closeProtocolClient = mapM_ uninterruptibleCancel . action +closeProtocolClient = mapM_ (deRefWeak >=> mapM_ killThread) . action {-# INLINE closeProtocolClient #-} -- | SMP client error type. @@ -510,6 +636,19 @@ temporaryClientError = \case _ -> False {-# INLINE temporaryClientError #-} +-- converts error of client running on proxy to the error sent to client connected to proxy +smpProxyError :: SMPClientError -> ErrorType +smpProxyError = \case + PCEProtocolError e -> PROXY $ PROTOCOL e + PCEResponseError e -> PROXY $ BROKER $ RESPONSE $ B.unpack $ strEncode e + PCEUnexpectedResponse e -> PROXY $ BROKER $ UNEXPECTED $ B.unpack e + PCEResponseTimeout -> PROXY $ BROKER TIMEOUT + PCENetworkError -> PROXY $ BROKER NETWORK + PCEIncompatibleHost -> PROXY $ BROKER HOST + PCETransportError t -> PROXY $ BROKER $ TRANSPORT t + PCECryptoError _ -> CRYPTO + PCEIOError _ -> INTERNAL + -- | Create a new SMP queue. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command @@ -519,11 +658,12 @@ createSMPQueue :: RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> + Bool -> ExceptT SMPClientError IO QueueIdsKeys -createSMPQueue c (rKey, rpKey) dhKey auth subMode = - sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode) >>= \case +createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure = + sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode sndSecure) >>= \case IDS qik -> pure qik - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r -- | Subscribe to the SMP queue. -- @@ -534,7 +674,7 @@ subscribeSMPQueue c@ProtocolClient {client_ = PClient {sendPings}} rpKey rId = d sendSMPCommand c (Just rpKey) rId SUB >>= \case OK -> pure () cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r -- | Subscribe to multiple SMP queues batching commands if supported. subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) @@ -554,15 +694,15 @@ processSUBResponse :: SMPClient -> Response ErrorType BrokerMsg -> IO (Either SM processSUBResponse c (Response rId r) = case r of Right OK -> pure $ Right () Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right () - Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r' + Right r' -> pure . Left $ unexpectedResponse r' Left e -> pure $ Left e writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO () -writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c False rId msg) (msgQ $ client_ c) +writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c [(rId, STEvent (Right msg))]) (msgQ $ client_ c) -serverTransmission :: ProtocolClient v err msg -> Bool -> RecipientId -> msg -> ServerTransmission v msg -serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} isResponse entityId message = - (transportSession, thVersion, sessionId, isResponse, entityId, message) +serverTransmission :: ProtocolClient v err msg -> NonEmpty (RecipientId, ServerTransmission err msg) -> ServerTransmissionBatch v err msg +serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} ts = + (transportSession, thVersion, sessionId, ts) -- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue -- @@ -572,7 +712,7 @@ getSMPMessage c rpKey rId = sendSMPCommand c (Just rpKey) rId GET >>= \case OK -> pure Nothing cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r -- | Subscribe to the SMP queue notifications. -- @@ -593,6 +733,15 @@ secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuth secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId {-# INLINE secureSMPQueue #-} +-- | Secure the SMP queue via sender queue ID. +secureSndSMPQueue :: SMPClient -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO () +secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey sId +{-# INLINE secureSndSMPQueue #-} + +proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ()) +proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxySMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey) +{-# INLINE proxySecureSndSMPQueue #-} + -- | Enable notifications for the queue for push notifications server. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command @@ -600,7 +749,7 @@ enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey = sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey) - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r -- | Enable notifications for the multiple queues for push notifications server. enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey))) @@ -609,7 +758,7 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs process (Response _ r) = case r of Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey) - Right r' -> Left . PCEUnexpectedResponse $ bshow r' + Right r' -> Left $ unexpectedResponse r' Left e -> Left e -- | Disable notifications for the queue for push notifications server. @@ -631,7 +780,10 @@ sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags - sendSMPMessage c spKey sId flags msg = sendSMPCommand c spKey sId (SEND flags msg) >>= \case OK -> pure () - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r + +proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ()) +proxySMPMessage c proxiedRelay spKey sId flags msg = proxySMPCommand c proxiedRelay spKey sId (SEND flags msg) -- | Acknowledge message delivery (server deletes the message). -- @@ -641,7 +793,7 @@ ackSMPMessage c rpKey rId msgId = sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case OK -> return () cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r -- | Irreversibly suspend SMP queue. -- The existing messages from the queue will still be delivered. @@ -663,11 +815,168 @@ deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO deleteSMPQueues = okSMPCommands DEL {-# INLINE deleteSMPQueues #-} +-- send PRXY :: SMPServer -> Maybe BasicAuth -> Command Sender +-- receives PKEY :: SessionId -> X.CertificateChain -> X.SignedExact X.PubKey -> BrokerMsg +connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay +connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth + | thVersion (thParams c) >= sendingProxySMPVersion = + sendProtocolCommand_ c Nothing tOut Nothing "" (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case + PKEY sId vr (chain, key) -> + case supportedClientSMPRelayVRange `compatibleVersion` vr of + Nothing -> throwE $ transportErr TEVersion + Just (Compatible v) -> liftEitherWith (const $ transportErr $ TEHandshake IDENTITY) $ ProxiedRelay sId v proxyAuth <$> validateRelay chain key + r -> throwE $ unexpectedResponse r + | otherwise = throwE $ PCETransportError TEVersion + where + tOut = Just $ tcpConnectTimeout + tcpTimeout + transportErr = PCEProtocolError . PROXY . BROKER . TRANSPORT + validateRelay :: X.CertificateChain -> X.SignedExact X.PubKey -> Either String C.PublicKeyX25519 + validateRelay (X.CertificateChain cert) exact = do + serverKey <- case cert of + [leaf, ca] + | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> + C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned leaf, []) >>= C.pubKey + _ -> throwError "bad certificate" + pubKey <- C.verifyX509 serverKey exact + C.x509ToPublic (pubKey, []) >>= C.pubKey + +data ProxiedRelay = ProxiedRelay + { prSessionId :: SessionId, + prVersion :: VersionSMP, + prBasicAuth :: Maybe BasicAuth, -- auth is included here to allow reconnecting via the same proxy after NO_SESSION error + prServerKey :: C.PublicKeyX25519 + } + +data ProxyClientError + = -- | protocol error response from proxy + ProxyProtocolError {protocolErr :: ErrorType} + | -- | unexpexted response + ProxyUnexpectedResponse {responseStr :: String} + | -- | error between proxy and server + ProxyResponseError {responseErr :: ErrorType} + deriving (Eq, Show, Exception) + +instance StrEncoding ProxyClientError where + strEncode = \case + ProxyProtocolError e -> "PROTOCOL " <> strEncode e + ProxyUnexpectedResponse s -> "UNEXPECTED " <> B.pack s + ProxyResponseError e -> "SYNTAX " <> strEncode e + strP = + A.takeTill (== ' ') >>= \case + "PROTOCOL" -> ProxyProtocolError <$> _strP + "UNEXPECTED" -> ProxyUnexpectedResponse . B.unpack <$> (A.space *> A.takeByteString) + "SYNTAX" -> ProxyResponseError <$> _strP + _ -> fail "bad ProxyClientError" + +-- consider how to process slow responses - is it handled somehow locally or delegated to the caller +-- this method is used in the client +-- sends PFWD :: C.PublicKeyX25519 -> EncTransmission -> Command Sender +-- receives PRES :: EncResponse -> BrokerMsg -- proxy to client + +-- When client sends message via proxy, there may be one successful scenario and 9 error scenarios +-- as shown below (WTF stands for unexpected response, ??? for response that failed to parse). +-- client proxy relay proxy client +-- 0) PFWD(SEND) -> RFWD -> RRES -> PRES(OK) -> ok +-- 1) PFWD(SEND) -> RFWD -> RRES -> PRES(ERR) -> PCEProtocolError - business logic error for client +-- 2) PFWD(SEND) -> RFWD -> RRES -> PRES(WTF) -> PCEUnexpectedReponse - relay/client protocol logic error +-- 3) PFWD(SEND) -> RFWD -> RRES -> PRES(???) -> PCEResponseError - relay/client syntax error +-- 4) PFWD(SEND) -> RFWD -> ERR -> ERR PROXY PROTOCOL -> ProxyProtocolError - proxy/relay business logic error +-- 5) PFWD(SEND) -> RFWD -> WTF -> ERR PROXY $ BROKER (UNEXPECTED s) -> ProxyProtocolError - proxy/relay protocol logic +-- 6) PFWD(SEND) -> RFWD -> ??? -> ERR PROXY $ BROKER (RESPONSE s) -> ProxyProtocolError - - proxy/relay syntax +-- 7) PFWD(SEND) -> ERR -> ProxyProtocolError - client/proxy business logic +-- 8) PFWD(SEND) -> WTF -> ProxyUnexpectedResponse - client/proxy protocol logic +-- 9) PFWD(SEND) -> ??? -> ProxyResponseError - client/proxy syntax +-- +-- We report as proxySMPCommand error (ExceptT error) the errors of two kinds: +-- - protocol errors from the destination relay wrapped in PRES - to simplify processing of AUTH and QUOTA errors, in this case proxy is "transparent" for such errors (PCEProtocolError, PCEUnexpectedResponse, PCEResponseError) +-- - other response/transport/connection errors from the client connected to proxy itself +-- Other errors are reported in the function result as `Either ProxiedRelayError ()`, including +-- - protocol errors from the client connected to proxy in ProxyClientError (PCEProtocolError, PCEUnexpectedResponse, PCEResponseError) +-- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError + +-- This function proxies Sender commands that return OK or ERR +proxySMPCommand :: + SMPClient -> + -- proxy session from PKEY + ProxiedRelay -> + -- message to deliver + Maybe SndPrivateAuthKey -> + SenderId -> + Command 'Sender -> + ExceptT SMPClientError IO (Either ProxyClientError ()) +proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do + -- prepare params + let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams + serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth} + (cmdPubKey, cmdPrivKey) <- liftIO . atomically $ C.generateKeyPair @'C.X25519 g + let cmdSecret = C.dh' serverKey cmdPrivKey + nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g + -- encode + let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender command) + auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth + b <- case batchTransmissions (batch serverThParams) (blockSize serverThParams) [Right (auth, tToSend)] of + [] -> throwE $ PCETransportError TELargeMsg + TBError e _ : _ -> throwE $ PCETransportError e + TBTransmission s _ : _ -> pure s + TBTransmissions s _ _ : _ -> pure s + et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength + -- proxy interaction errors are wrapped + let tOut = Just $ 2 * tcpTimeout + tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing sessionId (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case + Right r -> case r of + PRES (EncResponse er) -> do + -- server interaction errors are thrown directly + t' <- liftEitherWith PCECryptoError $ C.cbDecrypt cmdSecret (C.reverseNonce nonce) er + case tParse serverThParams t' of + t'' :| [] -> case tDecodeParseValidate serverThParams t'' of + (_auth, _signed, (_c, _e, cmd)) -> case cmd of + Right OK -> pure $ Right () + Right (ERR e) -> throwE $ PCEProtocolError e -- this is the error from the destination relay + Right r' -> throwE $ unexpectedResponse r' + Left e -> throwE $ PCEResponseError e + _ -> throwE $ PCETransportError TEBadBlock + ERR e -> pure . Left $ ProxyProtocolError e -- this will not happen, this error is returned via Left + _ -> pure . Left $ ProxyUnexpectedResponse $ take 32 $ show r + Left e -> case e of + PCEProtocolError e' -> pure . Left $ ProxyProtocolError e' + PCEUnexpectedResponse e' -> pure . Left $ ProxyUnexpectedResponse $ B.unpack e' + PCEResponseError e' -> pure . Left $ ProxyResponseError e' + _ -> throwE e + +-- this method is used in the proxy +-- sends RFWD :: EncFwdTransmission -> Command Sender +-- receives RRES :: EncFwdResponse -> BrokerMsg +-- proxy should send PRES to the client with EncResponse +forwardSMPTransmission :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse +forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do + -- prepare params + sessSecret <- case thAuth thParams of + Nothing -> throwE $ PCETransportError TENoServerAuth + Just THAuthClient {sessSecret} -> maybe (throwE $ PCETransportError TENoServerAuth) pure sessSecret + nonce <- liftIO . atomically $ C.randomCbNonce g + -- wrap + let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission} + eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT) + -- send + sendProtocolCommand_ c (Just nonce) Nothing Nothing "" (Cmd SSender (RFWD eft)) >>= \case + RRES (EncFwdResponse efr) -> do + -- unwrap + r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr + FwdResponse {fwdCorrId = _, fwdResponse} <- liftEitherWith (const $ PCEResponseError BLOCK) $ smpDecode r' + pure fwdResponse + r -> throwE $ unexpectedResponse r + +getSMPQueueInfo :: SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo +getSMPQueueInfo c pKey qId = + sendSMPCommand c (Just pKey) qId QUE >>= \case + INFO info -> pure info + r -> throwE $ unexpectedResponse r + okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO () okSMPCommand cmd c pKey qId = sendSMPCommand c (Just pKey) qId cmd >>= \case OK -> return () - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateAuthKey, QueueId) -> IO (NonEmpty (Either SMPClientError ())) okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs @@ -676,7 +985,7 @@ okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs cs = L.map (\(pKey, qId) -> (Just pKey, qId, aCmd)) qs process (Response _ r) = case r of Right OK -> Right () - Right r' -> Left . PCEUnexpectedResponse $ bshow r' + Right r' -> Left $ unexpectedResponse r' Left e -> Left e -- | Send SMP command @@ -687,7 +996,7 @@ sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd) type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg) -- | Send multiple commands with batching and collect responses -sendProtocolCommands :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg)) +sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg)) sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs validate . concat =<< mapM (sendBatch c) bs @@ -704,91 +1013,134 @@ sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSiz where diff = L.length cs - length rs -streamProtocolCommands :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO () +streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO () streamProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs cb = do bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs mapM_ (cb <=< sendBatch c) bs sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg] -sendBatch c@ProtocolClient {client_ = PClient {rcvConcurrency, sndQ}} b = do +sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do case b of TBError e Request {entityId} -> do putStrLn "send error: large message" pure [Response entityId $ Left $ PCETransportError e] TBTransmissions s n rs | n > 0 -> do - active <- newTVarIO True - atomically $ writeTBQueue sndQ (active, s) - pooledMapConcurrentlyN rcvConcurrency (getResponse c active) rs + atomically $ writeTBQueue sndQ (Nothing, s) -- do not expire batched responses + mapConcurrently (getResponse c Nothing) rs | otherwise -> pure [] TBTransmission s r -> do - active <- newTVarIO True - atomically $ writeTBQueue sndQ (active, s) - (: []) <$> getResponse c active r + atomically $ writeTBQueue sndQ (Nothing, s) + (: []) <$> getResponse c Nothing r -- | Send Protocol command -sendProtocolCommand :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg -sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} pKey entId cmd = - ExceptT $ uncurry sendRecv =<< mkTransmission c (pKey, entId, cmd) +sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg +sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing + +-- Currently there is coupling - batch commands do not expire, and individually sent commands do. +-- This is to reflect the fact that we send subscriptions only as batches, and also because we do not track a separate timeout for the whole batch, so it is not obvious when should we expire it. +-- We could expire a batch of deletes, for example, either when the first response expires or when the last one does. +-- But a better solution is to process delayed delete responses. +sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg +sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} nonce_ tOut pKey entId cmd = + ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (pKey, entId, cmd) where -- two separate "atomically" needed to avoid blocking sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg) - sendRecv t_ r = case t_ of + sendRecv t_ r@Request {pending} = case t_ of Left e -> pure . Left $ PCETransportError e Right t | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg | otherwise -> do - active <- newTVarIO True - atomically (writeTBQueue sndQ (active, s)) - response <$> getResponse c active r + atomically $ writeTBQueue sndQ (Just pending, s) + response <$> getResponse c tOut r where s | batch = tEncodeBatch1 t | otherwise = tEncode t --- TODO switch to timeout or TimeManager that supports Int64 -getResponse :: ProtocolClient v err msg -> TVar Bool -> Request err msg -> IO (Response err msg) -getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount, sentCommands}} active Request {corrId, entityId, responseVar} = do - response <- - timeout tcpTimeout (atomically (takeTMVar responseVar)) >>= \case - Just r -> atomically (writeTVar timeoutErrorCount 0) $> r - Nothing -> do - atomically (writeTVar active False >> TM.delete corrId sentCommands) - atomically $ modifyTVar' timeoutErrorCount (+ 1) - pure $ Left PCEResponseTimeout +getResponse :: ProtocolClient v err msg -> Maybe Int -> Request err msg -> IO (Response err msg) +getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} tOut Request {entityId, pending, responseVar} = do + r <- fromMaybe tcpTimeout tOut `timeout` atomically (takeTMVar responseVar) + response <- atomically $ do + writeTVar pending False + -- Try to read response again in case it arrived after timeout expired + -- but before `pending` was set to False above. + -- See `processMsg`. + ((r <|>) <$> tryTakeTMVar responseVar) >>= \case + Just r' -> writeTVar timeoutErrorCount 0 $> r' + Nothing -> modifyTVar' timeoutErrorCount (+ 1) $> Left PCEResponseTimeout pure Response {entityId, response} -mkTransmission :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg) -mkTransmission ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} (pKey_, entId, cmd) = do - corrId <- atomically getNextCorrId - let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, entId, cmd) - auth = authTransmission (thAuth thParams) pKey_ corrId tForAuth - r <- atomically $ mkRequest corrId +mkTransmission :: Protocol v err msg => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg) +mkTransmission c = mkTransmission_ c Nothing + +mkTransmission_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> ClientCommand msg -> IO (PCTransmission err msg) +mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (pKey_, entityId, command) = do + nonce@(C.CbNonce corrId) <- maybe (atomically $ C.randomCbNonce clientCorrId) pure nonce_ + let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, entityId, command) + auth = authTransmission (thAuth thParams) pKey_ nonce tForAuth + r <- atomically $ mkRequest (CorrId corrId) pure ((,tToSend) <$> auth, r) where - getNextCorrId :: STM CorrId - getNextCorrId = CorrId <$> C.randomBytes 24 clientCorrId -- also used as nonce mkRequest :: CorrId -> STM (Request err msg) mkRequest corrId = do - r <- Request corrId entId <$> newEmptyTMVar + pending <- newTVar True + responseVar <- newEmptyTMVar + let r = + Request + { corrId, + entityId, + command, + pending, + responseVar + } TM.insert corrId r sentCommands pure r -authTransmission :: Maybe (THandleAuth 'TClient) -> Maybe C.APrivateAuthKey -> CorrId -> ByteString -> Either TransportError (Maybe TransmissionAuth) -authTransmission thAuth pKey_ (CorrId corrId) t = traverse authenticate pKey_ +authTransmission :: Maybe (THandleAuth 'TClient) -> Maybe C.APrivateAuthKey -> C.CbNonce -> ByteString -> Either TransportError (Maybe TransmissionAuth) +authTransmission thAuth pKey_ nonce t = traverse authenticate pKey_ where authenticate :: C.APrivateAuthKey -> Either TransportError TransmissionAuth authenticate (C.APrivateAuthKey a pk) = case a of C.SX25519 -> case thAuth of - Just THAuthClient {serverPeerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk (C.cbNonce corrId) t + Just THAuthClient {serverPeerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk nonce t Nothing -> Left TENoServerAuth C.SEd25519 -> sign pk C.SEd448 -> sign pk sign :: forall a. (C.AlgorithmI a, C.SignatureAlgorithm a) => C.PrivateKey a -> Either TransportError TransmissionAuth sign pk = Right $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t) +data TBQueueInfo = TBQueueInfo + { qLength :: Int, + qFull :: Bool + } + deriving (Show) + +getTBQueueInfo :: TBQueue a -> STM TBQueueInfo +getTBQueueInfo q = do + qLength <- fromIntegral <$> lengthTBQueue q + qFull <- isFullTBQueue q + pure TBQueueInfo {qLength, qFull} + +getProtocolClientQueuesInfo :: ProtocolClient v err msg -> IO (TBQueueInfo, TBQueueInfo) +getProtocolClientQueuesInfo ProtocolClient {client_ = PClient {sndQ, rcvQ}} = do + sndQInfo <- atomically $ getTBQueueInfo sndQ + rcvQInfo <- atomically $ getTBQueueInfo rcvQ + pure (sndQInfo, rcvQInfo) + $(J.deriveJSON (enumJSON $ dropPrefix "HM") ''HostMode) +$(J.deriveJSON (enumJSON $ dropPrefix "SM") ''SocksMode) + $(J.deriveJSON (enumJSON $ dropPrefix "TSM") ''TransportSessionMode) +$(J.deriveJSON (enumJSON $ dropPrefix "SPM") ''SMPProxyMode) + +$(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback) + $(J.deriveJSON defaultJSON ''NetworkConfig) + +$(J.deriveJSON (sumTypeJSON $ dropPrefix "Proxy") ''ProxyClientError) + +$(J.deriveJSON defaultJSON ''TBQueueInfo) diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 4b925c6f6..99c77f67c 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,57 +8,53 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Simplex.Messaging.Client.Agent where import Control.Concurrent (forkIO) import Control.Concurrent.Async (Async, uninterruptibleCancel) +import Control.Concurrent.STM (retry) import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Trans.Except -import Control.Monad.Trans.Reader import Crypto.Random (ChaChaDRG) -import Data.Bifunctor (bimap, first) +import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Either (partitionEithers) -import Data.List (partition) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (listToMaybe) import Data.Set (Set) +import qualified Data.Set as S import Data.Text.Encoding +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import Data.Tuple (swap) import Numeric.Natural import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (BrokerMsg, NotifierId, NtfPrivateAuthKey, ProtocolServer (..), QueueId, RcvPrivateAuthKey, RecipientId, SMPServer) +import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, NotifierId, NtfPrivateAuthKey, ProtocolServer (..), QueueId, RcvPrivateAuthKey, RecipientId, SMPServer) import Simplex.Messaging.Session import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport -import Simplex.Messaging.Util (catchAll_, toChunks, ($>>=)) +import Simplex.Messaging.Util (catchAll_, ifM, toChunks, whenM, ($>>=), (<$$>)) import System.Timeout (timeout) import UnliftIO (async) -import UnliftIO.Exception (Exception) import qualified UnliftIO.Exception as E import UnliftIO.STM -type SMPClientVar = SessionVar (Either SMPClientError SMPClient) +type SMPClientVar = SessionVar (Either (SMPClientError, Maybe UTCTime) (OwnServer, SMPClient)) data SMPClientAgentEvent = CAConnected SMPServer | CADisconnected SMPServer (Set SMPSub) - | CAReconnected SMPServer - | CAResubscribed SMPServer (NonEmpty SMPSub) - | CASubError SMPServer (NonEmpty (SMPSub, SMPClientError)) + | CASubscribed SMPServer SMPSubParty (NonEmpty QueueId) + | CASubError SMPServer SMPSubParty (NonEmpty (QueueId, SMPClientError)) data SMPSubParty = SPRecipient | SPNotifier deriving (Eq, Ord, Show) @@ -70,9 +66,11 @@ type SMPSub = (SMPSubParty, QueueId) data SMPClientAgentConfig = SMPClientAgentConfig { smpCfg :: ProtocolClientConfig SMPVersion, reconnectInterval :: RetryInterval, + persistErrorInterval :: NominalDiffTime, msgQSize :: Natural, agentQSize :: Natural, - agentSubsBatchSize :: Int + agentSubsBatchSize :: Int, + ownServerDomains :: [ByteString] } defaultSMPClientAgentConfig :: SMPClientAgentConfig @@ -85,204 +83,227 @@ defaultSMPClientAgentConfig = increaseAfter = 10 * second, maxInterval = 10 * second }, - msgQSize = 256, - agentQSize = 256, - agentSubsBatchSize = 900 + persistErrorInterval = 30, -- seconds + msgQSize = 1024, + agentQSize = 1024, + agentSubsBatchSize = 1360, + ownServerDomains = [] } where second = 1000000 data SMPClientAgent = SMPClientAgent { agentCfg :: SMPClientAgentConfig, - msgQ :: TBQueue (ServerTransmission SMPVersion BrokerMsg), + active :: TVar Bool, + msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg), agentQ :: TBQueue SMPClientAgentEvent, randomDrg :: TVar ChaChaDRG, smpClients :: TMap SMPServer SMPClientVar, + smpSessions :: TMap SessionId (OwnServer, SMPClient), srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey), pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey), - reconnections :: TVar [Async ()], - asyncClients :: TVar [Async ()], + smpSubWorkers :: TMap SMPServer (SessionVar (Async ())), workerSeq :: TVar Int } -newtype InternalException e = InternalException {unInternalException :: e} - deriving (Eq, Show) - -instance Exception e => Exception (InternalException e) - -instance Exception e => MonadUnliftIO (ExceptT e IO) where - {-# INLINE withRunInIO #-} - withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b - withRunInIO inner = - ExceptT . fmap (first unInternalException) . E.try $ - withRunInIO $ \run -> - inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT) - --- as MonadUnliftIO instance for IO is `withRunInIO inner = inner id`, --- the last two lines could be replaced with: --- inner $ either (E.throwIO . InternalException) pure <=< runExceptT - -instance Exception e => MonadUnliftIO (ExceptT e (ReaderT r IO)) where - {-# INLINE withRunInIO #-} - withRunInIO :: ((forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b) -> ExceptT e (ReaderT r IO) b - withRunInIO inner = - withExceptT unInternalException . ExceptT . E.try $ - withRunInIO $ \run -> - inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT) +type OwnServer = Bool newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> STM SMPClientAgent newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do + active <- newTVar True msgQ <- newTBQueue msgQSize agentQ <- newTBQueue agentQSize smpClients <- TM.empty + smpSessions <- TM.empty srvSubs <- TM.empty pendingSrvSubs <- TM.empty - reconnections <- newTVar [] - asyncClients <- newTVar [] + smpSubWorkers <- TM.empty workerSeq <- newTVar 0 pure SMPClientAgent { agentCfg, + active, msgQ, agentQ, randomDrg, smpClients, + smpSessions, srvSubs, pendingSrvSubs, - reconnections, - asyncClients, + smpSubWorkers, workerSeq } +-- | Get or create SMP client for SMPServer getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient -getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ, randomDrg, workerSeq} srv = - atomically getClientVar >>= either newSMPClient waitForSMPClient +getSMPServerClient' ca srv = snd <$> getSMPServerClient'' ca srv +{-# INLINE getSMPServerClient' #-} + +getSMPServerClient'' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO (OwnServer, SMPClient) +getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, workerSeq} srv = do + ts <- liftIO getCurrentTime + atomically (getClientVar ts) >>= either (ExceptT . newSMPClient) waitForSMPClient where - getClientVar :: STM (Either SMPClientVar SMPClientVar) + getClientVar :: UTCTime -> STM (Either SMPClientVar SMPClientVar) getClientVar = getSessVar workerSeq srv smpClients - waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO SMPClient + waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO (OwnServer, SMPClient) waitForSMPClient v = do let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) - liftEither $ case smpClient_ of - Just (Right smpClient) -> Right smpClient - Just (Left e) -> Left e - Nothing -> Left PCEResponseTimeout + case smpClient_ of + Just (Right smpClient) -> pure smpClient + Just (Left (e, ts_)) -> case ts_ of + Nothing -> throwE e + Just ts -> + ifM + ((ts <) <$> liftIO getCurrentTime) + (atomically (removeSessVar v srv smpClients) >> getSMPServerClient'' ca srv) + (throwE e) + Nothing -> throwE PCEResponseTimeout - newSMPClient :: SMPClientVar -> ExceptT SMPClientError IO SMPClient - newSMPClient v = tryConnectClient pure (liftIO tryConnectAsync) - where - tryConnectClient :: (SMPClient -> ExceptT SMPClientError IO a) -> ExceptT SMPClientError IO () -> ExceptT SMPClientError IO a - tryConnectClient successAction retryAction = - tryE (connectClient v) >>= \r -> case r of - Right smp -> do - logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv - atomically $ putTMVar (sessionVar v) r - successAction smp - Left e -> do - if e == PCENetworkError || e == PCEResponseTimeout - then retryAction - else atomically $ do - putTMVar (sessionVar v) (Left e) - removeSessVar v srv smpClients - throwE e - tryConnectAsync :: IO () - tryConnectAsync = do - a <- async $ void $ runExceptT connectAsync - atomically $ modifyTVar' (asyncClients ca) (a :) - connectAsync :: ExceptT SMPClientError IO () - connectAsync = - withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> - void $ tryConnectClient (const reconnectClient) loop + newSMPClient :: SMPClientVar -> IO (Either SMPClientError (OwnServer, SMPClient)) + newSMPClient v = do + r <- connectClient ca srv v `E.catch` (pure . Left . PCEIOError) + case r of + Right smp -> do + logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv + let !owned = isOwnServer ca srv + !c = (owned, smp) + atomically $ do + putTMVar (sessionVar v) (Right c) + TM.insert (sessionId $ thParams smp) c smpSessions + notify ca $ CAConnected srv + pure $ Right c + Left e -> do + let ei = persistErrorInterval agentCfg + if ei == 0 + then atomically $ do + putTMVar (sessionVar v) (Left (e, Nothing)) + removeSessVar v srv smpClients + else do + ts <- addUTCTime ei <$> liftIO getCurrentTime + atomically $ putTMVar (sessionVar v) (Left (e, Just ts)) + reconnectClient ca srv + pure $ Left e - connectClient :: SMPClientVar -> ExceptT SMPClientError IO SMPClient - connectClient v = ExceptT $ getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) (clientDisconnected v) +isOwnServer :: SMPClientAgent -> SMPServer -> OwnServer +isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} = + let srv = strEncode $ L.head host + in any (\s -> s == srv || B.cons '.' s `B.isSuffixOf` srv) (ownServerDomains agentCfg) - clientDisconnected :: SMPClientVar -> SMPClient -> IO () - clientDisconnected v _ = do - removeClientAndSubs v >>= (`forM_` serverDown) +-- | Run an SMP client for SMPClientVar +connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient) +connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg} srv v = + getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected + where + clientDisconnected :: SMPClient -> IO () + clientDisconnected smp = do + removeClientAndSubs smp >>= (`forM_` serverDown) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv - removeClientAndSubs :: SMPClientVar -> IO (Maybe (Map SMPSub C.APrivateAuthKey)) - removeClientAndSubs v = atomically $ do + removeClientAndSubs :: SMPClient -> IO (Maybe (Map SMPSub C.APrivateAuthKey)) + removeClientAndSubs smp = atomically $ do removeSessVar v srv smpClients + TM.delete (sessionId $ thParams smp) smpSessions TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs where updateSubs sVar = do ss <- readTVar sVar - addPendingSubs sVar ss + addSubs_ (pendingSrvSubs ca) srv ss pure ss - addPendingSubs sVar ss = do - let ps = pendingSrvSubs ca - TM.lookup srv ps >>= \case - Just ss' -> TM.union ss ss' - _ -> TM.insert srv sVar ps - serverDown :: Map SMPSub C.APrivateAuthKey -> IO () serverDown ss = unless (M.null ss) $ do - notify . CADisconnected srv $ M.keysSet ss - reconnectServer + notify ca . CADisconnected srv $ M.keysSet ss + reconnectClient ca srv - reconnectServer :: IO () - reconnectServer = do - a <- async $ void $ runExceptT tryReconnectClient - atomically $ modifyTVar' (reconnections ca) (a :) +-- | Spawn reconnect worker if needed +reconnectClient :: SMPClientAgent -> SMPServer -> IO () +reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} srv = do + ts <- getCurrentTime + whenM (readTVarIO active) $ atomically (getWorkerVar ts) >>= mapM_ (either newSubWorker (\_ -> pure ())) + where + getWorkerVar ts = + ifM + (null <$> getPending) + (pure Nothing) -- prevent race with cleanup and adding pending queues in another call + (Just <$> getSessVar workerSeq srv smpSubWorkers ts) + newSubWorker :: SessionVar (Async ()) -> IO () + newSubWorker v = do + a <- async $ void (E.tryAny runSubWorker) >> atomically (cleanup v) + atomically $ putTMVar (sessionVar v) a + runSubWorker = + withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do + pending <- atomically getPending + unless (null pending) $ whenM (readTVarIO active) $ do + void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv pending) + loop + ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg + getPending = maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca) + cleanup :: SessionVar (Async ()) -> STM () + cleanup v = do + -- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar. + -- Not waiting may result in terminated worker remaining in the map. + whenM (isEmptyTMVar $ sessionVar v) retry + removeSessVar v srv smpSubWorkers - tryReconnectClient :: ExceptT SMPClientError IO () - tryReconnectClient = do - withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> - reconnectClient `catchE` const loop - - reconnectClient :: ExceptT SMPClientError IO () - reconnectClient = do - withSMP ca srv $ \smp -> do - liftIO $ notify $ CAReconnected srv - cs_ <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca) - forM_ cs_ $ \cs -> do - subs' <- filterM (fmap not . atomically . hasSub (srvSubs ca) srv . fst) $ M.assocs cs - let (nSubs, rSubs) = partition (isNotifier . fst . fst) subs' - subscribe_ smp SPNotifier nSubs - subscribe_ smp SPRecipient rSubs +reconnectSMPClient :: SMPClientAgent -> SMPServer -> Map SMPSub C.APrivateAuthKey -> ExceptT SMPClientError IO () +reconnectSMPClient ca@SMPClientAgent {agentCfg} srv cs = + withSMP ca srv $ \smp -> liftIO $ do + currSubs <- atomically $ maybe (pure M.empty) readTVar =<< TM.lookup srv (srvSubs ca) + let (nSubs, rSubs) = foldr (groupSub currSubs) ([], []) $ M.assocs cs + subscribe_ smp SPNotifier nSubs + subscribe_ smp SPRecipient rSubs + where + groupSub :: Map SMPSub C.APrivateAuthKey -> (SMPSub, C.APrivateAuthKey) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)]) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)]) + groupSub currSubs (s@(party, qId), k) (nSubs, rSubs) + | M.member s currSubs = (nSubs, rSubs) + | otherwise = case party of + SPNotifier -> (s' : nSubs, rSubs) + SPRecipient -> (nSubs, s' : rSubs) where - isNotifier = \case - SPNotifier -> True - SPRecipient -> False + s' = (qId, k) + subscribe_ :: SMPClient -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> IO () + subscribe_ smp party = mapM_ (smpSubscribeQueues party ca smp srv) . toChunks (agentSubsBatchSize agentCfg) - subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateAuthKey)] -> ExceptT SMPClientError IO () - subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg) - where - subscribeBatch subs' = do - let subs'' :: (NonEmpty (QueueId, C.APrivateAuthKey)) = L.map (first snd) subs' - rs <- liftIO $ smpSubscribeQueues party ca smp srv subs'' - let rs' :: (NonEmpty ((SMPSub, C.APrivateAuthKey), Either SMPClientError ())) = - L.zipWith (first . const) subs' rs - rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateAuthKey)] = - map (\(sub, r) -> bimap (fst sub,) (const sub) r) $ L.toList rs' - (errs, oks) = partitionEithers rs'' - (tempErrs, finalErrs) = partition (temporaryClientError . snd) errs - mapM_ (atomically . addSubscription ca srv) oks - mapM_ (liftIO . notify . CAResubscribed srv) $ L.nonEmpty $ map fst oks - mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs - mapM_ (liftIO . notify . CASubError srv) $ L.nonEmpty finalErrs - mapM_ (throwE . snd) $ listToMaybe tempErrs +notify :: MonadIO m => SMPClientAgent -> SMPClientAgentEvent -> m () +notify ca evt = atomically $ writeTBQueue (agentQ ca) evt +{-# INLINE notify #-} - notify :: SMPClientAgentEvent -> IO () - notify evt = atomically $ writeTBQueue (agentQ ca) evt +-- Returns already connected client for proxying messages or Nothing if client is absent, not connected yet or stores expired error. +-- If Nothing is return proxy will spawn a new thread to wait or to create another client connection to destination relay. +getConnectedSMPServerClient :: SMPClientAgent -> SMPServer -> IO (Maybe (Either SMPClientError (OwnServer, SMPClient))) +getConnectedSMPServerClient SMPClientAgent {smpClients} srv = + atomically (TM.lookup srv smpClients $>>= \v -> (v,) <$$> tryReadTMVar (sessionVar v)) -- Nothing: client is absent or not connected yet + $>>= \case + (_, Right r) -> pure $ Just $ Right r + (v, Left (e, ts_)) -> + pure ts_ $>>= \ts -> + -- proxy will create a new connection if ts_ is Nothing + ifM + ((ts <) <$> liftIO getCurrentTime) -- error persistence interval period expired? + (Nothing <$ atomically (removeSessVar v srv smpClients)) -- proxy will create a new connection + (pure $ Just $ Left e) -- not expired, returning error + +lookupSMPServerClient :: SMPClientAgent -> SessionId -> STM (Maybe (OwnServer, SMPClient)) +lookupSMPServerClient SMPClientAgent {smpSessions} sessId = TM.lookup sessId smpSessions closeSMPClientAgent :: SMPClientAgent -> IO () closeSMPClientAgent c = do + atomically $ writeTVar (active c) False closeSMPServerClients c - cancelActions $ reconnections c - cancelActions $ asyncClients c + atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect + where + cancelReconnect :: SessionVar (Async ()) -> IO () + cancelReconnect v = void . forkIO $ atomically (readTMVar $ sessionVar v) >>= uninterruptibleCancel closeSMPServerClients :: SMPClientAgent -> IO () closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient) where closeClient v = atomically (readTMVar $ sessionVar v) >>= \case - Right smp -> closeProtocolClient smp `catchAll_` pure () + Right (_, smp) -> closeProtocolClient smp `catchAll_` pure () _ -> pure () cancelActions :: Foldable f => TVar (f (Async ())) -> IO () @@ -296,86 +317,99 @@ withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPE liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e throwE e -subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO () -subscribeQueue ca srv sub = do - atomically $ addPendingSubscription ca srv sub - withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleErr - where - subscribe_ smp = do - smpSubscribe smp sub - atomically $ addSubscription ca srv sub - - handleErr e = do - atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $ - removePendingSubscription ca srv (fst sub) - throwE e - -subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ())) +subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO () subscribeQueuesSMP = subscribeQueues_ SPRecipient -subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ())) +subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO () subscribeQueuesNtfs = subscribeQueues_ SPNotifier -subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) +subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO () subscribeQueues_ party ca srv subs = do - atomically $ forM_ subs $ addPendingSubscription ca srv . first (party,) + atomically $ addPendingSubs ca srv party $ L.toList subs runExceptT (getSMPServerClient' ca srv) >>= \case - Left e -> pure $ L.map ((,Left e) . fst) subs Right smp -> smpSubscribeQueues party ca smp srv subs + Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that -smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) +smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO () smpSubscribeQueues party ca smp srv subs = do - rs <- L.zip subs <$> subscribe smp (L.map swap subs) - atomically $ forM rs $ \(sub, r) -> - (fst sub,) <$> case r of - Right () -> do - addSubscription ca srv $ first (party,) sub - pure $ Right () - Left e -> do - when (e /= PCENetworkError && e /= PCEResponseTimeout) $ - removePendingSubscription ca srv (party, fst sub) - pure $ Left e + rs <- subscribe smp $ L.map swap subs + rs' <- + atomically $ + ifM + (activeClientSession ca smp srv) + (Just <$> processSubscriptions rs) + (pure Nothing) + case rs' of + Just (tempErrs, finalErrs, oks, _) -> do + notify_ CASubscribed $ map fst oks + notify_ CASubError finalErrs + when tempErrs $ reconnectClient ca srv + Nothing -> reconnectClient ca srv where + processSubscriptions :: NonEmpty (Either SMPClientError ()) -> STM (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId]) + processSubscriptions rs = do + pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca) + let acc@(_, _, oks, notPending) = foldr (groupSub pending) (False, [], [], []) (L.zip subs rs) + unless (null oks) $ addSubscriptions ca srv party oks + unless (null notPending) $ removePendingSubs ca srv party notPending + pure acc + groupSub :: Map SMPSub C.APrivateAuthKey -> ((QueueId, C.APrivateAuthKey), Either SMPClientError ()) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId]) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId]) + groupSub pending (s@(qId, _), r) acc@(!tempErrs, finalErrs, oks, notPending) = case r of + Right () + | M.member (party, qId) pending -> (tempErrs, finalErrs, s : oks, qId : notPending) + | otherwise -> acc + Left e + | temporaryClientError e -> (True, finalErrs, oks, notPending) + | otherwise -> (tempErrs, (qId, e) : finalErrs, oks, qId : notPending) subscribe = case party of SPRecipient -> subscribeSMPQueues SPNotifier -> subscribeSMPQueuesNtfs + notify_ :: (SMPServer -> SMPSubParty -> NonEmpty a -> SMPClientAgentEvent) -> [a] -> IO () + notify_ evt qs = mapM_ (notify ca . evt srv party) $ L.nonEmpty qs + +activeClientSession :: SMPClientAgent -> SMPClient -> SMPServer -> STM Bool +activeClientSession ca smp srv = sameSess <$> tryReadSessVar srv (smpClients ca) + where + sessId = sessionId . thParams + sameSess = \case + Just (Right (_, smp')) -> sessId smp == sessId smp' + _ -> False showServer :: SMPServer -> ByteString showServer ProtocolServer {host, port} = strEncode host <> B.pack (if null port then "" else ':' : port) -smpSubscribe :: SMPClient -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO () -smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId +addSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM () +addSubscriptions = addSubsList_ . srvSubs +{-# INLINE addSubscriptions #-} + +addPendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM () +addPendingSubs = addSubsList_ . pendingSrvSubs +{-# INLINE addPendingSubs #-} + +addSubsList_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM () +addSubsList_ subs srv party ss = addSubs_ subs srv ss' where - subscribe_ = case party of - SPRecipient -> subscribeSMPQueue - SPNotifier -> subscribeSMPQueueNotifications + ss' = M.fromList $ map (first (party,)) ss -addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () -addSubscription ca srv sub = do - addSub_ (srvSubs ca) srv sub - removePendingSubscription ca srv $ fst sub - -addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () -addPendingSubscription = addSub_ . pendingSrvSubs - -addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () -addSub_ subs srv (s, key) = +addSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> Map SMPSub C.APrivateAuthKey -> STM () +addSubs_ subs srv ss = TM.lookup srv subs >>= \case - Just m -> TM.insert s key m - _ -> TM.singleton s key >>= \v -> TM.insert srv v subs + Just m -> TM.union ss m + _ -> newTVar ss >>= \v -> TM.insert srv v subs removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM () removeSubscription = removeSub_ . srvSubs - -removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM () -removePendingSubscription = removeSub_ . pendingSrvSubs +{-# INLINE removeSubscription #-} removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM () removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s) -getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateAuthKey) -getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s +removePendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM () +removePendingSubs = removeSubs_ . pendingSrvSubs +{-# INLINE removePendingSubs #-} -hasSub :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM Bool -hasSub subs srv s = maybe (pure False) (TM.member s) =<< TM.lookup srv subs +removeSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSubParty -> [QueueId] -> STM () +removeSubs_ subs srv party qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` ss)) + where + ss = S.fromList $ map (party,) qs diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 28183a1fc..7aefbd709 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -141,6 +141,7 @@ module Simplex.Messaging.Crypto sbEncrypt_, cbNonce, randomCbNonce, + reverseNonce, -- * NaCl crypto_secretbox SbKey (unSbKey), @@ -756,6 +757,8 @@ data Signature (a :: Algorithm) where SignatureEd25519 :: Ed25519.Signature -> Signature Ed25519 SignatureEd448 :: Ed448.Signature -> Signature Ed448 +deriving instance Eq (Signature a) + deriving instance Show (Signature a) data ASignature @@ -1290,6 +1293,9 @@ randomCbNonce = fmap CryptoBoxNonce . randomBytes 24 randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString randomBytes n gVar = stateTVar gVar $ randomBytesGenerate n +reverseNonce :: CbNonce -> CbNonce +reverseNonce (CryptoBoxNonce s) = CryptoBoxNonce (B.reverse s) + instance Encoding CbNonce where smpEncode = unCbNonce smpP = CryptoBoxNonce <$> A.take 24 diff --git a/src/Simplex/Messaging/Crypto/File.hs b/src/Simplex/Messaging/Crypto/File.hs index 2787df58e..3ab491946 100644 --- a/src/Simplex/Messaging/Crypto/File.hs +++ b/src/Simplex/Messaging/Crypto/File.hs @@ -23,6 +23,7 @@ where import Control.Exception import Control.Monad import Control.Monad.Except +import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import qualified Data.Aeson.TH as J import qualified Data.ByteArray as BA @@ -31,7 +32,6 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) -import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Lazy (LazyByteString) import qualified Simplex.Messaging.Crypto.Lazy as LC @@ -57,10 +57,10 @@ readFile (CryptoFile path cfArgs) = do case cfArgs of Just (CFArgs (C.SbKey key) (C.CbNonce nonce)) -> do let len = LB.length s - fromIntegral C.authTagSize - when (len < 0) $ throwError FTCEInvalidFileSize + when (len < 0) $ throwE FTCEInvalidFileSize let (s', tag') = LB.splitAt len s (tag :| cs) <- liftEitherWith FTCECryptoError $ LC.secretBox LC.sbDecryptChunk key nonce s' - unless (BA.constEq (LB.toStrict tag') tag) $ throwError FTCEInvalidAuthTag + unless (BA.constEq (LB.toStrict tag') tag) $ throwE FTCEInvalidAuthTag pure $ LB.fromChunks cs Nothing -> pure s @@ -97,7 +97,7 @@ hGetTag :: CryptoFileHandle -> ExceptT FTCryptoError IO () hGetTag (CFHandle h sb_) = forM_ sb_ $ \sb -> do tag <- liftIO $ B.hGet h C.authTagSize tag' <- LC.sbAuth <$> readTVarIO sb - unless (BA.constEq tag tag') $ throwError FTCEInvalidAuthTag + unless (BA.constEq tag tag') $ throwE FTCEInvalidAuthTag data FTCryptoError = FTCECryptoError C.CryptoError diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 6ab84aa30..148d931a9 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -117,7 +117,7 @@ import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON, parseE, parseE') -import Simplex.Messaging.Util ((<$?>), ($>>=)) +import Simplex.Messaging.Util (($>>=), (<$?>)) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal import UnliftIO.STM @@ -166,9 +166,9 @@ instance TestEquality SRatchetKEMState where class RatchetKEMStateI (s :: RatchetKEMState) where sRatchetKEMState :: SRatchetKEMState s -instance RatchetKEMStateI RKSProposed where sRatchetKEMState = SRKSProposed +instance RatchetKEMStateI 'RKSProposed where sRatchetKEMState = SRKSProposed -instance RatchetKEMStateI RKSAccepted where sRatchetKEMState = SRKSAccepted +instance RatchetKEMStateI 'RKSAccepted where sRatchetKEMState = SRKSAccepted checkRatchetKEMState :: forall t s s' a. (RatchetKEMStateI s, RatchetKEMStateI s') => t s' a -> Either String (t s a) checkRatchetKEMState x = case testEquality (sRatchetKEMState @s) (sRatchetKEMState @s') of @@ -266,6 +266,7 @@ instance VersionRangeI E2EVersion (E2ERatchetParamsUri s a) where type VersionT E2EVersion (E2ERatchetParamsUri s a) = (E2ERatchetParams s a) versionRange (E2ERatchetParamsUri vr _ _ _) = vr toVersionT (E2ERatchetParamsUri _ k1 k2 kem_) v = E2ERatchetParams v k1 k2 kem_ + toVersionRange (E2ERatchetParamsUri _ k1 k2 kem_) vr = E2ERatchetParamsUri vr k1 k2 kem_ type RcvE2ERatchetParamsUri a = E2ERatchetParamsUri 'RKSProposed a @@ -377,13 +378,15 @@ generateE2EParams g v useKEM_ = do where kemParams :: IO (Maybe (RKEMParams s, PrivRKEMParams s)) kemParams = case useKEM_ of - Just useKem | v >= pqRatchetE2EEncryptVersion -> Just <$> do - ks@(k, _) <- sntrup761Keypair g - case useKem of - ProposeKEM -> pure (RKParamsProposed k, PrivateRKParamsProposed ks) - AcceptKEM k' -> do - (ct, shared) <- sntrup761Enc g k' - pure (RKParamsAccepted ct k, PrivateRKParamsAccepted ct shared ks) + Just useKem + | v >= pqRatchetE2EEncryptVersion -> + Just <$> do + ks@(k, _) <- sntrup761Keypair g + case useKem of + ProposeKEM -> pure (RKParamsProposed k, PrivateRKParamsProposed ks) + AcceptKEM k' -> do + (ct, shared) <- sntrup761Enc g k' + pure (RKParamsAccepted ct k, PrivateRKParamsAccepted ct shared ks) _ -> pure Nothing -- used by party initiating connection, Bob in double-ratchet spec @@ -444,7 +447,7 @@ pqX3dhRcv rpk1 rpk2 rpKem_ (E2ERatchetParams v sk1 sk2 sKem_) = do Just (PrivateRKParamsProposed ks@(_, pk)) -> do shared <- liftIO $ sntrup761Dec ct pk pure $ Just (ks, RatchetKEMAccepted k' shared ct) - Nothing -> throwError CERatchetKEMState + Nothing -> throwE CERatchetKEMState _ -> pure Nothing -- both parties can send "proposal" in case of ratchet renegotiation pqX3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> Maybe RatchetKEMAccepted -> RatchetInitParams @@ -456,7 +459,7 @@ pqX3dh (sk1, rk1) dh1 dh2 dh3 kemAccepted = pq = maybe "" (\RatchetKEMAccepted {rcPQRss = KEMSharedKey ss} -> BA.convert ss) kemAccepted (hk, nhk, sk) = let salt = B.replicate 64 '\0' - in hkdf3 salt dhs "SimpleXX3DH" + in hkdf3 salt dhs "SimpleXX3DH" type RatchetX448 = Ratchet 'X448 @@ -698,8 +701,8 @@ data EncMessageHeader = EncMessageHeader -- this encoding depends on version in EncMessageHeader because it is "current" ratchet version instance Encoding EncMessageHeader where - smpEncode EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody} - = smpEncode (ehVersion, ehIV, ehAuthTag) <> encodeLarge ehVersion ehBody + smpEncode EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody} = + smpEncode (ehVersion, ehIV, ehAuthTag) <> encodeLarge ehVersion ehBody smpP = do (ehVersion, ehIV, ehAuthTag) <- smpP ehBody <- largeP @@ -708,8 +711,6 @@ instance Encoding EncMessageHeader where -- the encoder always uses 2-byte lengths for the new version, even for short headers without PQ keys. encodeLarge :: VersionE2E -> ByteString -> ByteString encodeLarge v s - -- the condition for length is not necessary, it's here as a fallback. - -- | v >= pqRatchetE2EEncryptVersion || B.length s > 255 = smpEncode $ Large s | v >= pqRatchetE2EEncryptVersion = smpEncode $ Large s | otherwise = smpEncode s @@ -729,8 +730,8 @@ data EncRatchetMessage = EncRatchetMessage } encodeEncRatchetMessage :: VersionE2E -> EncRatchetMessage -> ByteString -encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag} - = encodeLarge v emHeader <> smpEncode (emAuthTag, Tail emBody) +encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag} = + encodeLarge v emHeader <> smpEncode (emAuthTag, Tail emBody) encRatchetMessageP :: Parser EncRatchetMessage encRatchetMessageP = do diff --git a/src/Simplex/Messaging/Encoding/String.hs b/src/Simplex/Messaging/Encoding/String.hs index fcefdc73d..6b9fb5624 100644 --- a/src/Simplex/Messaging/Encoding/String.hs +++ b/src/Simplex/Messaging/Encoding/String.hs @@ -75,6 +75,8 @@ instance StrEncoding Str where strEncode = unStr strP = Str <$> A.takeTill (== ' ') <* optional A.space +-- inherited from ByteString, the parser only allows non-empty strings +-- only Char8 elements may round-trip as B.pack truncates unicode instance StrEncoding String where strEncode = strEncode . B.pack strP = B.unpack <$> strP diff --git a/src/Simplex/Messaging/Notifications/Client.hs b/src/Simplex/Messaging/Notifications/Client.hs index 72a92c278..32d92faf3 100644 --- a/src/Simplex/Messaging/Notifications/Client.hs +++ b/src/Simplex/Messaging/Notifications/Client.hs @@ -10,22 +10,21 @@ import Data.Word (Word16) import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol -import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange) +import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes) import Simplex.Messaging.Protocol (ErrorType) -import Simplex.Messaging.Util (bshow) type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse type NtfClientError = ProtocolClientError ErrorType defaultNTFClientConfig :: ProtocolClientConfig NTFVersion -defaultNTFClientConfig = defaultClientConfig supportedClientNTFVRange +defaultNTFClientConfig = defaultClientConfig (Just supportedNTFHandshakes) supportedClientNTFVRange ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519) ntfRegisterToken c pKey newTkn = sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case NRTknId tknId dhKey -> pure (tknId, dhKey) - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO () ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId @@ -34,7 +33,7 @@ ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClie ntfCheckToken c pKey tknId = sendNtfCommand c (Just pKey) tknId TCHK >>= \case NRTkn stat -> pure stat - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO () ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId @@ -49,13 +48,13 @@ ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscri ntfCreateSubscription c pKey newSub = sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case NRSubId subId -> pure subId - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus ntfCheckSubscription c pKey subId = sendNtfCommand c (Just pKey) subId SCHK >>= \case NRSub stat -> pure stat - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO () ntfDeleteSubscription = okNtfCommand SDEL @@ -68,4 +67,4 @@ okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey - okNtfCommand cmd c pKey entId = sendNtfCommand c (Just pKey) entId cmd >>= \case NROk -> return () - r -> throwE . PCEUnexpectedResponse $ bshow r + r -> throwE $ unexpectedResponse r diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index b79665c87..2bf8dbcbf 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -31,7 +31,7 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) import Data.Time.Clock.System (getSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import Network.Socket (ServiceName) -import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError) +import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmission (..)) import Simplex.Messaging.Client.Agent import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -98,7 +98,9 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do stopServer = do withNtfLog closeStoreLog saveServerStats - asks (smpSubscribers . subscriber) >>= readTVarIO >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (liftIO . deRefWeak >=> mapM_ killThread)) + NtfSubscriber {smpSubscribers, smpAgent} <- asks subscriber + liftIO $ readTVarIO smpSubscribers >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (deRefWeak >=> mapM_ killThread)) + liftIO $ closeSMPClientAgent smpAgent serverStatsThread_ :: NtfServerConfig -> [M ()] serverStatsThread_ NtfServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = @@ -186,70 +188,58 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge runSMPSubscriber :: SMPSubscriber -> M () runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} = forever $ do - subs <- atomically (peekTQueue subscriberSubQ) + subs <- atomically $ readTQueue subscriberSubQ let subs' = L.map (\(NtfSub sub) -> sub) subs srv = server $ L.head subs logSubStatus srv "subscribing" $ length subs mapM_ (\NtfSubData {smpQueue} -> updateSubStatus smpQueue NSPending) subs' - rs <- liftIO $ subscribeQueues srv subs' - (subs'', oks, errs) <- foldM process ([], 0, []) rs - atomically $ do - void $ readTQueue subscriberSubQ - mapM_ (writeTQueue subscriberSubQ . L.map NtfSub) $ L.nonEmpty subs'' - logSubStatus srv "retrying" $ length subs'' - logSubStatus srv "subscribed" oks - logSubErrors srv errs - where - process :: ([NtfSubData], Int, [NtfSubStatus]) -> (NtfSubData, Either SMPClientError ()) -> M ([NtfSubData], Int, [NtfSubStatus]) - process (subs, oks, errs) (sub@NtfSubData {smpQueue}, r) = case r of - Right _ -> updateSubStatus smpQueue NSActive $> (subs, oks + 1, errs) - Left e -> update <$> handleSubError smpQueue e - where - update = \case - Just err -> (subs, oks, err : errs) -- permanent error, log and don't retry subscription - Nothing -> (sub : subs, oks, errs) -- temporary error, retry subscription + liftIO $ subscribeQueues srv subs' -- \| Subscribe to queues. The list of results can have a different order. - subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO (NonEmpty (NtfSubData, Either SMPClientError ())) - subscribeQueues srv subs = - L.zipWith (\s r -> (s, snd r)) subs <$> subscribeQueuesNtfs ca srv (L.map sub subs) + subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO () + subscribeQueues srv subs = subscribeQueuesNtfs ca srv (L.map sub subs) where sub NtfSubData {smpQueue = SMPQueueNtf {notifierId}, notifierKey} = (notifierId, notifierKey) receiveSMP :: M () receiveSMP = forever $ do - ((_, srv, _), _, _, _, ntfId, msg) <- atomically $ readTBQueue msgQ - let smpQueue = SMPQueueNtf srv ntfId - case msg of - SMP.NMSG nmsgNonce encNMsgMeta -> do - ntfTs <- liftIO getSystemTime - st <- asks store - NtfPushServer {pushQ} <- asks pushServer - stats <- asks serverStats - atomically $ updatePeriodStats (activeSubs stats) ntfId - atomically $ - findNtfSubscriptionToken st smpQueue - >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta})) - incNtfStat ntfReceived - SMP.END -> updateSubStatus smpQueue NSEnd - _ -> pure () + ((_, srv, _), _, _, ts) <- atomically $ readTBQueue msgQ + forM ts $ \(ntfId, t) -> case t of + STUnexpectedError e -> logError $ "SMP client unexpected error: " <> tshow e -- uncorrelated response, should not happen + STResponse {} -> pure () -- it was already reported as timeout error + STEvent msgOrErr -> do + let smpQueue = SMPQueueNtf srv ntfId + case msgOrErr of + Right (SMP.NMSG nmsgNonce encNMsgMeta) -> do + ntfTs <- liftIO getSystemTime + st <- asks store + NtfPushServer {pushQ} <- asks pushServer + stats <- asks serverStats + atomically $ updatePeriodStats (activeSubs stats) ntfId + atomically $ + findNtfSubscriptionToken st smpQueue + >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta})) + incNtfStat ntfReceived + Right SMP.END -> updateSubStatus smpQueue NSEnd + Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e + Right _ -> logError "SMP server unexpected response" + Left e -> logError $ "SMP client error: " <> tshow e receiveAgent = forever $ atomically (readTBQueue agentQ) >>= \case - CAConnected _ -> pure () + CAConnected srv -> + logInfo $ "SMP server reconnected " <> showServer' srv CADisconnected srv subs -> do logSubStatus srv "disconnected" $ length subs forM_ subs $ \(_, ntfId) -> do let smpQueue = SMPQueueNtf srv ntfId updateSubStatus smpQueue NSInactive - CAReconnected srv -> - logInfo $ "SMP server reconnected " <> showServer' srv - CAResubscribed srv subs -> do - forM_ subs $ \(_, ntfId) -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive - logSubStatus srv "resubscribed" $ length subs - CASubError srv errs -> - forM errs (\((_, ntfId), err) -> handleSubError (SMPQueueNtf srv ntfId) err) + CASubscribed srv _ subs -> do + forM_ subs $ \ntfId -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive + logSubStatus srv "subscribed" $ length subs + CASubError srv _ errs -> + forM errs (\(ntfId, err) -> handleSubError (SMPQueueNtf srv ntfId) err) >>= logSubErrors srv . catMaybes . L.toList logSubStatus srv event n = @@ -375,7 +365,7 @@ send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO () send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do t <- atomically $ readTBQueue sndQ void . liftIO $ tPut h [Right (Nothing, encodeTransmission params t)] - atomically . writeTVar sndActiveAt =<< liftIO getSystemTime + atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime -- instance Show a => Show (TVar a) where -- show x = unsafePerformIO $ show <$> readTVarIO x diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 5bcd72f3d..5ebd5230e 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -34,7 +34,7 @@ import Simplex.Messaging.Server.Expiration import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..)) -import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams) +import Simplex.Messaging.Transport.Server (TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams) import System.IO (IOMode (..)) import System.Mem.Weak (Weak) import UnliftIO.STM @@ -84,7 +84,7 @@ data NtfEnv = NtfEnv } newNtfServerEnv :: NtfServerConfig -> IO NtfEnv -newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do +newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do random <- liftIO C.newRandom store <- atomically newNtfStore logInfo "restoring subscriptions..." @@ -92,7 +92,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo logInfo "restored subscriptions" subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg random pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig - tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile + tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig) Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index a8d16d85d..477b12bfc 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -7,24 +7,28 @@ module Simplex.Messaging.Notifications.Server.Main where +import Control.Monad ((<$!>)) import Data.Functor (($>)) import Data.Ini (lookupValue, readIniFile) import Data.Maybe (fromMaybe) import qualified Data.Text as T +import qualified Data.Text.IO as T import Network.Socket (HostName) import Options.Applicative -import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig) +import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig) +import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Server (runNtfServer) import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration) import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig) -import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange) +import Simplex.Messaging.Notifications.Transport (supportedNTFHandshakes, supportedServerNTFVRange) import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig) +import Simplex.Messaging.Util (tshow) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (combine) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) @@ -65,7 +69,7 @@ ntfServerCLI cfgPath logPath = fp <- createServerX509 cfgPath x509cfg let host = fromMaybe (if ip == "127.0.0.1" then "" else ip) fqdn srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp)) Nothing - writeFile iniFile $ iniFileContent host + T.writeFile iniFile $ iniFileContent host putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server." warnCAPrivateKeyFile cfgPath x509cfg printServiceInfo serverVersion srv @@ -81,15 +85,23 @@ ntfServerCLI cfgPath logPath = <> "log_stats: off\n\n\ \[TRANSPORT]\n\ \# host is only used to print server address on start\n" - <> ("host: " <> host <> "\n") - <> ("port: " <> defaultServerPort <> "\n") + <> ("host: " <> T.pack host <> "\n") + <> ("port: " <> T.pack defaultServerPort <> "\n") <> "log_tls_errors: off\n" <> "websockets: off\n\n\ + \[SUBSCRIBER]\n\ + \# Network configuration for notification server client.\n\ + \# SOCKS proxy port for subscribing to SMP servers.\n\ + \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\ + \# socks_proxy: localhost:9050\n\n\ + \# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\ + \# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\ + \# socks_mode: onion\n\n\ \[INACTIVE_CLIENTS]\n\ \# TTL and interval to check inactive clients\n\ \disconnect: off\n" - <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n") - <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n") + <> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n") + <> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n") runServer ini = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering @@ -113,7 +125,18 @@ ntfServerCLI cfgPath logPath = clientQSize = 64, subQSize = 512, pushQSize = 1048, - smpAgentCfg = defaultSMPClientAgentConfig, + smpAgentCfg = + defaultSMPClientAgentConfig + { smpCfg = + (smpCfg defaultSMPClientAgentConfig) + { networkConfig = + defaultNetworkConfig + { socksProxy = either error id <$!> strDecodeIni "SUBSCRIBER" "socks_proxy" ini, + socksMode = either (const SMOnion) textToSocksMode $ lookupValue "SUBSCRIBER" "socks_mode" ini + } + }, + persistErrorInterval = 0 -- seconds + }, apnsConfig = defaultAPNSPushClientConfig, subsBatchSize = 900, inactiveClientExpiration = @@ -133,7 +156,8 @@ ntfServerCLI cfgPath logPath = ntfServerVRange = supportedServerNTFVRange, transportConfig = defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini + { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini, + alpn = Just supportedNTFHandshakes } } diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 151f5e044..2632ff4b4 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -15,6 +15,7 @@ import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Control.Monad.Trans.Except import Crypto.Hash.Algorithms (SHA256 (..)) import qualified Crypto.PubKey.ECC.ECDSA as EC import qualified Crypto.PubKey.ECC.Types as ECT @@ -353,18 +354,18 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke | status == Just N.ok200 = pure () | status == Just N.badRequest400 = case reason' of - "BadDeviceToken" -> throwError PPTokenInvalid - "DeviceTokenNotForTopic" -> throwError PPTokenInvalid - "TopicDisallowed" -> throwError PPPermanentError + "BadDeviceToken" -> throwE PPTokenInvalid + "DeviceTokenNotForTopic" -> throwE PPTokenInvalid + "TopicDisallowed" -> throwE PPPermanentError _ -> err status reason' | status == Just N.forbidden403 = case reason' of - "ExpiredProviderToken" -> throwError PPPermanentError -- there should be no point retrying it as the token was refreshed - "InvalidProviderToken" -> throwError PPPermanentError + "ExpiredProviderToken" -> throwE PPPermanentError -- there should be no point retrying it as the token was refreshed + "InvalidProviderToken" -> throwE PPPermanentError _ -> err status reason' - | status == Just N.gone410 = throwError PPTokenInvalid - | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwError PPRetryLater + | status == Just N.gone410 = throwE PPTokenInvalid + | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwE PPRetryLater -- Just tooManyRequests429 -> TooManyRequests - too many requests for the same token | otherwise = err status reason' err :: Maybe Status -> Text -> ExceptT PushProviderError IO () - err s r = throwError $ PPResponseError s r + err s r = throwE $ PPResponseError s r liftHTTPS2 a = ExceptT $ first PPConnection <$> a diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index e2c287437..77a598c5c 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -11,6 +11,7 @@ module Simplex.Messaging.Notifications.Transport where import Control.Monad (forM) import Control.Monad.Except +import Control.Monad.Trans.Except import Data.Attoparsec.ByteString.Char8 (Parser) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -44,7 +45,7 @@ authBatchCmdsNTFVersion :: VersionNTF authBatchCmdsNTFVersion = VersionNTF 2 currentClientNTFVersion :: VersionNTF -currentClientNTFVersion = VersionNTF 1 +currentClientNTFVersion = VersionNTF 2 currentServerNTFVersion :: VersionNTF currentServerNTFVersion = VersionNTF 2 @@ -52,9 +53,15 @@ currentServerNTFVersion = VersionNTF 2 supportedClientNTFVRange :: VersionRangeNTF supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion +legacyServerNTFVRange :: VersionRangeNTF +legacyServerNTFVRange = mkVersionRange initialNTFVersion initialNTFVersion + supportedServerNTFVRange :: VersionRangeNTF supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion +supportedNTFHandshakes :: [ALPN] +supportedNTFHandshakes = ["ntf/1"] + type THandleNTF c p = THandle NTFVersion c p data NtfServerHandshake = NtfServerHandshake @@ -104,14 +111,16 @@ ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPa ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c let sk = C.signX509 serverSignKey $ C.publicToX509 k - sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange, authPubKey = Just sk} + let ntfVersionRange = maybe legacyServerNTFVRange (const ntfVRange) $ getSessionALPN c + sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange, authPubKey = Just sk} getHandshake th >>= \case NtfClientHandshake {ntfVersion = v, keyHash} | keyHash /= kh -> - throwError $ TEHandshake IDENTITY - | v `isCompatible` ntfVRange -> - pure $ ntfThHandleServer th v pk - | otherwise -> throwError $ TEHandshake VERSION + throwE $ TEHandshake IDENTITY + | otherwise -> + case compatibleVRange' ntfVersionRange v of + Just (Compatible vr) -> pure $ ntfThHandleServer th v vr pk + Nothing -> throwE TEVersion -- | Notifcations server client transport handshake. ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TClient) @@ -119,35 +128,46 @@ ntfClientHandshake c keyHash ntfVRange = do let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th if sessionId /= sessId - then throwError TEBadSession - else case ntfVersionRange `compatibleVersion` ntfVRange of - Just (Compatible v) -> do + then throwE TEBadSession + else case ntfVersionRange `compatibleVRange` ntfVRange of + Just (Compatible vr) -> do ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do serverKey <- getServerVerifyKey c pubKey <- C.verifyX509 serverKey signedKey (,(getServerCerts c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey) + let v = maxVersion vr sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash} - pure $ ntfThHandleClient th v ck_ - Nothing -> throwError $ TEHandshake VERSION + pure $ ntfThHandleClient th v vr ck_ + Nothing -> throwE TEVersion -ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> C.PrivateKeyX25519 -> THandleNTF c 'TServer -ntfThHandleServer th v pk = +ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> VersionRangeNTF -> C.PrivateKeyX25519 -> THandleNTF c 'TServer +ntfThHandleServer th v vr pk = let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing} - in ntfThHandle_ th v (Just thAuth) + in ntfThHandle_ th v vr (Just thAuth) -ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient -ntfThHandleClient th v ck_ = +ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient +ntfThHandleClient th v vr ck_ = let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = Nothing}) <$> ck_ - in ntfThHandle_ th v thAuth + in ntfThHandle_ th v vr thAuth -ntfThHandle_ :: forall c p. THandleNTF c p -> VersionNTF -> Maybe (THandleAuth p) -> THandleNTF c p -ntfThHandle_ th@THandle {params} v thAuth = +ntfThHandle_ :: forall c p. THandleNTF c p -> VersionNTF -> VersionRangeNTF -> Maybe (THandleAuth p) -> THandleNTF c p +ntfThHandle_ th@THandle {params} v vr thAuth = -- TODO drop SMP v6: make thAuth non-optional let v3 = v >= authBatchCmdsNTFVersion - params' = params {thVersion = v, thAuth, implySessId = v3, batch = v3} + params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v3, batch = v3} in (th :: THandleNTF c p) {params = params'} ntfTHandle :: Transport c => c -> THandleNTF c p ntfTHandle c = THandle {connection = c, params} where - params = THandleParams {sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = VersionNTF 0, thAuth = Nothing, implySessId = False, batch = False} + v = VersionNTF 0 + params = + THandleParams + { sessionId = tlsUnique c, + blockSize = ntfBlockSize, + thVersion = v, + thServerVRange = versionToRange v, + thAuth = Nothing, + implySessId = False, + batch = False + } diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs index 39cb0383c..6ad9f867d 100644 --- a/src/Simplex/Messaging/Parsers.hs +++ b/src/Simplex/Messaging/Parsers.hs @@ -24,7 +24,7 @@ import Database.SQLite.Simple (ResultError (..), SQLData (..)) import Database.SQLite.Simple.FromField (FieldParser, returnError) import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Ok (Ok (Ok)) -import Simplex.Messaging.Util ((<$?>)) +import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) import Text.Read (readMaybe) base64P :: Parser ByteString @@ -154,3 +154,6 @@ singleFieldJSON_ objectTag tagModifier = defaultJSON :: J.Options defaultJSON = J.defaultOptions {J.omitNothingFields = True} + +textP :: Parser String +textP = T.unpack . safeDecodeUtf8 <$> A.takeByteString diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 1dc76dbab..63e3e4d98 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -43,6 +43,7 @@ module Simplex.Messaging.Protocol ( -- * SMP protocol parameters supportedSMPClientVRange, maxMessageLength, + paddedProxiedTLength, e2eEncConfirmationLength, e2eEncMessageLength, @@ -54,8 +55,10 @@ module Simplex.Messaging.Protocol ProtocolEncoding (..), Command (..), SubscriptionMode (..), + SenderCanSecure, Party (..), Cmd (..), + DirectParty, BrokerMsg (..), SParty (..), PartyI (..), @@ -63,6 +66,8 @@ module Simplex.Messaging.Protocol ProtocolErrorType (..), ErrorType (..), CommandError (..), + ProxyError (..), + BrokerErrorType (..), Transmission, TransmissionAuth (..), SignedTransmission, @@ -121,8 +126,15 @@ module Simplex.Messaging.Protocol EncNMsgMeta, SMPMsgMeta (..), NMsgMeta (..), + EncFwdResponse (..), + EncFwdTransmission (..), + EncResponse (..), + EncTransmission (..), + FwdResponse (..), + FwdTransmission (..), MsgFlags (..), initialSMPClientVersion, + currentSMPClientVersion, userProtocol, rcvMessageMeta, noMsgFlags, @@ -143,9 +155,11 @@ module Simplex.Messaging.Protocol legacyServerP, legacyStrEncodeServer, srvHostnamesSMPClientVersion, + sndAuthKeySMPClientVersion, sameSrvAddr, sameSrvAddr', noAuthSrv, + toMsgInfo, -- * TCP transport functions TransportBatch (..), @@ -167,6 +181,7 @@ module Simplex.Messaging.Protocol where import Control.Applicative (optional, (<|>)) +import Control.Exception (Exception) import Control.Monad import Control.Monad.Except import Data.Aeson (FromJSON (..), ToJSON (..)) @@ -185,19 +200,25 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Maybe (isJust, isNothing) import Data.String -import Data.Time.Clock.System (SystemTime (..)) +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Data.Time.Clock.System (SystemTime (..), systemToUTCTime) import Data.Type.Equality import Data.Word (Word16) +import qualified Data.X509 as X import GHC.TypeLits (ErrorMessage (..), TypeError, type (+)) +import qualified GHC.TypeLits as TE +import qualified GHC.TypeLits as Type import Network.Socket (ServiceName) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers +import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.ServiceScheme import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..)) -import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>)) +import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>)) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal @@ -222,15 +243,25 @@ initialSMPClientVersion = VersionSMPC 1 srvHostnamesSMPClientVersion :: VersionSMPC srvHostnamesSMPClientVersion = VersionSMPC 2 +sndAuthKeySMPClientVersion :: VersionSMPC +sndAuthKeySMPClientVersion = VersionSMPC 3 + currentSMPClientVersion :: VersionSMPC -currentSMPClientVersion = VersionSMPC 2 +currentSMPClientVersion = VersionSMPC 3 supportedSMPClientVRange :: VersionRangeSMPC supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClientVersion -maxMessageLength :: Int -maxMessageLength = 16088 +-- TODO v6.0 remove dependency on version +maxMessageLength :: VersionSMP -> Int +maxMessageLength v + | v >= sendingProxySMPVersion = 16064 -- max 16067 + | otherwise = 16088 -- 16064 - always use this size to determine allowed ranges +paddedProxiedTLength :: Int +paddedProxiedTLength = 16242 -- 16241 .. 16243 + +-- TODO v6.0 change to 16064 type MaxMessageLen = 16088 -- 16 extra bytes: 8 for timestamp and 8 for flags (7 flags and the space, only 1 flag is currently used) @@ -244,7 +275,7 @@ e2eEncMessageLength :: Int e2eEncMessageLength = 16016 -- 16004 .. 16021 -- | SMP protocol clients -data Party = Recipient | Sender | Notifier +data Party = Recipient | Sender | Notifier | ProxiedClient deriving (Show) -- | Singleton types for SMP protocol clients @@ -252,11 +283,13 @@ data SParty :: Party -> Type where SRecipient :: SParty Recipient SSender :: SParty Sender SNotifier :: SParty Notifier + SProxiedClient :: SParty ProxiedClient instance TestEquality SParty where testEquality SRecipient SRecipient = Just Refl testEquality SSender SSender = Just Refl testEquality SNotifier SNotifier = Just Refl + testEquality SProxiedClient SProxiedClient = Just Refl testEquality _ _ = Nothing deriving instance Show (SParty p) @@ -269,6 +302,15 @@ instance PartyI Sender where sParty = SSender instance PartyI Notifier where sParty = SNotifier +instance PartyI ProxiedClient where sParty = SProxiedClient + +type family DirectParty (p :: Party) :: Constraint where + DirectParty Recipient = () + DirectParty Sender = () + DirectParty Notifier = () + DirectParty p = + (Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not direct")) + -- | Type for client command of any participant. data Cmd = forall p. PartyI p => Cmd (SParty p) (Command p) @@ -341,7 +383,7 @@ data Command (p :: Party) where -- v6 of SMP servers only support signature algorithm for command authorization. -- v7 of SMP servers additionally support additional layer of authenticated encryption. -- RcvPublicAuthKey is defined as C.APublicKey - it can be either signature or DH public keys. - NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> Command Recipient + NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient SUB :: Command Recipient KEY :: SndPublicAuthKey -> Command Recipient NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient @@ -352,13 +394,26 @@ data Command (p :: Party) where ACK :: MsgId -> Command Recipient OFF :: Command Recipient DEL :: Command Recipient + QUE :: Command Recipient -- SMP sender commands + SKEY :: SndPublicAuthKey -> Command Sender -- SEND v1 has to be supported for encoding/decoding -- SEND :: MsgBody -> Command Sender SEND :: MsgFlags -> MsgBody -> Command Sender PING :: Command Sender -- SMP notification subscriber commands NSUB :: Command Notifier + PRXY :: SMPServer -> Maybe BasicAuth -> Command ProxiedClient -- request a relay server connection by URI + -- Transmission to proxy: + -- - entity ID: ID of the session with relay returned in PKEY (response to PRXY) + -- - corrId: also used as a nonce to encrypt transmission to relay, corrId + 1 - from relay + -- - key (1st param in the command) is used to agree DH secret for this particular transmission and its response + -- Encrypted transmission should include session ID (tlsunique) from proxy-relay connection. + PFWD :: VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> Command ProxiedClient -- use CorrId as CbNonce, client to proxy + -- Transmission forwarded to relay: + -- - entity ID: empty + -- - corrId: unique correlation ID between proxy and relay, also used as a nonce to encrypt forwarded transmission + RFWD :: EncFwdTransmission -> Command Sender -- use CorrId as CbNonce, proxy to relay deriving instance Show (Command p) @@ -384,6 +439,28 @@ instance Encoding SubscriptionMode where 'C' -> pure SMOnlyCreate _ -> fail "bad SubscriptionMode" +type SenderCanSecure = Bool + +newtype EncTransmission = EncTransmission ByteString + deriving (Show) + +data FwdTransmission = FwdTransmission + { fwdCorrId :: CorrId, + fwdVersion :: VersionSMP, + fwdKey :: C.PublicKeyX25519, + fwdTransmission :: EncTransmission + } + +instance Encoding FwdTransmission where + smpEncode FwdTransmission {fwdCorrId = CorrId corrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t} = + smpEncode (corrId, fwdVersion, fwdKey, Tail t) + smpP = do + (corrId, fwdVersion, fwdKey, Tail t) <- smpP + pure FwdTransmission {fwdCorrId = CorrId corrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t} + +newtype EncFwdTransmission = EncFwdTransmission ByteString + deriving (Show) + data BrokerMsg where -- SMP broker messages (responses, client messages, notifications) IDS :: QueueIdsKeys -> BrokerMsg @@ -393,7 +470,12 @@ data BrokerMsg where MSG :: RcvMessage -> BrokerMsg NID :: NotifierId -> RcvNtfPublicDhKey -> BrokerMsg NMSG :: C.CbNonce -> EncNMsgMeta -> BrokerMsg + -- Should include certificate chain + PKEY :: SessionId -> VersionRangeSMP -> (X.CertificateChain, X.SignedExact X.PubKey) -> BrokerMsg -- TLS-signed server key for proxy shared secret and initial sender key + RRES :: EncFwdResponse -> BrokerMsg -- relay to proxy + PRES :: EncResponse -> BrokerMsg -- proxy to client END :: BrokerMsg + INFO :: QueueInfo -> BrokerMsg OK :: BrokerMsg ERR :: ErrorType -> BrokerMsg PONG :: BrokerMsg @@ -405,6 +487,24 @@ data RcvMessage = RcvMessage } deriving (Eq, Show) +newtype EncFwdResponse = EncFwdResponse ByteString + deriving (Eq, Show) + +data FwdResponse = FwdResponse + { fwdCorrId :: CorrId, + fwdResponse :: EncResponse + } + +instance Encoding FwdResponse where + smpEncode FwdResponse {fwdCorrId = CorrId corrId, fwdResponse = EncResponse t} = + smpEncode (corrId, Tail t) + smpP = do + (corrId, Tail t) <- smpP + pure FwdResponse {fwdCorrId = CorrId corrId, fwdResponse = EncResponse t} + +newtype EncResponse = EncResponse ByteString + deriving (Eq, Show) + -- | received message without server/recipient encryption data Message = Message @@ -418,6 +518,13 @@ data Message msgTs :: SystemTime } +toMsgInfo :: Message -> MsgInfo +toMsgInfo = \case + Message {msgId, msgTs} -> msgInfo msgId msgTs MTMessage + MessageQuota {msgId, msgTs} -> msgInfo msgId msgTs MTQuota + where + msgInfo msgId msgTs msgType = MsgInfo {msgId = decodeLatin1 $ B64.encode msgId, msgTs = systemToUTCTime msgTs, msgType} + messageId :: Message -> MsgId messageId = \case Message {msgId} -> msgId @@ -565,8 +672,13 @@ data CommandTag (p :: Party) where ACK_ :: CommandTag Recipient OFF_ :: CommandTag Recipient DEL_ :: CommandTag Recipient + QUE_ :: CommandTag Recipient + SKEY_ :: CommandTag Sender SEND_ :: CommandTag Sender PING_ :: CommandTag Sender + PRXY_ :: CommandTag ProxiedClient + PFWD_ :: CommandTag ProxiedClient + RFWD_ :: CommandTag Sender NSUB_ :: CommandTag Notifier data CmdTag = forall p. PartyI p => CT (SParty p) (CommandTag p) @@ -580,7 +692,11 @@ data BrokerMsgTag | MSG_ | NID_ | NMSG_ + | PKEY_ + | RRES_ + | PRES_ | END_ + | INFO_ | OK_ | ERR_ | PONG_ @@ -605,8 +721,13 @@ instance PartyI p => Encoding (CommandTag p) where ACK_ -> "ACK" OFF_ -> "OFF" DEL_ -> "DEL" + QUE_ -> "QUE" + SKEY_ -> "SKEY" SEND_ -> "SEND" PING_ -> "PING" + PRXY_ -> "PRXY" + PFWD_ -> "PFWD" + RFWD_ -> "RFWD" NSUB_ -> "NSUB" smpP = messageTagP @@ -621,8 +742,13 @@ instance ProtocolMsgTag CmdTag where "ACK" -> Just $ CT SRecipient ACK_ "OFF" -> Just $ CT SRecipient OFF_ "DEL" -> Just $ CT SRecipient DEL_ + "QUE" -> Just $ CT SRecipient QUE_ + "SKEY" -> Just $ CT SSender SKEY_ "SEND" -> Just $ CT SSender SEND_ "PING" -> Just $ CT SSender PING_ + "PRXY" -> Just $ CT SProxiedClient PRXY_ + "PFWD" -> Just $ CT SProxiedClient PFWD_ + "RFWD" -> Just $ CT SSender RFWD_ "NSUB" -> Just $ CT SNotifier NSUB_ _ -> Nothing @@ -639,7 +765,11 @@ instance Encoding BrokerMsgTag where MSG_ -> "MSG" NID_ -> "NID" NMSG_ -> "NMSG" + PKEY_ -> "PKEY" + RRES_ -> "RRES" + PRES_ -> "PRES" END_ -> "END" + INFO_ -> "INFO" OK_ -> "OK" ERR_ -> "ERR" PONG_ -> "PONG" @@ -651,7 +781,11 @@ instance ProtocolMsgTag BrokerMsgTag where "MSG" -> Just MSG_ "NID" -> Just NID_ "NMSG" -> Just NMSG_ + "PKEY" -> Just PKEY_ + "RRES" -> Just RRES_ + "PRES" -> Just PRES_ "END" -> Just END_ + "INFO" -> Just INFO_ "OK" -> Just OK_ "ERR" -> Just ERR_ "PONG" -> Just PONG_ @@ -829,7 +963,7 @@ type family UserProtocol (p :: ProtocolType) :: Constraint where UserProtocol PSMP = () UserProtocol PXFTP = () UserProtocol a = - (Int ~ Bool, TypeError (Text "Servers for protocol " :<>: ShowType a :<>: Text " cannot be configured by the users")) + (Int ~ Bool, TypeError (TE.Text "Servers for protocol " :<>: ShowType a :<>: TE.Text " cannot be configured by the users")) userProtocol :: SProtocolType p -> Maybe (Dict (UserProtocol p)) userProtocol = \case @@ -984,7 +1118,8 @@ instance FromJSON CorrId where data QueueIdsKeys = QIK { rcvId :: RecipientId, sndId :: SenderId, - rcvPublicDhKey :: RcvPublicDhKey + rcvPublicDhKey :: RcvPublicDhKey, + sndSecure :: SenderCanSecure } deriving (Eq, Show) @@ -1038,14 +1173,20 @@ data ErrorType SESSION | -- | SMP command is unknown or has invalid syntax CMD {cmdErr :: CommandError} + | -- | error from proxied relay + PROXY {proxyErr :: ProxyError} | -- | command authorization error - bad signature or non-existing SMP queue AUTH + | -- | encryption/decryption error in proxy protocol + CRYPTO | -- | SMP queue capacity is exceeded on the server QUOTA | -- | ACK command is sent without message to be acknowledged NO_MSG | -- | sent message is too large (> maxMessageLength = 16088 bytes) LARGE_MSG + | -- | relay public key is expired + EXPIRED | -- | internal server error INTERNAL | -- | used internally, never returned by the server (to be removed) @@ -1055,8 +1196,12 @@ data ErrorType instance StrEncoding ErrorType where strEncode = \case CMD e -> "CMD " <> bshow e + PROXY e -> "PROXY " <> strEncode e e -> bshow e - strP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1 + strP = + "CMD " *> (CMD <$> parseRead1) + <|> "PROXY " *> (PROXY <$> strP) + <|> parseRead1 -- | SMP command error type. data CommandError @@ -1074,6 +1219,34 @@ data CommandError NO_ENTITY deriving (Eq, Read, Show) +data ProxyError + = -- | Correctly parsed SMP server ERR response. + -- This error is forwarded to the agent client as AgentErrorType `ERR PROXY PROTOCOL err`. + PROTOCOL {protocolErr :: ErrorType} + | -- | destination server error + BROKER {brokerErr :: BrokerErrorType} + | -- | basic auth provided to proxy is invalid + BASIC_AUTH + | -- no destination server error + NO_SESSION + deriving (Eq, Read, Show) + +-- | SMP server errors. +data BrokerErrorType + = -- | invalid server response (failed to parse) + RESPONSE {respErr :: String} + | -- | unexpected response + UNEXPECTED {respErr :: String} + | -- | network error + NETWORK + | -- | no compatible server host (e.g. onion when public is required, or vice versa) + HOST + | -- | handshake or other transport error + TRANSPORT {transportErr :: TransportError} + | -- | command response timeout + TIMEOUT + deriving (Eq, Read, Show, Exception) + -- | SMP transmission parser. transmissionP :: THandleParams v p -> Parser RawTransmission transmissionP THandleParams {sessionId, implySessId} = do @@ -1117,7 +1290,8 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg - instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where type Tag (Command p) = CommandTag p encodeProtocol v = \case - NEW rKey dhKey auth_ subMode + NEW rKey dhKey auth_ subMode sndSecure + | v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, sndSecure) | v >= subModeSMPVersion -> new <> auth <> e subMode | v == basicAuthSMPVersion -> new <> auth | otherwise -> new @@ -1132,9 +1306,14 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where ACK msgId -> e (ACK_, ' ', msgId) OFF -> e OFF_ DEL -> e DEL_ + QUE -> e QUE_ + SKEY k -> e (SKEY_, ' ', k) SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg) PING -> e PING_ NSUB -> e NSUB_ + PRXY host auth_ -> e (PRXY_, ' ', host, auth_) + PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s) + RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s) where e :: Encoding a => a -> ByteString e = smpEncode @@ -1144,24 +1323,36 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg {-# INLINE fromProtocolError #-} - checkCredentials (auth, _, queueId, _) cmd = case cmd of + checkCredentials (auth, _, entId, _) cmd = case cmd of -- NEW must have signature but NOT queue ID NEW {} | isNothing auth -> Left $ CMD NO_AUTH - | not (B.null queueId) -> Left $ CMD HAS_AUTH + | not (B.null entId) -> Left $ CMD HAS_AUTH | otherwise -> Right cmd -- SEND must have queue ID, signature is not always required SEND {} - | B.null queueId -> Left $ CMD NO_ENTITY + | B.null entId -> Left $ CMD NO_ENTITY | otherwise -> Right cmd - -- PING must not have queue ID or signature - PING - | isNothing auth && B.null queueId -> Right cmd + SKEY _ + | isNothing auth || B.null entId -> Left $ CMD NO_AUTH + | otherwise -> Right cmd + PING -> noAuthCmd + PRXY {} -> noAuthCmd + PFWD {} + | B.null entId -> Left $ CMD NO_ENTITY + | isNothing auth -> Right cmd | otherwise -> Left $ CMD HAS_AUTH + RFWD _ -> noAuthCmd -- other client commands must have both signature and queue ID _ - | isNothing auth || B.null queueId -> Left $ CMD NO_AUTH + | isNothing auth || B.null entId -> Left $ CMD NO_AUTH | otherwise -> Right cmd + where + -- command must not have entity ID (queue or session ID) or signature + noAuthCmd :: Either ErrorType (Command p) + noAuthCmd + | isNothing auth && B.null entId = Right cmd + | otherwise = Left $ CMD HAS_AUTH instance ProtocolEncoding SMPVersion ErrorType Cmd where type Tag Cmd = CmdTag @@ -1171,9 +1362,10 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where CT SRecipient tag -> Cmd SRecipient <$> case tag of NEW_ - | v >= subModeSMPVersion -> new <*> auth <*> smpP - | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe - | otherwise -> new <*> pure Nothing <*> pure SMSubscribe + | v >= sndAuthKeySMPVersion -> new <*> smpP <*> smpP <*> smpP + | v >= subModeSMPVersion -> new <*> auth <*> smpP <*> pure False + | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe <*> pure False + | otherwise -> new <*> pure Nothing <*> pure SMSubscribe <*> pure False where new = NEW <$> _smpP <*> smpP auth = optional (A.char 'A' *> smpP) @@ -1185,10 +1377,17 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where ACK_ -> ACK <$> _smpP OFF_ -> pure OFF DEL_ -> pure DEL + QUE_ -> pure QUE CT SSender tag -> Cmd SSender <$> case tag of + SKEY_ -> SKEY <$> _smpP SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP) PING_ -> pure PING + RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP) + CT SProxiedClient tag -> + Cmd SProxiedClient <$> case tag of + PFWD_ -> PFWD <$> _smpP <*> smpP <*> (EncTransmission . unTail <$> smpP) + PRXY_ -> PRXY <$> _smpP <*> smpP CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg @@ -1198,13 +1397,21 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where type Tag BrokerMsg = BrokerMsgTag - encodeProtocol _v = \case - IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh) + encodeProtocol v = \case + IDS (QIK rcvId sndId srvDh sndSecure) + | v >= sndAuthKeySMPVersion -> ids <> e sndSecure + | otherwise -> ids + where + ids = e (IDS_, ' ', rcvId, sndId, srvDh) MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} -> e (MSG_, ' ', msgId, Tail body) NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh) NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta) + PKEY sid vr (cert, key) -> e (PKEY_, ' ', sid, vr, C.encodeCertChain cert, C.SignedObject key) + RRES (EncFwdResponse encBlock) -> e (RRES_, ' ', Tail encBlock) + PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock) END -> e END_ + INFO info -> e (INFO_, ' ', info) OK -> e OK_ ERR err -> e (ERR_, ' ', err) PONG -> e PONG_ @@ -1212,16 +1419,24 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where e :: Encoding a => a -> ByteString e = smpEncode - protocolP _v = \case + protocolP v = \case MSG_ -> do msgId <- _smpP MSG . RcvMessage msgId <$> bodyP where bodyP = EncRcvMsgBody . unTail <$> smpP - IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP) + IDS_ + | v >= sndAuthKeySMPVersion -> ids smpP + | otherwise -> ids $ pure False + where + ids p = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p) NID_ -> NID <$> _smpP <*> smpP NMSG_ -> NMSG <$> _smpP <*> smpP + PKEY_ -> PKEY <$> _smpP <*> smpP <*> ((,) <$> C.certChainP <*> (C.getSignedExact <$> smpP)) + RRES_ -> RRES <$> (EncFwdResponse . unTail <$> _smpP) + PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP) END_ -> pure END + INFO_ -> INFO <$> _smpP OK_ -> pure OK ERR_ -> ERR <$> _smpP PONG_ -> pure PONG @@ -1233,19 +1448,24 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where PEBlock -> BLOCK {-# INLINE fromProtocolError #-} - checkCredentials (_, _, queueId, _) cmd = case cmd of + checkCredentials (_, _, entId, _) cmd = case cmd of -- IDS response should not have queue ID IDS _ -> Right cmd -- ERR response does not always have queue ID ERR _ -> Right cmd -- PONG response must not have queue ID - PONG - | B.null queueId -> Right cmd - | otherwise -> Left $ CMD HAS_AUTH + PONG -> noEntityMsg + PKEY {} -> noEntityMsg + RRES _ -> noEntityMsg -- other broker responses must have queue ID _ - | B.null queueId -> Left $ CMD NO_ENTITY + | B.null entId -> Left $ CMD NO_ENTITY | otherwise -> Right cmd + where + noEntityMsg :: Either ErrorType BrokerMsg + noEntityMsg + | B.null entId = Right cmd + | otherwise = Left $ CMD HAS_AUTH -- | Parse SMP protocol commands and broker messages parseProtocol :: forall v err msg. ProtocolEncoding v err msg => Version v -> ByteString -> Either err msg @@ -1268,8 +1488,11 @@ instance Encoding ErrorType where BLOCK -> "BLOCK" SESSION -> "SESSION" CMD err -> "CMD " <> smpEncode err + PROXY err -> "PROXY " <> smpEncode err AUTH -> "AUTH" + CRYPTO -> "CRYPTO" QUOTA -> "QUOTA" + EXPIRED -> "EXPIRED" NO_MSG -> "NO_MSG" LARGE_MSG -> "LARGE_MSG" INTERNAL -> "INTERNAL" @@ -1280,13 +1503,16 @@ instance Encoding ErrorType where "BLOCK" -> pure BLOCK "SESSION" -> pure SESSION "CMD" -> CMD <$> _smpP + "PROXY" -> PROXY <$> _smpP "AUTH" -> pure AUTH + "CRYPTO" -> pure CRYPTO "QUOTA" -> pure QUOTA + "EXPIRED" -> pure EXPIRED "NO_MSG" -> pure NO_MSG "LARGE_MSG" -> pure LARGE_MSG "INTERNAL" -> pure INTERNAL "DUPLICATE_" -> pure DUPLICATE_ - _ -> fail "bad error type" + _ -> fail "bad ErrorType" instance Encoding CommandError where smpEncode e = case e of @@ -1304,8 +1530,74 @@ instance Encoding CommandError where "NO_AUTH" -> pure NO_AUTH "HAS_AUTH" -> pure HAS_AUTH "NO_ENTITY" -> pure NO_ENTITY - "NO_QUEUE" -> pure NO_ENTITY - _ -> fail "bad command error type" + "NO_QUEUE" -> pure NO_ENTITY -- for backward compatibility + _ -> fail "bad CommandError" + +instance Encoding ProxyError where + smpEncode = \case + PROTOCOL e -> "PROTOCOL " <> smpEncode e + BROKER e -> "BROKER " <> smpEncode e + BASIC_AUTH -> "BASIC_AUTH" + NO_SESSION -> "NO_SESSION" + smpP = + A.takeTill (== ' ') >>= \case + "PROTOCOL" -> PROTOCOL <$> _smpP + "BROKER" -> BROKER <$> _smpP + "BASIC_AUTH" -> pure BASIC_AUTH + "NO_SESSION" -> pure NO_SESSION + _ -> fail "bad ProxyError" + +instance StrEncoding ProxyError where + strEncode = \case + PROTOCOL e -> "PROTOCOL " <> strEncode e + BROKER e -> "BROKER " <> strEncode e + BASIC_AUTH -> "BASIC_AUTH" + NO_SESSION -> "NO_SESSION" + strP = + A.takeTill (== ' ') >>= \case + "PROTOCOL" -> PROTOCOL <$> _strP + "BROKER" -> BROKER <$> _strP + "BASIC_AUTH" -> pure BASIC_AUTH + "NO_SESSION" -> pure NO_SESSION + _ -> fail "bad ProxyError" + +instance Encoding BrokerErrorType where + smpEncode = \case + RESPONSE e -> "RESPONSE " <> smpEncode e + UNEXPECTED e -> "UNEXPECTED " <> smpEncode e + TRANSPORT e -> "TRANSPORT " <> smpEncode e + NETWORK -> "NETWORK" + TIMEOUT -> "TIMEOUT" + HOST -> "HOST" + smpP = + A.takeTill (== ' ') >>= \case + "RESPONSE" -> RESPONSE <$> _smpP + "UNEXPECTED" -> UNEXPECTED <$> _smpP + "TRANSPORT" -> TRANSPORT <$> _smpP + "NETWORK" -> pure NETWORK + "TIMEOUT" -> pure TIMEOUT + "HOST" -> pure HOST + _ -> fail "bad BrokerErrorType" + +instance StrEncoding BrokerErrorType where + strEncode = \case + RESPONSE e -> "RESPONSE " <> encodeUtf8 (T.pack e) + UNEXPECTED e -> "UNEXPECTED " <> encodeUtf8 (T.pack e) + TRANSPORT e -> "TRANSPORT " <> smpEncode e + NETWORK -> "NETWORK" + TIMEOUT -> "TIMEOUT" + HOST -> "HOST" + strP = + A.takeTill (== ' ') >>= \case + "RESPONSE" -> RESPONSE <$> _textP + "UNEXPECTED" -> UNEXPECTED <$> _textP + "TRANSPORT" -> TRANSPORT <$> _smpP + "NETWORK" -> pure NETWORK + "TIMEOUT" -> pure TIMEOUT + "HOST" -> pure HOST + _ -> fail "bad BrokerErrorType" + where + _textP = A.space *> (T.unpack . safeDecodeUtf8 <$> A.takeByteString) -- | Send signed SMP transmission to TCP transport. tPut :: Transport c => THandle v c p -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()] @@ -1444,4 +1736,7 @@ $(J.deriveJSON defaultJSON ''MsgFlags) $(J.deriveJSON (sumTypeJSON id) ''CommandError) -$(J.deriveJSON (sumTypeJSON id) ''ErrorType) +$(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType) + +-- run deriveJSON in one TH splice to allow mutual instance +$(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''ErrorType]) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 5415ebd65..d88b2349a 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -13,7 +13,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -- | -- Module : Simplex.Messaging.Server @@ -43,7 +42,9 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader +import Control.Monad.Trans.Except import Crypto.Random +import Control.Monad.STM (retry) import Data.Bifunctor (first) import Data.ByteString.Base64 (encode) import Data.ByteString.Char8 (ByteString) @@ -53,10 +54,12 @@ import Data.Either (fromRight, partitionEithers) import Data.Functor (($>)) import Data.Int (Int64) import qualified Data.IntMap.Strict as IM -import Data.List (intercalate) +import Data.List (intercalate, mapAccumR) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M -import Data.Maybe (isNothing) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) +import qualified Data.Set as S import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) @@ -67,8 +70,10 @@ import GHC.Stats (getRTSStats) import GHC.TypeLits (KnownNat) import Network.Socket (ServiceName, Socket, socketToHandle) import Simplex.Messaging.Agent.Lock +import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPTransmission, smpProxyError, temporaryClientError) +import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Encoding (Encoding (smpEncode)) +import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol import Simplex.Messaging.Server.Control @@ -77,6 +82,7 @@ import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.QueueStore +import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.QueueStore.STM as QS import Simplex.Messaging.Server.Stats import Simplex.Messaging.Server.StoreLog @@ -86,6 +92,7 @@ import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.Server import Simplex.Messaging.Util +import Simplex.Messaging.Version import System.Exit (exitFailure) import System.IO (hPrint, hPutStrLn, hSetNewlineMode, universalNewlineMode) import System.Mem.Weak (deRefWeak) @@ -97,7 +104,6 @@ import UnliftIO.IO import UnliftIO.STM #if MIN_VERSION_base(4,18,0) import Data.List (sort) -import Data.Maybe (fromMaybe) import GHC.Conc (listThreads, threadStatus) import GHC.Conc.Sync (threadLabel) #endif @@ -122,14 +128,16 @@ type M a = ReaderT Env IO a smpServer :: TMVar Bool -> ServerConfig -> M () smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do s <- asks server + pa <- asks proxyAgent expired <- restoreServerMessages restoreServerStats expired raceAny_ ( serverThread s "server subscribedQ" subscribedQ subscribers subscriptions cancelSub : serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubscriptions (\_ -> pure ()) + : receiveFromProxyAgent pa : map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg ) - `finally` withLock' (savingLock s) "final" (saveServer False) + `finally` withLock' (savingLock s) "final" (saveServer False >> closeServer) where runServer :: (ServiceName, ATransport) -> M () runServer (tcpPort, ATransport t) = do @@ -143,6 +151,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do saveServer :: Bool -> M () saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats + closeServer :: M () + closeServer = asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent + serverThread :: forall s. Server -> @@ -171,14 +182,22 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s) endPreviousSubscriptions (qId, c) = do - tId <- atomically $ stateTVar (endThreadSeq c) $ \next -> (next, next + 1) - t <- forkIO $ do - labelMyThread $ label <> ".endPreviousSubscriptions" + forkClient c (label <> ".endPreviousSubscriptions") $ atomically $ writeTBQueue (sndQ c) [(CorrId "", qId, END)] - atomically $ modifyTVar' (endThreads c) $ IM.delete tId - mkWeakThreadId t >>= atomically . modifyTVar' (endThreads c) . IM.insert tId atomically $ TM.lookupDelete qId (clientSubs c) + receiveFromProxyAgent :: ProxyAgent -> M () + receiveFromProxyAgent ProxyAgent {smpAgent = SMPClientAgent {agentQ}} = + forever $ + atomically (readTBQueue agentQ) >>= \case + CAConnected srv -> logInfo $ "SMP server connected " <> showServer' srv + CADisconnected srv [] -> logInfo $ "SMP server disconnected " <> showServer' srv + CADisconnected srv subs -> logError $ "SMP server disconnected " <> showServer' srv <> " / subscriptions: " <> tshow (length subs) + CASubscribed srv _ subs -> logError $ "SMP server subscribed " <> showServer' srv <> " / subscriptions: " <> tshow (length subs) + CASubError srv _ errs -> logError $ "SMP server subscription errors " <> showServer' srv <> " / errors: " <> tshow (length errs) + where + showServer' = decodeLatin1 . strEncode . host + expireMessagesThread_ :: ServerConfig -> [M ()] expireMessagesThread_ ServerConfig {messageExpiration = Just msgExp} = [expireMessages msgExp] expireMessagesThread_ _ = [] @@ -210,7 +229,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0) - ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats + ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, qSub, qSubAuth, qSubDuplicate, qSubProhibited, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv} <- asks serverStats let interval = 1000000 * logInterval forever $ do withFile statsFilePath AppendMode $ \h -> liftIO $ do @@ -222,39 +241,74 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do qDeletedAll' <- atomically $ swapTVar qDeletedAll 0 qDeletedNew' <- atomically $ swapTVar qDeletedNew 0 qDeletedSecured' <- atomically $ swapTVar qDeletedSecured 0 + qSub' <- atomically $ swapTVar qSub 0 + qSubAuth' <- atomically $ swapTVar qSubAuth 0 + qSubDuplicate' <- atomically $ swapTVar qSubDuplicate 0 + qSubProhibited' <- atomically $ swapTVar qSubProhibited 0 msgSent' <- atomically $ swapTVar msgSent 0 + msgSentAuth' <- atomically $ swapTVar msgSentAuth 0 + msgSentQuota' <- atomically $ swapTVar msgSentQuota 0 + msgSentLarge' <- atomically $ swapTVar msgSentLarge 0 msgRecv' <- atomically $ swapTVar msgRecv 0 msgExpired' <- atomically $ swapTVar msgExpired 0 ps <- atomically $ periodStatCounts activeQueues ts msgSentNtf' <- atomically $ swapTVar msgSentNtf 0 msgRecvNtf' <- atomically $ swapTVar msgRecvNtf 0 psNtf <- atomically $ periodStatCounts activeQueuesNtf ts + msgNtfs' <- atomically $ swapTVar (msgNtfs ss) 0 + msgNtfNoSub' <- atomically $ swapTVar (msgNtfNoSub ss) 0 + msgNtfLost' <- atomically $ swapTVar (msgNtfLost ss) 0 + pRelays' <- atomically $ getResetProxyStatsData pRelays + pRelaysOwn' <- atomically $ getResetProxyStatsData pRelaysOwn + pMsgFwds' <- atomically $ getResetProxyStatsData pMsgFwds + pMsgFwdsOwn' <- atomically $ getResetProxyStatsData pMsgFwdsOwn + pMsgFwdsRecv' <- atomically $ swapTVar pMsgFwdsRecv 0 qCount' <- readTVarIO qCount msgCount' <- readTVarIO msgCount hPutStrLn h $ intercalate "," - [ iso8601Show $ utctDay fromTime', - show qCreated', - show qSecured', - show qDeletedAll', - show msgSent', - show msgRecv', - dayCount ps, - weekCount ps, - monthCount ps, - show msgSentNtf', - show msgRecvNtf', - dayCount psNtf, - weekCount psNtf, - monthCount psNtf, - show qCount', - show msgCount', - show msgExpired', - show qDeletedNew', - show qDeletedSecured' - ] + ( [ iso8601Show $ utctDay fromTime', + show qCreated', + show qSecured', + show qDeletedAll', + show msgSent', + show msgRecv', + dayCount ps, + weekCount ps, + monthCount ps, + show msgSentNtf', + show msgRecvNtf', + dayCount psNtf, + weekCount psNtf, + monthCount psNtf, + show qCount', + show msgCount', + show msgExpired', + show qDeletedNew', + show qDeletedSecured' + ] + <> showProxyStats pRelays' + <> showProxyStats pRelaysOwn' + <> showProxyStats pMsgFwds' + <> showProxyStats pMsgFwdsOwn' + <> [ show pMsgFwdsRecv', + show qSub', + show qSubAuth', + show qSubDuplicate', + show qSubProhibited', + show msgSentAuth', + show msgSentQuota', + show msgSentLarge', + show msgNtfs', + show msgNtfNoSub', + show msgNtfLost' + ] + ) liftIO $ threadDelay' interval + where + showProxyStats ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} = + [show _pRequests, show _pSuccesses, show _pErrorsConnect, show _pErrorsCompat, show _pErrorsOther] runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M () runClient signKey tp h = do @@ -314,7 +368,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do CPResume -> withAdminRole $ hPutStrLn h "resume not implemented" CPClients -> withAdminRole $ do active <- unliftIO u (asks clients) >>= readTVarIO - hPutStrLn h $ "clientId,sessionId,connected,createdAt,rcvActiveAt,sndActiveAt,age,subscriptions" + hPutStrLn h "clientId,sessionId,connected,createdAt,rcvActiveAt,sndActiveAt,age,subscriptions" forM_ (IM.toList active) $ \(cid, Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions}) -> do connected' <- bshow <$> readTVarIO connected rcvActiveAt' <- strEncode <$> readTVarIO rcvActiveAt @@ -323,23 +377,32 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do let age = systemSeconds now - systemSeconds createdAt subscriptions' <- bshow . M.size <$> readTVarIO subscriptions hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions'] - CPStats -> withAdminRole $ do - ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgSentNtf, msgRecvNtf, qCount, msgCount} <- unliftIO u $ asks serverStats + CPStats -> withUserRole $ do + ss <- unliftIO u $ asks serverStats + let putStat :: Show a => ByteString -> (ServerStats -> TVar a) -> IO () + putStat label var = readTVarIO (var ss) >>= \v -> B.hPutStr h $ label <> ": " <> bshow v <> "\n" + putProxyStat :: ByteString -> (ServerStats -> ProxyStats) -> IO () + putProxyStat label var = do + ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} <- atomically $ getProxyStatsData $ var ss + B.hPutStr h $ label <> ": requests=" <> bshow _pRequests <> ", successes=" <> bshow _pSuccesses <> ", errorsConnect=" <> bshow _pErrorsConnect <> ", errorsCompat=" <> bshow _pErrorsCompat <> ", errorsOther=" <> bshow _pErrorsOther <> "\n" putStat "fromTime" fromTime putStat "qCreated" qCreated putStat "qSecured" qSecured putStat "qDeletedAll" qDeletedAll putStat "qDeletedNew" qDeletedNew putStat "qDeletedSecured" qDeletedSecured + readTVarIO (day $ activeQueues ss) >>= \v -> B.hPutStr h $ "dayMsgQueues" <> ": " <> bshow (S.size v) <> "\n" putStat "msgSent" msgSent putStat "msgRecv" msgRecv putStat "msgSentNtf" msgSentNtf putStat "msgRecvNtf" msgRecvNtf putStat "qCount" qCount putStat "msgCount" msgCount - where - putStat :: Show a => String -> TVar a -> IO () - putStat label var = readTVarIO var >>= \v -> hPutStrLn h $ label <> ": " <> show v + putProxyStat "pRelays" pRelays + putProxyStat "pRelaysOwn" pRelaysOwn + putProxyStat "pMsgFwds" pMsgFwds + putProxyStat "pMsgFwdsOwn" pMsgFwdsOwn + putStat "pMsgFwdsRecv" pMsgFwdsRecv CPStatsRTS -> getRTSStats >>= hPrint h CPThreads -> withAdminRole $ do #if MIN_VERSION_base(4,18,0) @@ -352,7 +415,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do #else hPutStrLn h "Not available on GHC 8.10" #endif - CPSockets -> withAdminRole $ do + CPSockets -> withUserRole $ do (accepted', closed', active') <- unliftIO u $ asks sockets (accepted, closed, active) <- atomically $ (,,) <$> readTVar accepted' <*> readTVar closed' <*> readTVar active' hPutStrLn h "Sockets: " @@ -374,6 +437,43 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do #else hPutStrLn h "Not available on GHC 8.10" #endif + CPServerInfo -> readTVarIO role >>= \case + CPRNone -> do + logError "Unauthorized control port command" + hPutStrLn h "AUTH" + r -> do +#if MIN_VERSION_base(4,18,0) + threads <- liftIO listThreads + hPutStrLn h $ "Threads: " <> show (length threads) +#else + hPutStrLn h "Threads: not available on GHC 8.10" +#endif + Env {clients, server = Server {subscribers, notifiers}} <- unliftIO u ask + activeClients <- readTVarIO clients + hPutStrLn h $ "Clients: " <> show (IM.size activeClients) + when (r == CPRAdmin) $ do + (smpSubCnt, smpClCnt) <- countClientSubs subscriptions activeClients + (ntfSubCnt, ntfClCnt) <- countClientSubs ntfSubscriptions activeClients + hPutStrLn h $ "SMP subscriptions (via clients, slow): " <> show smpSubCnt + hPutStrLn h $ "SMP subscribed clients (via clients, slow): " <> show smpClCnt + hPutStrLn h $ "Ntf subscriptions (via clients, slow): " <> show ntfSubCnt + hPutStrLn h $ "Ntf subscribed clients (via clients, slow): " <> show ntfClCnt + activeSubs <- readTVarIO subscribers + activeNtfSubs <- readTVarIO notifiers + hPutStrLn h $ "SMP subscriptions: " <> show (M.size activeSubs) + hPutStrLn h $ "SMP subscribed clients: " <> show (countSubClients activeSubs) + hPutStrLn h $ "Ntf subscriptions: " <> show (M.size activeNtfSubs) + hPutStrLn h $ "Ntf subscribed clients: " <> show (countSubClients activeNtfSubs) + where + countClientSubs :: (Client -> TMap QueueId a) -> IM.IntMap Client -> IO (Int, Int) + countClientSubs subSel = foldM addSubs (0, 0) + where + addSubs :: (Int, Int) -> Client -> IO (Int, Int) + addSubs (subCnt, clCnt) cl = do + subs <- readTVarIO $ subSel cl + let cnt = M.size subs + pure (subCnt + cnt, clCnt + if cnt == 0 then 0 else 1) + countSubClients = S.size . M.foldr' (S.insert . clientId) S.empty CPDelete queueId' -> withUserRole $ unliftIO u $ do st <- asks queueStore ms <- asks msgStore @@ -393,7 +493,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do hPutStrLn h "saving server state..." unliftIO u $ saveServer True hPutStrLn h "server state saved!" - CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, delete, save, help, quit" + CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, server-info, delete, save, help, quit" CPQuit -> pure () CPSkip -> pure () where @@ -410,7 +510,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do hPutStrLn h "AUTH" runClientTransport :: Transport c => THandleSMP c 'TServer -> M () -runClientTransport th@THandle {params = THandleParams {thVersion, sessionId}} = do +runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessionId}} = do q <- asks $ tbqSize . config ts <- liftIO getSystemTime active <- asks clients @@ -421,11 +521,12 @@ runClientTransport th@THandle {params = THandleParams {thVersion, sessionId}} = pure new s <- asks server expCfg <- asks $ inactiveClientExpiration . config + th <- newMVar h -- put TH under a fair lock to interleave messages and command responses labelMyThread . B.unpack $ "client $" <> encode sessionId - raceAny_ ([liftIO $ send th c, client c s, receive th c] <> disconnectThread_ c expCfg) + raceAny_ ([liftIO $ send th c, liftIO $ sendMsg th c, client thParams c s, receive h c] <> disconnectThread_ c expCfg) `finally` clientDisconnected c where - disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th (rcvActiveAt c) (sndActiveAt c) expCfg (noSubscriptions c)] + disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport h (rcvActiveAt c) (sndActiveAt c) expCfg (noSubscriptions c)] disconnectThread_ _ _ = [] noSubscriptions c = atomically $ (&&) <$> TM.null (subscriptions c) <*> TM.null (ntfSubscriptions c) @@ -451,47 +552,74 @@ clientDisconnected c@Client {clientId, subscriptions, connected, sessionId, endT sameClientId :: Client -> Client -> Bool sameClientId Client {clientId} Client {clientId = cId'} = clientId == cId' -cancelSub :: TVar Sub -> IO () -cancelSub sub = - readTVarIO sub >>= \case - Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread - _ -> return () +cancelSub :: Sub -> IO () +cancelSub s = + readTVarIO (subThread s) >>= \case + SubThread t -> liftIO $ deRefWeak t >>= mapM_ killThread + _ -> pure () receive :: Transport c => THandleSMP c 'TServer -> Client -> M () -receive th@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do +receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive" forever $ do - ts <- L.toList <$> liftIO (tGet th) - atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime - as <- partitionEithers <$> mapM cmdAction ts - write sndQ $ fst as - write rcvQ $ snd as + ts <- L.toList <$> liftIO (tGet h) + atomically . (writeTVar rcvActiveAt $!) =<< liftIO getSystemTime + stats <- asks serverStats + (errs, cmds) <- partitionEithers <$> mapM (cmdAction stats) ts + write sndQ errs + write rcvQ cmds where - cmdAction :: SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd)) - cmdAction (tAuth, authorized, (corrId, queueId, cmdOrError)) = + cmdAction :: ServerStats -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd)) + cmdAction stats (tAuth, authorized, (corrId, entId, cmdOrError)) = case cmdOrError of - Left e -> pure $ Left (corrId, queueId, ERR e) - Right cmd -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) tAuth authorized queueId cmd + Left e -> pure $ Left (corrId, entId, ERR e) + Right cmd -> verified =<< verifyTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) tAuth authorized entId cmd where verified = \case - VRVerified qr -> Right (qr, (corrId, queueId, cmd)) - VRFailed -> Left (corrId, queueId, ERR AUTH) + VRVerified qr -> pure $ Right (qr, (corrId, entId, cmd)) + VRFailed -> do + case cmd of + Cmd _ SEND {} -> atomically $ modifyTVar' (msgSentAuth stats) (+ 1) + Cmd _ SUB -> atomically $ modifyTVar' (qSubAuth stats) (+ 1) + _ -> pure () + pure $ Left (corrId, entId, ERR AUTH) write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty -send :: Transport c => THandleSMP c 'TServer -> Client -> IO () -send h@THandle {params} Client {sndQ, sessionId, sndActiveAt} = do +send :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> IO () +send th c@Client {sndQ, msgQ, sessionId} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send" - forever $ do - ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ - -- TODO we can authorize responses as well - void . liftIO . tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts - atomically . writeTVar sndActiveAt =<< liftIO getSystemTime + forever $ atomically (readTBQueue sndQ) >>= sendTransmissions where - tOrder :: Transmission BrokerMsg -> Int - tOrder (_, _, cmd) = case cmd of - MSG {} -> 0 - NMSG {} -> 0 - _ -> 1 + sendTransmissions :: NonEmpty (Transmission BrokerMsg) -> IO () + sendTransmissions ts + | L.length ts <= 2 = tSend th c ts + | otherwise = do + let (msgs_, ts') = mapAccumR splitMessages [] ts + -- If the request had batched subscriptions (L.length ts > 2) + -- this will reply OK to all SUBs in the first batched transmission, + -- to reduce client timeouts. + tSend th c ts' + -- After that all messages will be sent in separate transmissions, + -- without any client response timeouts, and allowing them to interleave + -- with other requests responses. + mapM_ (atomically . writeTBQueue msgQ) $ L.nonEmpty msgs_ + where + splitMessages :: [Transmission BrokerMsg] -> Transmission BrokerMsg -> ([Transmission BrokerMsg], Transmission BrokerMsg) + splitMessages msgs t@(corrId, entId, cmd) = case cmd of + -- replace MSG response with OK, accumulating MSG in a separate list. + MSG {} -> ((CorrId "", entId, cmd) : msgs, (corrId, entId, OK)) + _ -> (msgs, t) + +sendMsg :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> IO () +sendMsg th c@Client {msgQ, sessionId} = do + labelMyThread . B.unpack $ "client $" <> encode sessionId <> " sendMsg" + forever $ atomically (readTBQueue msgQ) >>= mapM_ (\t -> tSend th c [t]) + +tSend :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> NonEmpty (Transmission BrokerMsg) -> IO () +tSend th Client {sndActiveAt} ts = do + withMVar th $ \h@THandle {params} -> + void . tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts + atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime disconnectTransport :: Transport c => THandle v c 'TServer -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO () disconnectTransport THandle {connection, params = THandleParams {sessionId}} rcvActiveAt sndActiveAt expCfg noSubscriptions = do @@ -517,21 +645,24 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed verifyTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult verifyTransmission auth_ tAuth authorized queueId cmd = case cmd of - Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verifiedWith` k + Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey q) <$> get SRecipient - -- SEND will be accepted without authorization before the queue is secured with KEY command + -- SEND will be accepted without authorization before the queue is secured with KEY or SKEY command + Cmd SSender (SKEY k) -> verifyQueue (\q -> Just q `verifiedWith` k) <$> get SSender Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender Cmd SSender PING -> pure $ VRVerified Nothing + Cmd SSender RFWD {} -> pure $ VRVerified Nothing -- NSUB will not be accepted without authorization - Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (Just q `verifiedWith`) (notifierKey <$> notifier q)) <$> get SNotifier + Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (\n -> Just q `verifiedWith` notifierKey n) (notifier q)) <$> get SNotifier + Cmd SProxiedClient _ -> pure $ VRVerified Nothing where verify = verifyCmdAuthorization auth_ tAuth authorized dummyVerify = verify (dummyAuthKey tAuth) `seq` VRFailed verifyQueue :: (QueueRec -> VerificationResult) -> Either ErrorType QueueRec -> VerificationResult - verifyQueue = either (\_ -> dummyVerify) + verifyQueue = either (const dummyVerify) verified q cond = if cond then VRVerified q else VRFailed verifiedWith q k = q `verified` verify k - get :: SParty p -> M (Either ErrorType QueueRec) + get :: DirectParty p => SParty p -> M (Either ErrorType QueueRec) get party = do st <- asks queueStore atomically $ getQueue st party queueId @@ -581,48 +712,146 @@ dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/Xo dummyKeyX25519 :: C.PublicKey 'C.X25519 dummyKeyX25519 = "MCowBQYDK2VuAyEA4JGSMYht18H4mas/jHeBwfcM7jLwNYJNOAhi2/g4RXg=" -client :: Client -> Server -> M () -client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Server {subscribedQ, ntfSubscribedQ, notifiers} = do +forkClient :: Client -> String -> M () -> M () +forkClient Client {endThreads, endThreadSeq} label action = do + tId <- atomically $ stateTVar endThreadSeq $ \next -> (next, next + 1) + t <- forkIO $ do + labelMyThread label + action `finally` atomically (modifyTVar' endThreads $ IM.delete tId) + mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId + +client :: THandleParams SMPVersion 'TServer -> Client -> Server -> M () +client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, subscribers, notifiers} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" forever $ atomically (readTBQueue rcvQ) >>= mapM processCommand - >>= atomically . writeTBQueue sndQ + >>= mapM_ reply . L.nonEmpty . catMaybes . L.toList where - processCommand :: (Maybe QueueRec, Transmission Cmd) -> M (Transmission BrokerMsg) - processCommand (qr_, (corrId, queueId, cmd)) = do - st <- asks queueStore - case cmd of - Cmd SSender command -> - case command of - SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody - PING -> pure (corrId, "", PONG) - Cmd SNotifier NSUB -> subscribeNotifications - Cmd SRecipient command -> - case command of - NEW rKey dhKey auth subMode -> - ifM - allowNew - (createQueue st rKey dhKey subMode) - (pure (corrId, queueId, ERR AUTH)) - where - allowNew = do - ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config - pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth - SUB -> withQueue (`subscribeQueue` queueId) - GET -> withQueue getMessage - ACK msgId -> withQueue (`acknowledgeMsg` msgId) - KEY sKey -> secureQueue_ st sKey - NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey - NDEL -> deleteQueueNotifier_ st - OFF -> suspendQueue_ st - DEL -> delQueueAndMsgs st + reply :: MonadIO m => NonEmpty (Transmission BrokerMsg) -> m () + reply = atomically . writeTBQueue sndQ + processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M (Maybe (Transmission BrokerMsg)) + processProxiedCmd (corrId, sessId, command) = (corrId,sessId,) <$$> case command of + PRXY srv auth -> ifM allowProxy getRelay (pure $ Just $ ERR $ PROXY BASIC_AUTH) + where + allowProxy = do + ServerConfig {allowSMPProxy, newQueueBasicAuth} <- asks config + pure $ allowSMPProxy && maybe True ((== auth) . Just) newQueueBasicAuth + getRelay = do + ProxyAgent {smpAgent = a} <- asks proxyAgent + liftIO (getConnectedSMPServerClient a srv) >>= \case + Just r -> Just <$> proxyServerResponse a r + Nothing -> + forkProxiedCmd $ + liftIO (runExceptT (getSMPServerClient'' a srv) `catch` (pure . Left . PCEIOError)) + >>= proxyServerResponse a + proxyServerResponse :: SMPClientAgent -> Either SMPClientError (OwnServer, SMPClient) -> M BrokerMsg + proxyServerResponse a smp_ = do + ServerStats {pRelays, pRelaysOwn} <- asks serverStats + let inc = mkIncProxyStats pRelays pRelaysOwn + case smp_ of + Right (own, smp) -> do + inc own pRequests + case proxyResp smp of + r@PKEY {} -> r <$ inc own pSuccesses + r -> r <$ inc own pErrorsCompat + Left e -> do + let own = isOwnServer a srv + inc own pRequests + inc own $ if temporaryClientError e then pErrorsConnect else pErrorsOther + logWarn $ "Error connecting: " <> decodeLatin1 (strEncode $ host srv) <> " " <> tshow e + pure . ERR $ smpProxyError e + where + proxyResp smp = + let THandleParams {sessionId = srvSessId, thVersion, thServerVRange, thAuth} = thParams smp + in case compatibleVRange thServerVRange proxiedSMPRelayVRange of + -- Cap the destination relay version range to prevent client version fingerprinting. + -- See comment for proxiedSMPRelayVersion. + Just (Compatible vr) | thVersion >= sendingProxySMPVersion -> case thAuth of + Just THAuthClient {serverCertKey} -> PKEY srvSessId vr serverCertKey + Nothing -> ERR $ transportErr TENoServerAuth + _ -> ERR $ transportErr TEVersion + PFWD fwdV pubKey encBlock -> do + ProxyAgent {smpAgent = a} <- asks proxyAgent + ServerStats {pMsgFwds, pMsgFwdsOwn} <- asks serverStats + let inc = mkIncProxyStats pMsgFwds pMsgFwdsOwn + atomically (lookupSMPServerClient a sessId) >>= \case + Just (own, smp) -> do + inc own pRequests + if v >= sendingProxySMPVersion + then forkProxiedCmd $ do + liftIO (runExceptT (forwardSMPTransmission smp corrId fwdV pubKey encBlock) `catch` (pure . Left . PCEIOError)) >>= \case + Right r -> PRES r <$ inc own pSuccesses + Left e -> ERR (smpProxyError e) <$ case e of + PCEProtocolError {} -> inc own pSuccesses + _ -> inc own pErrorsOther + else Just (ERR $ transportErr TEVersion) <$ inc own pErrorsCompat + where + THandleParams {thVersion = v} = thParams smp + Nothing -> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION) where - createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> M (Transmission BrokerMsg) - createQueue st recipientKey dhKey subMode = time "NEW" $ do + forkProxiedCmd :: M BrokerMsg -> M (Maybe BrokerMsg) + forkProxiedCmd cmdAction = do + bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " proxy") $ do + -- commands MUST be processed under a reasonable timeout or the client would halt + cmdAction >>= \t -> reply [(corrId, sessId, t)] + pure Nothing + where + wait = do + ServerConfig {serverClientConcurrency} <- asks config + atomically $ do + used <- readTVar procThreads + when (used >= serverClientConcurrency) retry + writeTVar procThreads $! used + 1 + signal = atomically $ modifyTVar' procThreads (\t -> t - 1) + transportErr :: TransportError -> ErrorType + transportErr = PROXY . BROKER . TRANSPORT + mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> TVar Int) -> m () + mkIncProxyStats ps psOwn own sel = do + atomically $ modifyTVar' (sel ps) (+ 1) + when own $ atomically $ modifyTVar' (sel psOwn) (+ 1) + processCommand :: (Maybe QueueRec, Transmission Cmd) -> M (Maybe (Transmission BrokerMsg)) + processCommand (qr_, (corrId, queueId, cmd)) = case cmd of + Cmd SProxiedClient command -> processProxiedCmd (corrId, queueId, command) + Cmd SSender command -> Just <$> case command of + SKEY sKey -> (corrId,queueId,) <$> case qr_ of + Just QueueRec {sndSecure, recipientId} + | sndSecure -> secureQueue_ "SKEY" recipientId sKey + | otherwise -> pure $ ERR AUTH + Nothing -> pure $ ERR INTERNAL + SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody + PING -> pure (corrId, "", PONG) + RFWD encBlock -> (corrId, "",) <$> processForwardedCommand encBlock + Cmd SNotifier NSUB -> Just <$> subscribeNotifications + Cmd SRecipient command -> do + st <- asks queueStore + Just <$> case command of + NEW rKey dhKey auth subMode sndSecure -> + ifM + allowNew + (createQueue st rKey dhKey subMode sndSecure) + (pure (corrId, queueId, ERR AUTH)) + where + allowNew = do + ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config + pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth + SUB -> withQueue (`subscribeQueue` queueId) + GET -> withQueue getMessage + ACK msgId -> withQueue (`acknowledgeMsg` msgId) + KEY sKey -> (corrId,queueId,) <$> case qr_ of + Just QueueRec {recipientId} -> secureQueue_ "KEY" recipientId sKey + Nothing -> pure $ ERR INTERNAL + NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey + NDEL -> deleteQueueNotifier_ st + OFF -> suspendQueue_ st + DEL -> delQueueAndMsgs st + QUE -> withQueue getQueueInfo + where + createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg) + createQueue st recipientKey dhKey subMode sndSecure = time "NEW" $ do (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random let rcvDhSecret = C.dh' dhKey privDhKey - qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey} + qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure} qRec (recipientId, senderId) = QueueRec { recipientId, @@ -631,7 +860,8 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Serv rcvDhSecret, senderKey = Nothing, notifier = Nothing, - status = QueueActive + status = QueueActive, + sndSecure } (corrId,queueId,) <$> addQueueRetry 3 qik qRec where @@ -666,12 +896,13 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Serv n <- asks $ queueIdBytes . config liftM2 (,) (randomId n) (randomId n) - secureQueue_ :: QueueStore -> SndPublicAuthKey -> M (Transmission BrokerMsg) - secureQueue_ st sKey = time "KEY" $ do - withLog $ \s -> logSecureQueue s queueId sKey + secureQueue_ :: T.Text -> RecipientId -> SndPublicAuthKey -> M BrokerMsg + secureQueue_ name rId sKey = time name $ do + withLog $ \s -> logSecureQueue s rId sKey + st <- asks queueStore stats <- asks serverStats atomically $ modifyTVar' (qSecured stats) (+ 1) - atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey + atomically $ either ERR (const OK) <$> secureQueue st rId sKey addQueueNotifier_ :: QueueStore -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M (Transmission BrokerMsg) addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do @@ -703,37 +934,41 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Serv subscribeQueue :: QueueRec -> RecipientId -> M (Transmission BrokerMsg) subscribeQueue qr rId = do + stats <- asks serverStats atomically (TM.lookup rId subscriptions) >>= \case - Nothing -> + Nothing -> do + atomically $ modifyTVar' (qSub stats) (+ 1) newSub >>= deliver - Just sub -> - readTVarIO sub >>= \case - Sub {subThread = ProhibitSub} -> + Just s@Sub {subThread} -> + readTVarIO subThread >>= \case + ProhibitSub -> do -- cannot use SUB in the same connection where GET was used + atomically $ modifyTVar' (qSubProhibited stats) (+ 1) pure (corrId, rId, ERR $ CMD PROHIBITED) - s -> - atomically (tryTakeTMVar $ delivered s) >> deliver sub + _ -> do + atomically $ modifyTVar' (qSubDuplicate stats) (+ 1) + atomically (tryTakeTMVar $ delivered s) >> deliver s where - newSub :: M (TVar Sub) + newSub :: M Sub newSub = time "SUB newSub" . atomically $ do writeTQueue subscribedQ (rId, clnt) - sub <- newTVar =<< newSubscription NoSub + sub <- newSubscription NoSub TM.insert rId sub subscriptions pure sub - deliver :: TVar Sub -> M (Transmission BrokerMsg) + deliver :: Sub -> M (Transmission BrokerMsg) deliver sub = do q <- getStoreMsgQueue "SUB" rId msg_ <- atomically $ tryPeekMsg q - deliverMessage "SUB" qr rId sub q msg_ + deliverMessage "SUB" qr rId sub msg_ getMessage :: QueueRec -> M (Transmission BrokerMsg) getMessage qr = time "GET" $ do atomically (TM.lookup queueId subscriptions) >>= \case Nothing -> atomically newSub >>= getMessage_ - Just sub -> - readTVarIO sub >>= \case - s@Sub {subThread = ProhibitSub} -> + Just s@Sub {subThread} -> + readTVarIO subThread >>= \case + ProhibitSub -> atomically (tryTakeTMVar $ delivered s) >> getMessage_ s -- cannot use GET in the same connection where there is an active subscription @@ -742,8 +977,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Serv newSub :: STM Sub newSub = do s <- newSubscription ProhibitSub - sub <- newTVar s - TM.insert queueId sub subscriptions + TM.insert queueId s subscriptions pure s getMessage_ :: Sub -> M (Transmission BrokerMsg) getMessage_ s = do @@ -771,25 +1005,24 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Serv Nothing -> pure $ err NO_MSG Just sub -> atomically (getDelivered sub) >>= \case - Just s -> do + Just st -> do q <- getStoreMsgQueue "ACK" queueId - case s of - Sub {subThread = ProhibitSub} -> do + case st of + ProhibitSub -> do deletedMsg_ <- atomically $ tryDelMsg q msgId mapM_ updateStats deletedMsg_ pure ok _ -> do (deletedMsg_, msg_) <- atomically $ tryDelPeekMsg q msgId mapM_ updateStats deletedMsg_ - deliverMessage "ACK" qr queueId sub q msg_ + deliverMessage "ACK" qr queueId sub msg_ _ -> pure $ err NO_MSG where - getDelivered :: TVar Sub -> STM (Maybe Sub) - getDelivered sub = do - s@Sub {delivered} <- readTVar sub + getDelivered :: Sub -> STM (Maybe SubscriptionThread) + getDelivered Sub {delivered, subThread} = do tryTakeTMVar delivered $>>= \msgId' -> if msgId == msgId' || B.null msgId - then pure $ Just s + then Just <$> readTVar subThread else putTMVar delivered msgId' $> Nothing updateStats :: Message -> M () updateStats = \case @@ -805,56 +1038,122 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Serv sendMessage :: QueueRec -> MsgFlags -> MsgBody -> M (Transmission BrokerMsg) sendMessage qr msgFlags msgBody - | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG - | otherwise = case status qr of - QueueOff -> return $ err AUTH - QueueActive -> - case C.maxLenBS msgBody of - Left _ -> pure $ err LARGE_MSG - Right body -> do - msg_ <- time "SEND" $ do - q <- getStoreMsgQueue "SEND" $ recipientId qr - expireMessages q - atomically . writeMsg q =<< mkMessage body - case msg_ of - Nothing -> pure $ err QUOTA - Just msg -> time "SEND ok" $ do - stats <- asks serverStats - when (notification msgFlags) $ do - atomically . trySendNotification msg =<< asks random - atomically $ modifyTVar' (msgSentNtf stats) (+ 1) - atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr) - atomically $ modifyTVar' (msgSent stats) (+ 1) - atomically $ modifyTVar' (msgCount stats) (+ 1) - atomically $ updatePeriodStats (activeQueues stats) (recipientId qr) - pure ok + | B.length msgBody > maxMessageLength thVersion = do + stats <- asks serverStats + atomically $ modifyTVar' (msgSentLarge stats) (+ 1) + pure $ err LARGE_MSG + | otherwise = do + stats <- asks serverStats + case status qr of + QueueOff -> do + atomically $ modifyTVar' (msgSentAuth stats) (+ 1) + pure $ err AUTH + QueueActive -> + case C.maxLenBS msgBody of + Left _ -> pure $ err LARGE_MSG + Right body -> do + msg_ <- time "SEND" $ do + q <- getStoreMsgQueue "SEND" $ recipientId qr + expireMessages q + atomically . writeMsg q =<< mkMessage body + case msg_ of + Nothing -> do + atomically $ modifyTVar' (msgSentQuota stats) (+ 1) + pure $ err QUOTA + Just (msg, wasEmpty) -> time "SEND ok" $ do + when wasEmpty $ tryDeliverMessage msg + when (notification msgFlags) $ do + forM_ (notifier qr) $ \ntf -> do + asks random >>= atomically . trySendNotification ntf msg >>= \case + Nothing -> do + atomically $ modifyTVar' (msgNtfNoSub stats) (+ 1) + logWarn "No notification subscription" + Just False -> do + atomically $ modifyTVar' (msgNtfLost stats) (+ 1) + logWarn "Dropped message notification" + Just True -> atomically $ modifyTVar' (msgNtfs stats) (+ 1) + atomically $ modifyTVar' (msgSentNtf stats) (+ 1) + atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr) + atomically $ modifyTVar' (msgSent stats) (+ 1) + atomically $ modifyTVar' (msgCount stats) (+ 1) + atomically $ updatePeriodStats (activeQueues stats) (recipientId qr) + pure ok where + THandleParams {thVersion} = thParams' mkMessage :: C.MaxLenBS MaxMessageLen -> M Message mkMessage body = do msgId <- randomId =<< asks (msgIdBytes . config) msgTs <- liftIO getSystemTime - pure $ Message msgId msgTs msgFlags body + pure $! Message msgId msgTs msgFlags body expireMessages :: MsgQueue -> M () expireMessages q = do msgExp <- asks $ messageExpiration . config old <- liftIO $ mapM expireBeforeEpoch msgExp - stats <- asks serverStats deleted <- atomically $ sum <$> mapM (deleteExpiredMsgs q) old - atomically $ modifyTVar' (msgExpired stats) (+ deleted) + when (deleted > 0) $ do + stats <- asks serverStats + atomically $ modifyTVar' (msgExpired stats) (+ deleted) - trySendNotification :: Message -> TVar ChaChaDRG -> STM () - trySendNotification msg ntfNonceDrg = - forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} -> - mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers + -- The condition for delivery of the message is: + -- - the queue was empty when the message was sent, + -- - there is subscribed recipient, + -- - no message was "delivered" that was not acknowledged. + -- If the send queue of the subscribed client is not full the message is put there in the same transaction. + -- If the queue is not full, then the thread is created where these checks are made: + -- - it is the same subscribed client (in case it was reconnected it would receive message via SUB command) + -- - nothing was delivered to this subscription (to avoid race conditions with the recipient). + tryDeliverMessage :: Message -> M () + tryDeliverMessage msg = atomically deliverToSub >>= mapM_ forkDeliver + where + rId = recipientId qr + deliverToSub = + TM.lookup rId subscribers + $>>= \rc@Client {subscriptions = subs, sndQ = q} -> TM.lookup rId subs + $>>= \s@Sub {subThread, delivered} -> readTVar subThread >>= \case + NoSub -> + tryTakeTMVar delivered >>= \case + Just _ -> pure Nothing -- if a message was already delivered, should not deliver more + Nothing -> + ifM + (isFullTBQueue q) + (writeTVar subThread SubPending $> Just (rc, s)) + (deliver q s $> Nothing) + _ -> pure Nothing + deliver q s = do + let encMsg = encryptMsg qr msg + writeTBQueue q [(CorrId "", rId, MSG encMsg)] + void $ setDelivered s msg + forkDeliver (rc@Client {sndQ = q}, s@Sub {subThread, delivered}) = do + t <- mkWeakThreadId =<< forkIO deliverThread + atomically . modifyTVar' subThread $ \case + -- this case is needed because deliverThread can exit before it + SubPending -> SubThread t + st -> st + where + deliverThread = do + labelMyThread $ B.unpack ("client $" <> encode sessionId) <> " deliver/SEND" + time "deliver" . atomically $ + whenM (maybe False (sameClientId rc) <$> TM.lookup rId subscribers) $ do + tryTakeTMVar delivered >>= \case + Just _ -> pure () -- if a message was already delivered, should not deliver more + Nothing -> do + deliver q s + writeTVar subThread NoSub - writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM () + trySendNotification :: NtfCreds -> Message -> TVar ChaChaDRG -> STM (Maybe Bool) + trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg ntfNonceDrg = + mapM (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers + + writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM Bool writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} = - unlessM (isFullTBQueue q) $ case msg of - Message {msgId, msgTs} -> do - (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg - writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)] - _ -> pure () + ifM (isFullTBQueue q) (pure False) (sendNtf $> True) + where + sendNtf = case msg of + Message {msgId, msgTs} -> do + (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg + writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)] + _ -> pure () mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta) mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg = do @@ -863,34 +1162,70 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Serv encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128 pure . (cbNonce,) $ fromRight "" encNMsgMeta - deliverMessage :: T.Text -> QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> M (Transmission BrokerMsg) - deliverMessage name qr rId sub q msg_ = time (name <> " deliver") $ do - readTVarIO sub >>= \case - s@Sub {subThread = NoSub} -> - case msg_ of - Just msg -> - let encMsg = encryptMsg qr msg - in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg) - _ -> forkSub $> ok - _ -> pure ok + processForwardedCommand :: EncFwdTransmission -> M BrokerMsg + processForwardedCommand (EncFwdTransmission s) = fmap (either ERR id) . runExceptT $ do + THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwE $ transportErr TENoServerAuth) pure (thAuth thParams') + sessSecret <- maybe (throwE $ transportErr TENoServerAuth) pure sessSecret' + let proxyNonce = C.cbNonce $ bs corrId + s' <- liftEitherWith (const CRYPTO) $ C.cbDecryptNoPad sessSecret proxyNonce s + FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission et} <- liftEitherWith (const $ CMD SYNTAX) $ smpDecode s' + let clientSecret = C.dh' fwdKey serverPrivKey + clientNonce = C.cbNonce $ bs fwdCorrId + b <- liftEitherWith (const CRYPTO) $ C.cbDecrypt clientSecret clientNonce et + let clntTHParams = smpTHParamsSetVersion fwdVersion thParams' + -- only allowing single forwarded transactions + t' <- case tParse clntTHParams b of + t :| [] -> pure $ tDecodeParseValidate clntTHParams t + _ -> throwE BLOCK + let clntThAuth = Just $ THAuthServer {serverPrivKey, sessSecret' = Just clientSecret} + -- process forwarded command + r <- + lift (rejectOrVerify clntThAuth t') >>= \case + Left r -> pure r + -- rejectOrVerify filters allowed commands, no need to repeat it here. + -- INTERNAL is used because processCommand never returns Nothing for sender commands (could be extracted for better types). + Right t''@(_, (corrId', entId', _)) -> fromMaybe (corrId', entId', ERR INTERNAL) <$> lift (processCommand t'') + -- encode response + r' <- case batchTransmissions (batch clntTHParams) (blockSize clntTHParams) [Right (Nothing, encodeTransmission clntTHParams r)] of + [] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right + TBError _ _ : _ -> throwE BLOCK + TBTransmission b' _ : _ -> pure b' + TBTransmissions b' _ _ : _ -> pure b' + -- encrypt to client + r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (C.reverseNonce clientNonce) r' paddedProxiedTLength + -- encrypt to proxy + let fr = FwdResponse {fwdCorrId, fwdResponse = r2} + r3 = EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr) + stats <- asks serverStats + atomically $ modifyTVar' (pMsgFwdsRecv stats) (+ 1) + pure $ RRES r3 where - forkSub :: M () - forkSub = do - atomically . modifyTVar' sub $ \s -> s {subThread = SubPending} - t <- mkWeakThreadId =<< forkIO subscriber - atomically . modifyTVar' sub $ \case - s@Sub {subThread = SubPending} -> s {subThread = SubThread t} - s -> s - where - subscriber = do - labelMyThread $ B.unpack ("client $" <> encode sessionId) <> " subscriber/" <> T.unpack name - msg <- atomically $ peekMsg q - time "subscriber" . atomically $ do - let encMsg = encryptMsg qr msg - writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)] - s <- readTVar sub - void $ setDelivered s msg - writeTVar sub $! s {subThread = NoSub} + rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd)) + rejectOrVerify clntThAuth (tAuth, authorized, (corrId', entId', cmdOrError)) = + case cmdOrError of + Left e -> pure $ Left (corrId', entId', ERR e) + Right cmd' + | allowed -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId')) <$> clntThAuth) tAuth authorized entId' cmd' + | otherwise -> pure $ Left (corrId', entId', ERR $ CMD PROHIBITED) + where + allowed = case cmd' of + Cmd SSender SEND {} -> True + Cmd SSender (SKEY _) -> True + _ -> False + verified = \case + VRVerified qr -> Right (qr, (corrId', entId', cmd')) + VRFailed -> Left (corrId', entId', ERR AUTH) + deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> M (Transmission BrokerMsg) + deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") . atomically $ + readTVar subThread >>= \case + ProhibitSub -> pure resp + _ -> case msg_ of + Just msg -> + let encMsg = encryptMsg qr msg + in setDelivered s msg $> (corrId, rId, MSG encMsg) + _ -> pure resp + where + resp = (corrId, rId, OK) time :: T.Text -> M a -> M a time name = timed name queueId @@ -906,7 +1241,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Serv msgTs' = messageTs msg setDelivered :: Sub -> Message -> STM Bool - setDelivered s msg = tryPutTMVar (delivered s) (messageId msg) + setDelivered s msg = tryPutTMVar (delivered s) $! messageId msg getStoreMsgQueue :: T.Text -> RecipientId -> M MsgQueue getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do @@ -922,6 +1257,26 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Serv Right q -> updateDeletedStats q $> ok Left e -> pure $ err e + getQueueInfo :: QueueRec -> M (Transmission BrokerMsg) + getQueueInfo QueueRec {senderKey, notifier} = do + q@MsgQueue {size} <- getStoreMsgQueue "getQueueInfo" queueId + info <- atomically $ do + qiSub <- TM.lookup queueId subscriptions >>= mapM mkQSub + qiSize <- readTVar size + qiMsg <- toMsgInfo <$$> tryPeekMsg q + pure QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg} + pure (corrId, queueId, INFO info) + where + mkQSub Sub {subThread, delivered} = do + st <- readTVar subThread + let qSubThread = case st of + NoSub -> QNoSub + SubPending -> QSubPending + SubThread _ -> QSubThread + ProhibitSub -> QProhibitSub + qDelivered <- decodeLatin1 . encode <$$> tryReadTMVar delivered + pure QSub {qSubThread, qDelivered} + ok :: Transmission BrokerMsg ok = (corrId, queueId, OK) @@ -975,9 +1330,10 @@ saveServerMessages keepMsgs = asks (storeMsgsFile . config) >>= mapM_ saveMessag >>= mapM_ (B.hPutStrLn h . strEncode . MLRv3 rId) restoreServerMessages :: M Int -restoreServerMessages = asks (storeMsgsFile . config) >>= \case - Just f -> ifM (doesFileExist f) (restoreMessages f) (pure 0) - Nothing -> pure 0 +restoreServerMessages = + asks (storeMsgsFile . config) >>= \case + Just f -> ifM (doesFileExist f) (restoreMessages f) (pure 0) + Nothing -> pure 0 where restoreMessages f = do logInfo $ "restoring messages from file " <> T.pack f diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index 9531a2ca5..c22c1a161 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -24,6 +24,7 @@ import qualified Data.X509.File as XF import Data.X509.Validation (Fingerprint (..)) import Network.Socket (HostName, ServiceName) import Options.Applicative +import Simplex.Messaging.Client (SocksMode (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI) import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) @@ -254,7 +255,7 @@ onOffPrompt prompt def = "N" -> pure False _ -> putStrLn "Invalid input, please enter 'y' or 'n'" >> onOffPrompt prompt def -onOff :: Bool -> String +onOff :: Bool -> Text onOff True = "on" onOff _ = "off" @@ -301,3 +302,9 @@ clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= getEnvPath :: String -> FilePath -> IO FilePath getEnvPath name def = maybe def (\case "" -> def; f -> f) <$> lookupEnv name + +textToSocksMode :: Text -> SocksMode +textToSocksMode = \case + "always" -> SMAlways + "onion" -> SMOnion + s -> error . T.unpack $ "Invalid socks_mode: " <> s diff --git a/src/Simplex/Messaging/Server/Control.hs b/src/Simplex/Messaging/Server/Control.hs index 9463fa777..b4c74e4ac 100644 --- a/src/Simplex/Messaging/Server/Control.hs +++ b/src/Simplex/Messaging/Server/Control.hs @@ -9,6 +9,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (BasicAuth) data CPClientRole = CPRNone | CPRUser | CPRAdmin + deriving (Eq) data ControlProtocol = CPAuth BasicAuth @@ -20,6 +21,7 @@ data ControlProtocol | CPThreads | CPSockets | CPSocketThreads + | CPServerInfo | CPDelete ByteString | CPSave | CPHelp @@ -37,6 +39,7 @@ instance StrEncoding ControlProtocol where CPThreads -> "threads" CPSockets -> "sockets" CPSocketThreads -> "socket-threads" + CPServerInfo -> "server-info" CPDelete bs -> "delete " <> strEncode bs CPSave -> "save" CPHelp -> "help" @@ -53,6 +56,7 @@ instance StrEncoding ControlProtocol where "threads" -> pure CPThreads "sockets" -> pure CPSockets "socket-threads" -> pure CPSocketThreads + "server-info" -> pure CPServerInfo "delete" -> CPDelete <$> (A.space *> strP) "save" -> pure CPSave "help" -> pure CPHelp diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index baadfc79b..b40e9fc16 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} module Simplex.Messaging.Server.Env.STM where @@ -15,6 +16,7 @@ import qualified Data.IntMap.Strict as IM import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import Data.Maybe (isJust, isNothing) import Data.Time.Clock (getCurrentTime) import Data.Time.Clock.System (SystemTime) import Data.X509.Validation (Fingerprint (..)) @@ -22,10 +24,12 @@ import Network.Socket (ServiceName) import qualified Network.TLS as T import Numeric.Natural import Simplex.Messaging.Agent.Lock +import Simplex.Messaging.Client.Agent (SMPClientAgent, SMPClientAgentConfig, newSMPClientAgent) import Simplex.Messaging.Crypto (KeyHash (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.Information import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..)) import Simplex.Messaging.Server.QueueStore.STM @@ -33,8 +37,8 @@ import Simplex.Messaging.Server.Stats import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (ATransport, VersionSMP, VersionRangeSMP) -import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, loadFingerprint, loadTLSServerParams, newSocketState) +import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP) +import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams, newSocketState) import System.IO (IOMode (..)) import System.Mem.Weak (Weak) import UnliftIO.STM @@ -43,7 +47,6 @@ data ServerConfig = ServerConfig { transports :: [(ServiceName, ATransport)], smpHandshakeTimeout :: Int, tbqSize :: Natural, - -- serverTbqSize :: Natural, msgQueueQuota :: Int, queueIdBytes :: Int, msgIdBytes :: Int, @@ -79,7 +82,13 @@ data ServerConfig = ServerConfig -- | TCP transport config transportConfig :: TransportServerConfig, -- | run listener on control port - controlPort :: Maybe ServiceName + controlPort :: Maybe ServiceName, + -- | SMP proxy config + smpAgentCfg :: SMPClientAgentConfig, + allowSMPProxy :: Bool, -- auth is the same with `newQueueBasicAuth` + serverClientConcurrency :: Int, + -- | server public information + information :: Maybe ServerPublicInfo } defMsgExpirationDays :: Int64 @@ -99,8 +108,12 @@ defaultInactiveClientExpiration = checkInterval = 3600 -- seconds, 1 hours } +defaultProxyClientConcurrency :: Int +defaultProxyClientConcurrency = 32 + data Env = Env { config :: ServerConfig, + serverInfo :: ServerInformation, server :: Server, serverIdentity :: KeyHash, queueStore :: QueueStore, @@ -110,8 +123,9 @@ data Env = Env tlsServerParams :: T.ServerParams, serverStats :: ServerStats, sockets :: SocketState, - clientSeq :: TVar Int, - clients :: TVar (IntMap Client) + clientSeq :: TVar ClientId, + clients :: TVar (IntMap Client), + proxyAgent :: ProxyAgent -- senders served on this proxy } data Server = Server @@ -122,12 +136,20 @@ data Server = Server savingLock :: Lock } +newtype ProxyAgent = ProxyAgent + { smpAgent :: SMPClientAgent + } + +type ClientId = Int + data Client = Client - { clientId :: Int, - subscriptions :: TMap RecipientId (TVar Sub), + { clientId :: ClientId, + subscriptions :: TMap RecipientId Sub, ntfSubscriptions :: TMap NotifierId (), rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)), sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)), + msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)), + procThreads :: TVar Int, endThreads :: TVar (IntMap (Weak ThreadId)), endThreadSeq :: TVar Int, thVersion :: VersionSMP, @@ -141,7 +163,7 @@ data Client = Client data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub data Sub = Sub - { subThread :: SubscriptionThread, + { subThread :: TVar SubscriptionThread, delivered :: TMVar MsgId } @@ -154,40 +176,44 @@ newServer = do savingLock <- createLock return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock} -newClient :: TVar Int -> Natural -> VersionSMP -> ByteString -> SystemTime -> STM Client +newClient :: TVar ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> STM Client newClient nextClientId qSize thVersion sessionId createdAt = do clientId <- stateTVar nextClientId $ \next -> (next, next + 1) subscriptions <- TM.empty ntfSubscriptions <- TM.empty rcvQ <- newTBQueue qSize sndQ <- newTBQueue qSize + msgQ <- newTBQueue qSize + procThreads <- newTVar 0 endThreads <- newTVar IM.empty endThreadSeq <- newTVar 0 connected <- newTVar True rcvActiveAt <- newTVar createdAt sndActiveAt <- newTVar createdAt - return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt} + return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, msgQ, procThreads, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt} newSubscription :: SubscriptionThread -> STM Sub -newSubscription subThread = do +newSubscription st = do delivered <- newEmptyTMVar + subThread <- newTVar st return Sub {subThread, delivered} newEnv :: ServerConfig -> IO Env -newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do +newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, smpAgentCfg, transportConfig, information, messageExpiration} = do server <- atomically newServer queueStore <- atomically newQueueStore msgStore <- atomically newMsgStore random <- liftIO C.newRandom storeLog <- restoreQueues queueStore `mapM` storeLogFile - tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile + tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig) Fingerprint fp <- loadFingerprint caCertificateFile let serverIdentity = KeyHash fp serverStats <- atomically . newServerStats =<< getCurrentTime sockets <- atomically newSocketState clientSeq <- newTVarIO 0 clients <- newTVarIO mempty - return Env {config, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients} + proxyAgent <- atomically $ newSMPProxyAgent smpAgentCfg random + pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients, proxyAgent} where restoreQueues :: QueueStore -> FilePath -> IO (StoreLog 'WriteMode) restoreQueues QueueStore {queues, senders, notifiers} f = do @@ -203,3 +229,25 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, addNotifier q = case notifier q of Nothing -> id Just NtfCreds {notifierId} -> M.insert notifierId (recipientId q) + serverInfo = + ServerInformation + { information, + config = + ServerPublicConfig + { persistence, + messageExpiration = ttl <$> messageExpiration, + statsEnabled = isJust $ logStatsInterval config, + newQueuesAllowed = allowNewQueues config, + basicAuthEnabled = isJust $ newQueueBasicAuth config + } + } + where + persistence + | isNothing storeLogFile = SPMMemoryOnly + | isJust (storeMsgsFile config) = SPMMessages + | otherwise = SPMQueues + +newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> STM ProxyAgent +newSMPProxyAgent smpAgentCfg random = do + smpAgent <- newSMPClientAgent smpAgentCfg random + pure ProxyAgent {smpAgent} diff --git a/src/Simplex/Messaging/Server/Information.hs b/src/Simplex/Messaging/Server/Information.hs new file mode 100644 index 000000000..01052541d --- /dev/null +++ b/src/Simplex/Messaging/Server/Information.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Messaging.Server.Information where + +import qualified Data.Aeson.TH as J +import Data.Int (Int64) +import Data.Text (Text) +import Simplex.Messaging.Agent.Protocol (ConnectionMode (..), ConnectionRequestUri) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) + +data ServerInformation = ServerInformation + { config :: ServerPublicConfig, + information :: Maybe ServerPublicInfo + } + deriving (Show) + +-- based on server configuration +data ServerPublicConfig = ServerPublicConfig + { persistence :: ServerPersistenceMode, + messageExpiration :: Maybe Int64, + statsEnabled :: Bool, + newQueuesAllowed :: Bool, + basicAuthEnabled :: Bool -- server is private if enabled + } + deriving (Show) + +-- based on INFORMATION section of INI file +data ServerPublicInfo = ServerPublicInfo + { sourceCode :: Text, -- note that this property is not optional, in line with AGPLv3 license + usageConditions :: Maybe ServerConditions, + operator :: Maybe Entity, + website :: Maybe Text, + adminContacts :: Maybe ServerContactAddress, + complaintsContacts :: Maybe ServerContactAddress, + hosting :: Maybe Entity, + serverCountry :: Maybe Text + } + deriving (Show) + +data ServerPersistenceMode = SPMMemoryOnly | SPMQueues | SPMMessages + deriving (Show) + +data ServerConditions = ServerConditions {conditions :: Text, amendments :: Maybe Text} + deriving (Show) + +data Entity = Entity {name :: Text, country :: Maybe Text} + deriving (Show) + +data ServerContactAddress = ServerContactAddress + { simplex :: Maybe (ConnectionRequestUri 'CMContact), + email :: Maybe Text, -- it is recommended that it matches DNS email address, if either is present + pgp :: Maybe PGPKey + } + deriving (Show) + +data PGPKey = PGPKey {pkURI :: Text, pkFingerprint :: Text} + deriving (Show) + +$(J.deriveJSON (enumJSON $ dropPrefix "SPM") ''ServerPersistenceMode) + +$(J.deriveJSON defaultJSON ''ServerConditions) + +$(J.deriveJSON defaultJSON ''Entity) + +$(J.deriveJSON defaultJSON ''PGPKey) + +$(J.deriveJSON defaultJSON ''ServerContactAddress) + +$(J.deriveJSON defaultJSON ''ServerPublicConfig) + +$(J.deriveJSON defaultJSON ''ServerPublicInfo) + +$(J.deriveJSON defaultJSON ''ServerInformation) diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index a7844cc95..a135565bf 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -5,37 +5,56 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} module Simplex.Messaging.Server.Main where import Control.Concurrent.STM -import Control.Monad (void) +import Control.Logger.Simple +import Control.Monad (void, when, (<$!>)) +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Char (isAlpha, isAscii, toUpper) import Data.Functor (($>)) -import Data.Ini (lookupValue, readIniFile) -import Data.Maybe (fromMaybe) +import Data.Ini (Ini, lookupValue, readIniFile) +import Data.List (find, isPrefixOf) +import qualified Data.List.NonEmpty as L +import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.IO as T import Network.Socket (HostName) import Options.Applicative +import Simplex.Messaging.Agent.Protocol (connReqUriP') +import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig) +import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer) import Simplex.Messaging.Server (runSMPServer) import Simplex.Messaging.Server.CLI -import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration) +import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration, defaultProxyClientConcurrency) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Transport (simplexMQVersion, supportedServerSMPRelayVRange) +import Simplex.Messaging.Server.Information +import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig) -import Simplex.Messaging.Util (safeDecodeUtf8) +import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow) +import Simplex.Messaging.Version (mkVersionRange) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (combine) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) import Text.Read (readMaybe) smpServerCLI :: FilePath -> FilePath -> IO () -smpServerCLI cfgPath logPath = +smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ()) + +smpServerCLI_ :: (ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) -> (EmbeddedWebParams -> IO ()) -> FilePath -> FilePath -> IO () +smpServerCLI_ generateSite serveStaticFiles cfgPath logPath = getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case Init opts -> doesFileExist iniFile >>= \case @@ -60,7 +79,10 @@ smpServerCLI cfgPath logPath = defaultServerPort = "5223" executableName = "smp-server" storeLogFilePath = combine logPath "smp-server-store.log" - initializeServer opts@InitOptions {ip, fqdn, scripted} + httpsCertFile = combine cfgPath "web.cert" + httpsKeyFile = combine cfgPath "web.key" + defaultStaticPath = combine logPath "www" + initializeServer opts@InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb', scripted} | scripted = initialize opts | otherwise = do putStrLn "Use `smp-server init -h` for available options." @@ -71,7 +93,19 @@ smpServerCLI cfgPath logPath = password <- withPrompt "'r' for random (default), 'n' - no password, or enter password: " serverPassword let host = fromMaybe ip fqdn host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine - initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn else Just host', password} + sourceCode' <- withPrompt ("Enter server source code URI (" <> maybe simplexmqSource T.unpack src' <> "): ") getServerSourceCode + staticPath' <- withPrompt ("Enter path to store generated static site with server information (" <> fromMaybe defaultStaticPath sp' <> "): ") getLine + enableWeb <- onOffPrompt "Enable built-in web server for static site" (not noWeb') + initialize + opts + { enableStoreLog, + logStats, + fqdn = if null host' then fqdn else Just host', + password, + sourceCode = (T.pack <$> sourceCode') <|> src', + webStaticPath = if null staticPath' then sp' else Just staticPath', + disableWeb = not enableWeb + } where serverPassword = getLine >>= \case @@ -82,7 +116,7 @@ smpServerCLI cfgPath logPath = case strDecode $ encodeUtf8 $ T.pack s of Right auth -> pure . Just $ ServerPassword auth _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword - initialize InitOptions {enableStoreLog, logStats, signAlgorithm, password} = do + initialize InitOptions {enableStoreLog, logStats, signAlgorithm, password, sourceCode, webStaticPath, disableWeb} = do clearDirIfExists cfgPath clearDirIfExists logPath createDirectoryIfMissing True cfgPath @@ -92,26 +126,29 @@ smpServerCLI cfgPath logPath = basicAuth <- mapM createServerPassword password let host = fromMaybe (if ip == "127.0.0.1" then "" else ip) fqdn srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth - writeFile iniFile $ iniFileContent host basicAuth - putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server." + T.writeFile iniFile $ iniFileContent host basicAuth $ Just "https://github.com/simplex-chat/simplexmq" + putStrLn $ "Server initialized, please provide additional server information in " <> iniFile <> "." + putStrLn $ "Run `" <> executableName <> " start` to start server." warnCAPrivateKeyFile cfgPath x509cfg printServiceInfo serverVersion srv + printSourceCode sourceCode where createServerPassword = \case ServerPassword s -> pure s SPRandom -> BasicAuth . strEncode <$> (atomically . C.randomBytes 32 =<< C.newRandom) - iniFileContent host basicAuth = - "[STORE_LOG]\n\ - \# The server uses STM memory for persistence,\n\ - \# that will be lost on restart (e.g., as with redis).\n\ - \# This option enables saving memory to append only log,\n\ - \# and restoring it when the server is started.\n\ - \# Log is compacted on start (deleted objects are removed).\n" + iniFileContent host basicAuth sourceCode' = + informationIniContent sourceCode' + <> "[STORE_LOG]\n\ + \# The server uses STM memory for persistence,\n\ + \# that will be lost on restart (e.g., as with redis).\n\ + \# This option enables saving memory to append only log,\n\ + \# and restoring it when the server is started.\n\ + \# Log is compacted on start (deleted objects are removed).\n" <> ("enable: " <> onOff enableStoreLog <> "\n\n") <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\ \# they are preserved in the .bak file until the next restart.\n" <> ("restore_messages: " <> onOff enableStoreLog <> "\n") - <> ("expire_messages_days: " <> show defMsgExpirationDays <> "\n\n") + <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n\n") <> "# Log daily server statistics to CSV file\n" <> ("log_stats: " <> onOff logStats <> "\n\n") <> "[AUTH]\n\ @@ -124,33 +161,64 @@ smpServerCLI cfgPath logPath = \# The password will not be shared with the connecting contacts, you must share it only\n\ \# with the users who you want to allow creating messaging queues on your server.\n" <> ( case basicAuth of - Just auth -> "create_password: " <> T.unpack (safeDecodeUtf8 $ strEncode auth) + Just auth -> "create_password: " <> safeDecodeUtf8 (strEncode auth) _ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')" ) <> "\n\n\ \# control_port_admin_password:\n\ - \# control_port_user_password:\n\ + \# control_port_user_password:\n\n\ \[TRANSPORT]\n\ \# host is only used to print server address on start\n" - <> ("host: " <> host <> "\n") - <> ("port: " <> defaultServerPort <> "\n") + <> ("host: " <> T.pack host <> "\n") + <> ("port: " <> T.pack defaultServerPort <> "\n") <> "log_tls_errors: off\n\ \websockets: off\n\ \# control_port: 5224\n\n\ - \[INACTIVE_CLIENTS]\n\ + \[PROXY]\n\ + \# Network configuration for SMP proxy client.\n\ + \# `host_mode` can be 'public' (default) or 'onion'.\n\ + \# It defines prefferred hostname for destination servers with multiple hostnames.\n\ + \# host_mode: public\n\ + \# required_host_mode: off\n\n\ + \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n\ + \# own_server_domains: \n\n\ + \# SOCKS proxy port for forwarding messages to destination servers.\n\ + \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\ + \# socks_proxy: localhost:9050\n\n\ + \# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\ + \# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\ + \# socks_mode: onion\n\n\ + \# Limit number of threads a client can spawn to process proxy commands in parrallel.\n" + <> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency <> "\n\n") + <> "[INACTIVE_CLIENTS]\n\ \# TTL and interval to check inactive clients\n\ \disconnect: off\n" - <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n") - <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n") + <> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n") + <> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n") + <> "\n\n\ + \[WEB]\n\ + \# Set path to generate static mini-site for server information and qr codes/links\n" + <> ("static_path: " <> T.pack (fromMaybe defaultStaticPath webStaticPath) <> "\n\n") + <> "# Run an embedded server on this port\n\ + \# Onion sites can use any port and register it in the hidden service config.\n\ + \# Running on a port 80 may require setting process capabilities.\n" + <> ((if disableWeb then "# " else "") <> "http: 8000\n\n") + <> "# You can run an embedded TLS web server too if you provide port and cert and key files.\n\ + \# Not required for running relay on onion address.\n\ + \# https: 443\n" + <> ("# cert: " <> T.pack httpsCertFile <> "\n") + <> ("# key: " <> T.pack httpsKeyFile <> "\n") runServer ini = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering fp <- checkSavedFingerprint cfgPath defaultX509Config let host = either (const "") T.unpack $ lookupValue "TRANSPORT" "host" ini port = T.unpack $ strictIni "TRANSPORT" "port" ini - cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig + cfg@ServerConfig {information, transports, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig + sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth printServiceInfo serverVersion srv + printSourceCode sourceCode' printServerConfig transports storeLogFile putStrLn $ case messageExpiration of Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl @@ -163,6 +231,20 @@ smpServerCLI cfgPath logPath = <> if allowNewQueues cfg then maybe "allowed" (const "requires password") newQueueBasicAuth else "NOT allowed" + -- print information + let persistence + | isNothing storeLogFile = SPMMemoryOnly + | isJust (storeMsgsFile cfg) = SPMMessages + | otherwise = SPMQueues + let config = + ServerPublicConfig + { persistence, + messageExpiration = ttl <$> messageExpiration, + statsEnabled = isJust logStats, + newQueuesAllowed = allowNewQueues cfg, + basicAuthEnabled = isJust newQueueBasicAuth + } + runWebServer ini ServerInformation {config, information} runSMPServer cfg where enableStoreLog = settingIsOn "STORE_LOG" "enable" ini @@ -173,7 +255,6 @@ smpServerCLI cfgPath logPath = { transports = iniTransports ini, smpHandshakeTimeout = 120000000, tbqSize = 64, - -- serverTbqSize = 1024, msgQueueQuota = 128, queueIdBytes = 24, msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20 @@ -190,9 +271,9 @@ smpServerCLI cfgPath logPath = _ -> enableStoreLog $> messagesPath, -- allow creating new queues by default allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, - newQueueBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini, - controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini, - controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini, + newQueueBasicAuth = either error id <$!> strDecodeIni "AUTH" "create_password" ini, + controlPortAdminAuth = either error id <$!> strDecodeIni "AUTH" "control_port_admin_password" ini, + controlPortUserAuth = either error id <$!> strDecodeIni "AUTH" "control_port_user_password" ini, messageExpiration = Just defaultMessageExpiration @@ -211,10 +292,158 @@ smpServerCLI cfgPath logPath = smpServerVRange = supportedServerSMPRelayVRange, transportConfig = defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini + { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini, + alpn = Just supportedSMPHandshakes }, - controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini + controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini, + smpAgentCfg = + defaultSMPClientAgentConfig + { smpCfg = + (smpCfg defaultSMPClientAgentConfig) + { serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion, + agreeSecret = True, + networkConfig = + defaultNetworkConfig + { socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini, + socksMode = either (const SMOnion) textToSocksMode $ lookupValue "PROXY" "socks_mode" ini, + hostMode = either (const HMPublic) textToHostMode $ lookupValue "PROXY" "host_mode" ini, + requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini + } + }, + ownServerDomains = either (const []) textToOwnServers $ lookupValue "PROXY" "own_server_domains" ini, + persistErrorInterval = 30 -- seconds + }, + allowSMPProxy = True, + serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini, + information = serverPublicInfo ini } + textToHostMode :: Text -> HostMode + textToHostMode = \case + "public" -> HMPublic + "onion" -> HMOnionViaSocks + s -> error . T.unpack $ "Invalid host_mode: " <> s + textToOwnServers :: Text -> [ByteString] + textToOwnServers = map encodeUtf8 . T.words + + runWebServer ini si = + case eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini of + Nothing -> logWarn "No server static path set" + Just webStaticPath -> do + let onionHost = + either (const Nothing) (find isOnion) $ + strDecode @(L.NonEmpty TransportHost) . encodeUtf8 =<< lookupValue "TRANSPORT" "host" ini + webHttpPort = eitherToMaybe $ read . T.unpack <$> lookupValue "WEB" "http" ini + webHttpsParams = + eitherToMaybe $ do + port <- read . T.unpack <$> lookupValue "WEB" "https" ini + cert <- T.unpack <$> lookupValue "WEB" "cert" ini + key <- T.unpack <$> lookupValue "WEB" "key" ini + pure WebHttpsParams {port, cert, key} + generateSite si onionHost webStaticPath + when (isJust webHttpPort || isJust webHttpsParams) $ + serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams} + where + isOnion = \case THOnionHost _ -> True; _ -> False + +data EmbeddedWebParams = EmbeddedWebParams + { webStaticPath :: FilePath, + webHttpPort :: Maybe Int, + webHttpsParams :: Maybe WebHttpsParams + } + +data WebHttpsParams = WebHttpsParams + { port :: Int, + cert :: FilePath, + key :: FilePath + } + +getServerSourceCode :: IO (Maybe String) +getServerSourceCode = + getLine >>= \case + "" -> pure Nothing + s | "https://" `isPrefixOf` s || "http://" `isPrefixOf` s -> pure $ Just s + _ -> putStrLn "Invalid source code. URI should start from http:// or https://" >> getServerSourceCode + +simplexmqSource :: String +simplexmqSource = "https://github.com/simplex-chat/simplexmq" + +informationIniContent :: Maybe Text -> Text +informationIniContent sourceCode_ = + "[INFORMATION]\n\ + \# AGPLv3 license requires that you make any source code modifications\n\ + \# available to the end users of the server.\n\ + \# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE\n\ + \# Include correct source code URI in case the server source code is modified in any way.\n\ + \# If any other information fields are present, source code property also MUST be present.\n\n" + <> (maybe "# source_code: URI" ("source_code: " <>) sourceCode_ <> "\n\n") + <> "# Declaring all below information is optional, any of these fields can be omitted.\n\ + \\n\ + \# Server usage conditions and amendments.\n\ + \# It is recommended to use standard conditions with any amendments in a separate document.\n\ + \# usage_conditions: https://github.com/simplex-chat/simplex-chat/blob/stable/PRIVACY.md\n\ + \# condition_amendments: link\n\ + \\n\ + \# Server location and operator.\n\ + \# server_country: ISO-3166 2-letter code\n\ + \# operator: entity (organization or person name)\n\ + \# operator_country: ISO-3166 2-letter code\n\ + \# website:\n\ + \\n\ + \# Administrative contacts.\n\ + \# admin_simplex: SimpleX address\n\ + \# admin_email:\n\ + \# admin_pgp:\n\ + \# admin_pgp_fingerprint:\n\ + \\n\ + \# Contacts for complaints and feedback.\n\ + \# complaints_simplex: SimpleX address\n\ + \# complaints_email:\n\ + \# complaints_pgp:\n\ + \# complaints_pgp_fingerprint:\n\ + \\n\ + \# Hosting provider.\n\ + \# hosting: entity (organization or person name)\n\ + \# hosting_country: ISO-3166 2-letter code\n\n" + +serverPublicInfo :: Ini -> Maybe ServerPublicInfo +serverPublicInfo ini = serverInfo <$!> infoValue "source_code" + where + serverInfo sourceCode = + ServerPublicInfo + { sourceCode, + usageConditions = + (\conditions -> ServerConditions {conditions, amendments = infoValue "condition_amendments"}) + <$!> infoValue "usage_conditions", + serverCountry = countryValue "server_country", + operator = iniEntity "operator" "operator_country", + website = infoValue "website", + adminContacts = iniContacts "admin_simplex" "admin_email" "admin_pgp" "admin_pgp_fingerprint", + complaintsContacts = iniContacts "complaints_simplex" "complaints_email" "complaints_pgp" "complaints_pgp_fingerprint", + hosting = iniEntity "hosting" "hosting_country" + } + infoValue name = eitherToMaybe $ lookupValue "INFORMATION" name ini + iniEntity nameField countryField = + (\name -> Entity {name, country = countryValue countryField}) + <$!> infoValue nameField + countryValue field = + (\cs -> if T.length cs == 2 && T.all (\c -> isAscii c && isAlpha c) cs then T.map toUpper cs else error $ "Use ISO3166 2-letter code for " <> T.unpack field) + <$!> infoValue field + iniContacts simplexField emailField pgpKeyUriField pgpKeyFingerprintField = + let simplex = either error id . parseAll (connReqUriP' Nothing) . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini) + email = infoValue emailField + pkURI_ = infoValue pgpKeyUriField + pkFingerprint_ = infoValue pgpKeyFingerprintField + in case (simplex, email, pkURI_, pkFingerprint_) of + (Nothing, Nothing, Nothing, _) -> Nothing + (Nothing, Nothing, _, Nothing) -> Nothing + (_, _, pkURI, pkFingerprint) -> Just ServerContactAddress {simplex, email, pgp = PGPKey <$> pkURI <*> pkFingerprint} + +printSourceCode :: Maybe Text -> IO () +printSourceCode = \case + Just sourceCode -> T.putStrLn $ "Server source code: " <> sourceCode + Nothing -> do + putStrLn "Warning: server source code is not specified." + putStrLn "Add 'source_code' property to [INFORMATION] section of INI file." data CliCommand = Init InitOptions @@ -229,6 +458,9 @@ data InitOptions = InitOptions ip :: HostName, fqdn :: Maybe HostName, password :: Maybe ServerPassword, + sourceCode :: Maybe Text, + webStaticPath :: Maybe FilePath, + disableWeb :: Bool, scripted :: Bool } deriving (Show) @@ -283,7 +515,6 @@ cliCommandP cfgPath logPath iniFile = ( long "fqdn" <> short 'n' <> help "Server FQDN used as Common Name for TLS online certificate" - <> showDefault <> metavar "FQDN" ) password <- @@ -296,13 +527,41 @@ cliCommandP cfgPath logPath iniFile = <> help "Set password to create new messaging queues" <> value SPRandom ) + sourceCode <- + (optional . strOption) + ( long "source-code" + <> help "Server source code will be communicated to the users" + <> metavar "URI" + ) + webStaticPath <- + (optional . strOption) + ( long "web-path" + <> help "Directory to store generated static site with server information" + <> metavar "PATH" + ) + disableWeb <- + switch + ( long "disable-web" + <> help "Disable starting static web server with server information" + ) scripted <- switch ( long "yes" <> short 'y' <> help "Non-interactive initialization using command-line options" ) - pure InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password, scripted} + pure + InitOptions + { enableStoreLog, + logStats, + signAlgorithm, + ip, + fqdn, + password, + sourceCode, + webStaticPath, + disableWeb, + scripted + } parseBasicAuth :: ReadM ServerPassword parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack - diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 2d735d1d4..c8f78e2fb 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -74,8 +75,8 @@ snapshotMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (snapshotTQueue . mapM_ (writeTQueue q) msgs pure msgs -writeMsg :: MsgQueue -> Message -> STM (Maybe Message) -writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} msg = do +writeMsg :: MsgQueue -> Message -> STM (Maybe (Message, Bool)) +writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = do canWrt <- readTVar canWrite empty <- isEmptyTQueue q if canWrt || empty @@ -84,8 +85,8 @@ writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} msg = do writeTVar canWrite $! canWrt' modifyTVar' size (+ 1) if canWrt' - then writeTQueue q msg $> Just msg - else writeTQueue q msgQuota $> Nothing + then writeTQueue q msg $> Just (msg, empty) + else (writeTQueue q $! msgQuota) $> Nothing else pure Nothing where msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index cd1b94215..8d5bd8fff 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -14,6 +14,7 @@ data QueueRec = QueueRec rcvDhSecret :: !RcvDhSecret, senderId :: !SenderId, senderKey :: !(Maybe SndPublicAuthKey), + sndSecure :: !SenderCanSecure, notifier :: !(Maybe NtfCreds), status :: !ServerQueueStatus } diff --git a/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs b/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs new file mode 100644 index 000000000..b329a54ff --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/QueueInfo.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Messaging.Server.QueueStore.QueueInfo where + +import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Simplex.Messaging.Encoding +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) +import Simplex.Messaging.Util ((<$?>)) + +data QueueInfo = QueueInfo + { qiSnd :: Bool, + qiNtf :: Bool, + qiSub :: Maybe QSub, + qiSize :: Int, + qiMsg :: Maybe MsgInfo + } + deriving (Eq, Show) + +data QSub = QSub + { qSubThread :: QSubThread, + qDelivered :: Maybe Text + } + deriving (Eq, Show) + +data QSubThread = QNoSub | QSubPending | QSubThread | QProhibitSub + deriving (Eq, Show) + +data MsgInfo = MsgInfo + { msgId :: Text, + msgTs :: UTCTime, + msgType :: MsgType + } + deriving (Eq, Show) + +data MsgType = MTMessage | MTQuota + deriving (Eq, Show) + +$(JQ.deriveJSON (enumJSON $ dropPrefix "Q") ''QSubThread) + +$(JQ.deriveJSON defaultJSON ''QSub) + +$(JQ.deriveJSON (enumJSON $ dropPrefix "MT") ''MsgType) + +$(JQ.deriveJSON defaultJSON ''MsgInfo) + +$(JQ.deriveJSON defaultJSON ''QueueInfo) + +instance Encoding QueueInfo where + smpEncode = LB.toStrict . J.encode + smpP = J.eitherDecodeStrict <$?> A.takeByteString diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index b76ad4998..d6cdaf10a 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -54,7 +55,7 @@ addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = where hasId = (||) <$> TM.member rId queues <*> TM.member sId senders -getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec) +getQueue :: DirectParty p => QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec) getQueue QueueStore {queues, senders, notifiers} party qId = toResult <$> (mapM readTVar =<< getVar) where @@ -69,7 +70,7 @@ secureQueue QueueStore {queues} rId sKey = readTVar qVar >>= \q -> case senderKey q of Just k -> pure $ if sKey == k then Just q else Nothing _ -> - let q' = q {senderKey = Just sKey} + let !q' = q {senderKey = Just sKey} in writeTVar qVar q' $> Just q' addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec) diff --git a/src/Simplex/Messaging/Server/Stats.hs b/src/Simplex/Messaging/Server/Stats.hs index 0b4c677c2..f2716c9c3 100644 --- a/src/Simplex/Messaging/Server/Stats.hs +++ b/src/Simplex/Messaging/Server/Stats.hs @@ -26,13 +26,28 @@ data ServerStats = ServerStats qDeletedAll :: TVar Int, qDeletedNew :: TVar Int, qDeletedSecured :: TVar Int, + qSub :: TVar Int, + qSubAuth :: TVar Int, + qSubDuplicate :: TVar Int, + qSubProhibited :: TVar Int, msgSent :: TVar Int, + msgSentAuth :: TVar Int, + msgSentQuota :: TVar Int, + msgSentLarge :: TVar Int, msgRecv :: TVar Int, msgExpired :: TVar Int, activeQueues :: PeriodStats RecipientId, - msgSentNtf :: TVar Int, - msgRecvNtf :: TVar Int, + msgSentNtf :: TVar Int, -- sent messages with NTF flag + msgRecvNtf :: TVar Int, -- received messages with NTF flag activeQueuesNtf :: PeriodStats RecipientId, + msgNtfs :: TVar Int, -- messages notications delivered to NTF server (<= msgSentNtf) + msgNtfNoSub :: TVar Int, -- no subscriber to notifications (e.g., NTF server not connected) + msgNtfLost :: TVar Int, -- notification is lost because NTF delivery queue is full + pRelays :: ProxyStats, + pRelaysOwn :: ProxyStats, + pMsgFwds :: ProxyStats, + pMsgFwdsOwn :: ProxyStats, + pMsgFwdsRecv :: TVar Int, qCount :: TVar Int, msgCount :: TVar Int } @@ -44,13 +59,28 @@ data ServerStatsData = ServerStatsData _qDeletedAll :: Int, _qDeletedNew :: Int, _qDeletedSecured :: Int, + _qSub :: Int, + _qSubAuth :: Int, + _qSubDuplicate :: Int, + _qSubProhibited :: Int, _msgSent :: Int, + _msgSentAuth :: Int, + _msgSentQuota :: Int, + _msgSentLarge :: Int, _msgRecv :: Int, _msgExpired :: Int, _activeQueues :: PeriodStatsData RecipientId, _msgSentNtf :: Int, _msgRecvNtf :: Int, _activeQueuesNtf :: PeriodStatsData RecipientId, + _msgNtfs :: Int, + _msgNtfNoSub :: Int, + _msgNtfLost :: Int, + _pRelays :: ProxyStatsData, + _pRelaysOwn :: ProxyStatsData, + _pMsgFwds :: ProxyStatsData, + _pMsgFwdsOwn :: ProxyStatsData, + _pMsgFwdsRecv :: Int, _qCount :: Int, _msgCount :: Int } @@ -64,16 +94,63 @@ newServerStats ts = do qDeletedAll <- newTVar 0 qDeletedNew <- newTVar 0 qDeletedSecured <- newTVar 0 + qSub <- newTVar 0 + qSubAuth <- newTVar 0 + qSubDuplicate <- newTVar 0 + qSubProhibited <- newTVar 0 msgSent <- newTVar 0 + msgSentAuth <- newTVar 0 + msgSentQuota <- newTVar 0 + msgSentLarge <- newTVar 0 msgRecv <- newTVar 0 msgExpired <- newTVar 0 activeQueues <- newPeriodStats msgSentNtf <- newTVar 0 msgRecvNtf <- newTVar 0 activeQueuesNtf <- newPeriodStats + msgNtfs <- newTVar 0 + msgNtfNoSub <- newTVar 0 + msgNtfLost <- newTVar 0 + pRelays <- newProxyStats + pRelaysOwn <- newProxyStats + pMsgFwds <- newProxyStats + pMsgFwdsOwn <- newProxyStats + pMsgFwdsRecv <- newTVar 0 qCount <- newTVar 0 msgCount <- newTVar 0 - pure ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} + pure + ServerStats + { fromTime, + qCreated, + qSecured, + qDeletedAll, + qDeletedNew, + qDeletedSecured, + qSub, + qSubAuth, + qSubDuplicate, + qSubProhibited, + msgSent, + msgSentAuth, + msgSentQuota, + msgSentLarge, + msgRecv, + msgExpired, + activeQueues, + msgSentNtf, + msgRecvNtf, + activeQueuesNtf, + msgNtfs, + msgNtfNoSub, + msgNtfLost, + pRelays, + pRelaysOwn, + pMsgFwds, + pMsgFwdsOwn, + pMsgFwdsRecv, + qCount, + msgCount + } getServerStatsData :: ServerStats -> STM ServerStatsData getServerStatsData s = do @@ -83,16 +160,63 @@ getServerStatsData s = do _qDeletedAll <- readTVar $ qDeletedAll s _qDeletedNew <- readTVar $ qDeletedNew s _qDeletedSecured <- readTVar $ qDeletedSecured s + _qSub <- readTVar $ qSub s + _qSubAuth <- readTVar $ qSubAuth s + _qSubDuplicate <- readTVar $ qSubDuplicate s + _qSubProhibited <- readTVar $ qSubProhibited s _msgSent <- readTVar $ msgSent s + _msgSentAuth <- readTVar $ msgSentAuth s + _msgSentQuota <- readTVar $ msgSentQuota s + _msgSentLarge <- readTVar $ msgSentLarge s _msgRecv <- readTVar $ msgRecv s _msgExpired <- readTVar $ msgExpired s _activeQueues <- getPeriodStatsData $ activeQueues s _msgSentNtf <- readTVar $ msgSentNtf s _msgRecvNtf <- readTVar $ msgRecvNtf s _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s + _msgNtfs <- readTVar $ msgNtfs s + _msgNtfNoSub <- readTVar $ msgNtfNoSub s + _msgNtfLost <- readTVar $ msgNtfLost s + _pRelays <- getProxyStatsData $ pRelays s + _pRelaysOwn <- getProxyStatsData $ pRelaysOwn s + _pMsgFwds <- getProxyStatsData $ pMsgFwds s + _pMsgFwdsOwn <- getProxyStatsData $ pMsgFwdsOwn s + _pMsgFwdsRecv <- readTVar $ pMsgFwdsRecv s _qCount <- readTVar $ qCount s _msgCount <- readTVar $ msgCount s - pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _qCount, _msgCount} + pure + ServerStatsData + { _fromTime, + _qCreated, + _qSecured, + _qDeletedAll, + _qDeletedNew, + _qDeletedSecured, + _qSub, + _qSubAuth, + _qSubDuplicate, + _qSubProhibited, + _msgSent, + _msgSentAuth, + _msgSentQuota, + _msgSentLarge, + _msgRecv, + _msgExpired, + _activeQueues, + _msgSentNtf, + _msgRecvNtf, + _activeQueuesNtf, + _msgNtfs, + _msgNtfNoSub, + _msgNtfLost, + _pRelays, + _pRelaysOwn, + _pMsgFwds, + _pMsgFwdsOwn, + _pMsgFwdsRecv, + _qCount, + _msgCount + } setServerStats :: ServerStats -> ServerStatsData -> STM () setServerStats s d = do @@ -102,35 +226,69 @@ setServerStats s d = do writeTVar (qDeletedAll s) $! _qDeletedAll d writeTVar (qDeletedNew s) $! _qDeletedNew d writeTVar (qDeletedSecured s) $! _qDeletedSecured d + writeTVar (qSub s) $! _qSub d + writeTVar (qSubAuth s) $! _qSubAuth d + writeTVar (qSubDuplicate s) $! _qSubDuplicate d + writeTVar (qSubProhibited s) $! _qSubProhibited d writeTVar (msgSent s) $! _msgSent d + writeTVar (msgSentAuth s) $! _msgSentAuth d + writeTVar (msgSentQuota s) $! _msgSentQuota d + writeTVar (msgSentLarge s) $! _msgSentLarge d writeTVar (msgRecv s) $! _msgRecv d writeTVar (msgExpired s) $! _msgExpired d setPeriodStats (activeQueues s) (_activeQueues d) writeTVar (msgSentNtf s) $! _msgSentNtf d writeTVar (msgRecvNtf s) $! _msgRecvNtf d setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d) + writeTVar (msgNtfs s) $! _msgNtfs d + writeTVar (msgNtfNoSub s) $! _msgNtfNoSub d + writeTVar (msgNtfLost s) $! _msgNtfLost d + setProxyStats (pRelays s) $! _pRelays d + setProxyStats (pRelaysOwn s) $! _pRelaysOwn d + setProxyStats (pMsgFwds s) $! _pMsgFwds d + setProxyStats (pMsgFwdsOwn s) $! _pMsgFwdsOwn d + writeTVar (pMsgFwdsRecv s) $! _pMsgFwdsRecv d writeTVar (qCount s) $! _qCount d writeTVar (msgCount s) $! _msgCount d instance StrEncoding ServerStatsData where - strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount} = + strEncode d = B.unlines - [ "fromTime=" <> strEncode _fromTime, - "qCreated=" <> strEncode _qCreated, - "qSecured=" <> strEncode _qSecured, - "qDeletedAll=" <> strEncode _qDeletedAll, - "qDeletedNew=" <> strEncode _qDeletedNew, - "qDeletedSecured=" <> strEncode _qDeletedSecured, - "qCount=" <> strEncode _qCount, - "msgSent=" <> strEncode _msgSent, - "msgRecv=" <> strEncode _msgRecv, - "msgExpired=" <> strEncode _msgExpired, - "msgSentNtf=" <> strEncode _msgSentNtf, - "msgRecvNtf=" <> strEncode _msgRecvNtf, + [ "fromTime=" <> strEncode (_fromTime d), + "qCreated=" <> strEncode (_qCreated d), + "qSecured=" <> strEncode (_qSecured d), + "qDeletedAll=" <> strEncode (_qDeletedAll d), + "qDeletedNew=" <> strEncode (_qDeletedNew d), + "qDeletedSecured=" <> strEncode (_qDeletedSecured d), + "qCount=" <> strEncode (_qCount d), + "qSub=" <> strEncode (_qSub d), + "qSubAuth=" <> strEncode (_qSubAuth d), + "qSubDuplicate=" <> strEncode (_qSubDuplicate d), + "qSubProhibited=" <> strEncode (_qSubProhibited d), + "msgSent=" <> strEncode (_msgSent d), + "msgSentAuth=" <> strEncode (_msgSentAuth d), + "msgSentQuota=" <> strEncode (_msgSentQuota d), + "msgSentLarge=" <> strEncode (_msgSentLarge d), + "msgRecv=" <> strEncode (_msgRecv d), + "msgExpired=" <> strEncode (_msgExpired d), + "msgSentNtf=" <> strEncode (_msgSentNtf d), + "msgRecvNtf=" <> strEncode (_msgRecvNtf d), + "msgNtfs=" <> strEncode (_msgNtfs d), + "msgNtfNoSub=" <> strEncode (_msgNtfNoSub d), + "msgNtfLost=" <> strEncode (_msgNtfLost d), "activeQueues:", - strEncode _activeQueues, + strEncode (_activeQueues d), "activeQueuesNtf:", - strEncode _activeQueuesNtf + strEncode (_activeQueuesNtf d), + "pRelays:", + strEncode (_pRelays d), + "pRelaysOwn:", + strEncode (_pRelaysOwn d), + "pMsgFwds:", + strEncode (_pMsgFwds d), + "pMsgFwdsOwn:", + strEncode (_pMsgFwdsOwn d), + "pMsgFwdsRecv=" <> strEncode (_pMsgFwdsRecv d) ] strP = do _fromTime <- "fromTime=" *> strP <* A.endOfLine @@ -139,12 +297,22 @@ instance StrEncoding ServerStatsData where (_qDeletedAll, _qDeletedNew, _qDeletedSecured) <- (,0,0) <$> ("qDeleted=" *> strP <* A.endOfLine) <|> ((,,) <$> ("qDeletedAll=" *> strP <* A.endOfLine) <*> ("qDeletedNew=" *> strP <* A.endOfLine) <*> ("qDeletedSecured=" *> strP <* A.endOfLine)) - _qCount <- "qCount=" *> strP <* A.endOfLine <|> pure 0 + _qCount <- opt "qCount=" + _qSub <- opt "qSub=" + _qSubAuth <- opt "qSubAuth=" + _qSubDuplicate <- opt "qSubDuplicate=" + _qSubProhibited <- opt "qSubProhibited=" _msgSent <- "msgSent=" *> strP <* A.endOfLine + _msgSentAuth <- opt "msgSentAuth=" + _msgSentQuota <- opt "msgSentQuota=" + _msgSentLarge <- opt "msgSentLarge=" _msgRecv <- "msgRecv=" *> strP <* A.endOfLine - _msgExpired <- "msgExpired=" *> strP <* A.endOfLine <|> pure 0 - _msgSentNtf <- "msgSentNtf=" *> strP <* A.endOfLine <|> pure 0 - _msgRecvNtf <- "msgRecvNtf=" *> strP <* A.endOfLine <|> pure 0 + _msgExpired <- opt "msgExpired=" + _msgSentNtf <- opt "msgSentNtf=" + _msgRecvNtf <- opt "msgRecvNtf=" + _msgNtfs <- opt "msgNtfs=" + _msgNtfNoSub <- opt "msgNtfNoSub=" + _msgNtfLost <- opt "msgNtfLost=" _activeQueues <- optional ("activeQueues:" <* A.endOfLine) >>= \case Just _ -> strP <* optional A.endOfLine @@ -157,7 +325,50 @@ instance StrEncoding ServerStatsData where optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case Just _ -> strP <* optional A.endOfLine _ -> pure newPeriodStatsData - pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount = 0} + _pRelays <- proxyStatsP "pRelays:" + _pRelaysOwn <- proxyStatsP "pRelaysOwn:" + _pMsgFwds <- proxyStatsP "pMsgFwds:" + _pMsgFwdsOwn <- proxyStatsP "pMsgFwdsOwn:" + _pMsgFwdsRecv <- opt "pMsgFwdsRecv=" + pure + ServerStatsData + { _fromTime, + _qCreated, + _qSecured, + _qDeletedAll, + _qDeletedNew, + _qDeletedSecured, + _qSub, + _qSubAuth, + _qSubDuplicate, + _qSubProhibited, + _msgSent, + _msgSentAuth, + _msgSentQuota, + _msgSentLarge, + _msgRecv, + _msgExpired, + _msgSentNtf, + _msgRecvNtf, + _msgNtfs, + _msgNtfNoSub, + _msgNtfLost, + _activeQueues, + _activeQueuesNtf, + _pRelays, + _pRelaysOwn, + _pMsgFwds, + _pMsgFwdsOwn, + _pMsgFwdsRecv, + _qCount, + _msgCount = 0 + } + where + opt s = A.string s *> strP <* A.endOfLine <|> pure 0 + proxyStatsP key = + optional (A.string key >> A.endOfLine) >>= \case + Just _ -> strP <* optional A.endOfLine + _ -> pure newProxyStatsData data PeriodStats a = PeriodStats { day :: TVar (Set a), @@ -231,3 +442,78 @@ updatePeriodStats stats pId = do updatePeriod month where updatePeriod pSel = modifyTVar' (pSel stats) (S.insert pId) + +data ProxyStats = ProxyStats + { pRequests :: TVar Int, + pSuccesses :: TVar Int, -- includes destination server error responses that will be forwarded to the client + pErrorsConnect :: TVar Int, + pErrorsCompat :: TVar Int, + pErrorsOther :: TVar Int + } + +newProxyStats :: STM ProxyStats +newProxyStats = do + pRequests <- newTVar 0 + pSuccesses <- newTVar 0 + pErrorsConnect <- newTVar 0 + pErrorsCompat <- newTVar 0 + pErrorsOther <- newTVar 0 + pure ProxyStats {pRequests, pSuccesses, pErrorsConnect, pErrorsCompat, pErrorsOther} + +data ProxyStatsData = ProxyStatsData + { _pRequests :: Int, + _pSuccesses :: Int, + _pErrorsConnect :: Int, + _pErrorsCompat :: Int, + _pErrorsOther :: Int + } + deriving (Show) + +newProxyStatsData :: ProxyStatsData +newProxyStatsData = ProxyStatsData {_pRequests = 0, _pSuccesses = 0, _pErrorsConnect = 0, _pErrorsCompat = 0, _pErrorsOther = 0} + +getProxyStatsData :: ProxyStats -> STM ProxyStatsData +getProxyStatsData s = do + _pRequests <- readTVar $ pRequests s + _pSuccesses <- readTVar $ pSuccesses s + _pErrorsConnect <- readTVar $ pErrorsConnect s + _pErrorsCompat <- readTVar $ pErrorsCompat s + _pErrorsOther <- readTVar $ pErrorsOther s + pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} + +getResetProxyStatsData :: ProxyStats -> STM ProxyStatsData +getResetProxyStatsData s = do + _pRequests <- swapTVar (pRequests s) 0 + _pSuccesses <- swapTVar (pSuccesses s) 0 + _pErrorsConnect <- swapTVar (pErrorsConnect s) 0 + _pErrorsCompat <- swapTVar (pErrorsCompat s) 0 + _pErrorsOther <- swapTVar (pErrorsOther s) 0 + pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} + +setProxyStats :: ProxyStats -> ProxyStatsData -> STM () +setProxyStats s d = do + writeTVar (pRequests s) $! _pRequests d + writeTVar (pSuccesses s) $! _pSuccesses d + writeTVar (pErrorsConnect s) $! _pErrorsConnect d + writeTVar (pErrorsCompat s) $! _pErrorsCompat d + writeTVar (pErrorsOther s) $! _pErrorsOther d + +instance StrEncoding ProxyStatsData where + strEncode ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} = + "requests=" + <> strEncode _pRequests + <> "\nsuccesses=" + <> strEncode _pSuccesses + <> "\nerrorsConnect=" + <> strEncode _pErrorsConnect + <> "\nerrorsCompat=" + <> strEncode _pErrorsCompat + <> "\nerrorsOther=" + <> strEncode _pErrorsOther + strP = do + _pRequests <- "requests=" *> strP <* A.endOfLine + _pSuccesses <- "successes=" *> strP <* A.endOfLine + _pErrorsConnect <- "errorsConnect=" *> strP <* A.endOfLine + _pErrorsCompat <- "errorsCompat=" *> strP <* A.endOfLine + _pErrorsOther <- "errorsOther=" *> strP + pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index b1011c404..d1ce15ed6 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} @@ -53,7 +54,7 @@ data StoreLogRecord | DeleteNotifier QueueId instance StrEncoding QueueRec where - strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier} = + strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier} = B.unwords [ "rid=" <> strEncode recipientId, "rk=" <> strEncode recipientKey, @@ -61,6 +62,7 @@ instance StrEncoding QueueRec where "sid=" <> strEncode senderId, "sk=" <> strEncode senderKey ] + <> if sndSecure then " sndSecure=" <> strEncode sndSecure else "" <> maybe "" notifierStr notifier where notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds @@ -71,8 +73,9 @@ instance StrEncoding QueueRec where rcvDhSecret <- "rdh=" *> strP_ senderId <- "sid=" *> strP_ senderKey <- "sk=" *> strP + sndSecure <- (" sndSecure=" *> strP) <|> pure False notifier <- optional $ " notifier=" *> strP - pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier, status = QueueActive} + pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive} instance StrEncoding StoreLogRecord where strEncode = \case diff --git a/src/Simplex/Messaging/Session.hs b/src/Simplex/Messaging/Session.hs index 7a219e106..3ce5a35c8 100644 --- a/src/Simplex/Messaging/Session.hs +++ b/src/Simplex/Messaging/Session.hs @@ -8,22 +8,25 @@ import Control.Concurrent.STM import Control.Monad import Data.Composition ((.:.)) import Data.Functor (($>)) +import Data.Time (UTCTime) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Util (($>>=)) data SessionVar a = SessionVar { sessionVar :: TMVar a, - sessionVarId :: Int + sessionVarId :: Int, + sessionVarTs :: UTCTime } -getSessVar :: forall k a. Ord k => TVar Int -> k -> TMap k (SessionVar a) -> STM (Either (SessionVar a) (SessionVar a)) -getSessVar sessSeq sessKey vs = maybe (Left <$> newSessionVar) (pure . Right) =<< TM.lookup sessKey vs +getSessVar :: forall k a. Ord k => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> STM (Either (SessionVar a) (SessionVar a)) +getSessVar sessSeq sessKey vs sessionVarTs = maybe (Left <$> newSessionVar) (pure . Right) =<< TM.lookup sessKey vs where newSessionVar :: STM (SessionVar a) newSessionVar = do sessionVar <- newEmptyTMVar sessionVarId <- stateTVar sessSeq $ \next -> (next, next + 1) - let v = SessionVar {sessionVar, sessionVarId} + let v = SessionVar {sessionVar, sessionVarId, sessionVarTs} TM.insert sessKey v vs pure v @@ -36,3 +39,6 @@ removeSessVar' v sessKey vs = TM.lookup sessKey vs >>= \case Just v' | sessionVarId v == sessionVarId v' -> TM.delete sessKey vs $> True _ -> pure False + +tryReadSessVar :: Ord k => k -> TMap k (SessionVar a) -> STM (Maybe a) +tryReadSessVar sessKey vs = TM.lookup sessKey vs $>>= (tryReadTMVar . sessionVar) diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 8dfd15813..d7f81f563 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -33,14 +33,20 @@ module Simplex.Messaging.Transport VersionSMP, VersionRangeSMP, THandleSMP, + supportedSMPHandshakes, supportedClientSMPRelayVRange, supportedServerSMPRelayVRange, + proxiedSMPRelayVRange, + legacyServerSMPRelayVRange, currentClientSMPRelayVersion, + legacyServerSMPRelayVersion, currentServerSMPRelayVersion, batchCmdsSMPVersion, basicAuthSMPVersion, subModeSMPVersion, authCmdsSMPVersion, + sendingProxySMPVersion, + sndAuthKeySMPVersion, simplexMQVersion, smpBlockSize, TransportConfig (..), @@ -71,15 +77,14 @@ module Simplex.Messaging.Transport smpClientHandshake, tPutBlock, tGetBlock, - serializeTransportError, - transportErrorP, sendHandshake, getHandshake, + smpTHParamsSetVersion, ) where -import Control.Applicative (optional, (<|>)) -import Control.Monad (forM) +import Control.Applicative (optional) +import Control.Monad (forM, (<$!>)) import Control.Monad.Except import Control.Monad.Trans.Except (throwE) import qualified Data.Aeson.TH as J @@ -124,7 +129,7 @@ smpBlockSize = 16384 -- 4 - support command batching (7/17/2022) -- 5 - basic auth for SMP servers (11/12/2022) -- 6 - allow creating queues without subscribing (9/10/2023) --- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (2/3/2024) +-- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024) data SMPVersion @@ -149,20 +154,47 @@ subModeSMPVersion = VersionSMP 6 authCmdsSMPVersion :: VersionSMP authCmdsSMPVersion = VersionSMP 7 +sendingProxySMPVersion :: VersionSMP +sendingProxySMPVersion = VersionSMP 8 + +sndAuthKeySMPVersion :: VersionSMP +sndAuthKeySMPVersion = VersionSMP 9 + currentClientSMPRelayVersion :: VersionSMP -currentClientSMPRelayVersion = VersionSMP 6 +currentClientSMPRelayVersion = VersionSMP 9 + +legacyServerSMPRelayVersion :: VersionSMP +legacyServerSMPRelayVersion = VersionSMP 6 currentServerSMPRelayVersion :: VersionSMP -currentServerSMPRelayVersion = VersionSMP 7 +currentServerSMPRelayVersion = VersionSMP 9 + +-- Max SMP protocol version to be used in e2e encrypted +-- connection between client and server, as defined by SMP proxy. +-- SMP proxy sets it to lower than its current version +-- to prevent client version fingerprinting by the +-- destination relays when clients upgrade at different times. +proxiedSMPRelayVersion :: VersionSMP +proxiedSMPRelayVersion = VersionSMP 9 -- minimal supported protocol version is 4 -- TODO remove code that supports sending commands without batching supportedClientSMPRelayVRange :: VersionRangeSMP supportedClientSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentClientSMPRelayVersion +legacyServerSMPRelayVRange :: VersionRangeSMP +legacyServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion legacyServerSMPRelayVersion + supportedServerSMPRelayVRange :: VersionRangeSMP supportedServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion +-- This range initially allows only version 8 - see the comment above. +proxiedSMPRelayVRange :: VersionRangeSMP +proxiedSMPRelayVRange = mkVersionRange sendingProxySMPVersion proxiedSMPRelayVersion + +supportedSMPHandshakes :: [ALPN] +supportedSMPHandshakes = ["smp/1"] + simplexMQVersion :: String simplexMQVersion = showVersion SMQ.version @@ -194,6 +226,9 @@ class Transport c where -- | tls-unique channel binding per RFC5929 tlsUnique :: c -> SessionId + -- | ALPN value negotiated for the session + getSessionALPN :: c -> Maybe ALPN + -- | Close connection closeConnection :: c -> IO () @@ -288,6 +323,7 @@ instance Transport TLS where getServerConnection = getTLS TServer getClientConnection = getTLS TClient getServerCerts = tlsServerCerts + getSessionALPN = tlsALPN tlsUnique = tlsUniq closeConnection tls = closeTLS $ tlsContext tls @@ -322,6 +358,8 @@ type THandleSMP c p = THandle SMPVersion c p data THandleParams v p = THandleParams { sessionId :: SessionId, blockSize :: Int, + -- | server protocol version range + thServerVRange :: VersionRange v, -- | agreed server protocol version thVersion :: Version v, -- | peer public key for command authorization and shared secrets for entity ID encryption @@ -354,6 +392,7 @@ data ServerHandshake = ServerHandshake { smpVersionRange :: VersionRangeSMP, sessionId :: SessionId, -- pub key to agree shared secrets for command authorization and entity ID encryption. + -- todo C.PublicKeyX25519 authPubKey :: Maybe (X.CertificateChain, X.SignedExact X.PubKey) } @@ -405,6 +444,8 @@ authEncryptCmdsP v p = if v >= authCmdsSMPVersion then optional p else pure Noth data TransportError = -- | error parsing transport block TEBadBlock + | -- | incompatible client or server version + TEVersion | -- | message does not fit in transport block TELargeMsg | -- | incorrect session ID @@ -420,31 +461,29 @@ data TransportError data HandshakeError = -- | parsing error PARSE - | -- | incompatible peer version - VERSION | -- | incorrect server identity IDENTITY | -- | v7 authentication failed BAD_AUTH deriving (Eq, Read, Show, Exception) --- | SMP encrypted transport error parser. -transportErrorP :: Parser TransportError -transportErrorP = - "BLOCK" $> TEBadBlock - <|> "LARGE_MSG" $> TELargeMsg - <|> "SESSION" $> TEBadSession - <|> "NO_AUTH" $> TENoServerAuth - <|> "HANDSHAKE " *> (TEHandshake <$> parseRead1) - --- | Serialize SMP encrypted transport error. -serializeTransportError :: TransportError -> ByteString -serializeTransportError = \case - TEBadBlock -> "BLOCK" - TELargeMsg -> "LARGE_MSG" - TEBadSession -> "SESSION" - TENoServerAuth -> "NO_AUTH" - TEHandshake e -> "HANDSHAKE " <> bshow e +instance Encoding TransportError where + smpP = + A.takeTill (== ' ') >>= \case + "BLOCK" -> pure TEBadBlock + "VERSION" -> pure TEVersion + "LARGE_MSG" -> pure TELargeMsg + "SESSION" -> pure TEBadSession + "NO_AUTH" -> pure TENoServerAuth + "HANDSHAKE" -> TEHandshake <$> (A.space *> parseRead1) + _ -> fail "bad TransportError" + smpEncode = \case + TEBadBlock -> "BLOCK" + TEVersion -> "VERSION" + TELargeMsg -> "LARGE_MSG" + TEBadSession -> "SESSION" + TENoServerAuth -> "NO_AUTH" + TEHandshake e -> "HANDSHAKE " <> bshow e -- | Pad and send block to SMP transport. tPutBlock :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ()) @@ -468,14 +507,16 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do let th@THandle {params = THandleParams {sessionId}} = smpTHandle c sk = C.signX509 serverSignKey $ C.publicToX509 k certChain = getServerCerts c - sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange, authPubKey = Just (certChain, sk)} + smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c + sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (certChain, sk)} getHandshake th >>= \case ClientHandshake {smpVersion = v, keyHash, authPubKey = k'} | keyHash /= kh -> throwE $ TEHandshake IDENTITY - | v `isCompatible` smpVRange -> - pure $ smpThHandleServer th v pk k' - | otherwise -> throwE $ TEHandshake VERSION + | otherwise -> + case compatibleVRange' smpVersionRange v of + Just (Compatible vr) -> pure $ smpTHandleServer th v vr pk k' + Nothing -> throwE TEVersion -- | Client SMP transport handshake. -- @@ -486,8 +527,8 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th if sessionId /= sessId then throwE TEBadSession - else case smpVersionRange `compatibleVersion` smpVRange of - Just (Compatible v) -> do + else case smpVersionRange `compatibleVRange` smpVRange of + Just (Compatible vr) -> do ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do case cert of @@ -496,26 +537,37 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do serverKey <- getServerVerifyKey c pubKey <- C.verifyX509 serverKey exact (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey) + let v = maxVersion vr sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_} - pure $ smpThHandleClient th v (snd <$> ks_) ck_ - Nothing -> throwE $ TEHandshake VERSION + pure $ smpTHandleClient th v vr (snd <$> ks_) ck_ + Nothing -> throwE TEVersion -smpThHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer -smpThHandleServer th v pk k_ = - let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$> k_} - in smpThHandle_ th v (Just thAuth) +smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer +smpTHandleServer th v vr pk k_ = + let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_} + in smpTHandle_ th v vr (Just thAuth) -smpThHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleSMP c 'TClient -smpThHandleClient th v pk_ ck_ = - let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = C.dh' k <$> pk_}) <$> ck_ - in smpThHandle_ th v thAuth +smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleSMP c 'TClient +smpTHandleClient th v vr pk_ ck_ = + let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = forceCertChain ck, sessSecret = C.dh' k <$!> pk_}) <$!> ck_ + in smpTHandle_ th v vr thAuth -smpThHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> Maybe (THandleAuth p) -> THandleSMP c p -smpThHandle_ th@THandle {params} v thAuth = +smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> THandleSMP c p +smpTHandle_ th@THandle {params} v vr thAuth = -- TODO drop SMP v6: make thAuth non-optional - let params' = params {thVersion = v, thAuth, implySessId = v >= authCmdsSMPVersion} + let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion} in (th :: THandleSMP c p) {params = params'} +{-# INLINE forceCertChain #-} +forceCertChain :: (X.CertificateChain, X.SignedExact T.PubKey) -> (X.CertificateChain, X.SignedExact T.PubKey) +forceCertChain cert@(X.CertificateChain cc, signedKey) = length (show cc) `seq` show signedKey `seq` cert + +-- This function is only used with v >= 8, so currently it's a simple record update. +-- It may require some parameters update in the future, to be consistent with smpTHandle_. +smpTHParamsSetVersion :: VersionSMP -> THandleParams SMPVersion p -> THandleParams SMPVersion p +smpTHParamsSetVersion v params = params {thVersion = v} +{-# INLINE smpTHParamsSetVersion #-} + sendHandshake :: (Transport c, Encoding smp) => THandle v c p -> smp -> ExceptT TransportError IO () sendHandshake th = ExceptT . tPutBlock th . smpEncode @@ -526,7 +578,17 @@ getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP smpTHandle :: Transport c => c -> THandleSMP c p smpTHandle c = THandle {connection = c, params} where - params = THandleParams {sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = VersionSMP 0, thAuth = Nothing, implySessId = False, batch = True} + v = VersionSMP 0 + params = + THandleParams + { sessionId = tlsUnique c, + blockSize = smpBlockSize, + thServerVRange = versionToRange v, + thVersion = v, + thAuth = Nothing, + implySessId = False, + batch = True + } $(J.deriveJSON (sumTypeJSON id) ''HandshakeError) diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index 08cff1d0d..da2c6c253 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -19,7 +19,7 @@ module Simplex.Messaging.Transport.Client TransportHost (..), TransportHosts (..), TransportHosts_ (..), - validateCertificateChain + validateCertificateChain, ) where @@ -52,9 +52,8 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll, parseString) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.KeepAlive -import Simplex.Messaging.Util (bshow, (<$?>), catchAll, tshow) +import Simplex.Messaging.Util (bshow, catchAll, tshow, (<$?>)) import System.IO.Error -import System.Timeout (timeout) import Text.Read (readMaybe) import UnliftIO.Exception (IOException) import qualified UnliftIO.Exception as E @@ -139,30 +138,26 @@ runTransportClient :: Transport c => TransportClientConfig -> Maybe ByteString - runTransportClient = runTLSTransportClient supportedParameters Nothing runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a -runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpConnectTimeout, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do +runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do serverCert <- newEmptyTMVarIO let hostName = B.unpack $ strEncode host clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert connectTCP = case socksProxy of - Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host + Just proxy -> connectSocksClient proxy proxyUsername (hostAddr host) _ -> connectTCPClient hostName c <- do sock <- connectTCP port mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive" <> tshow e) let tCfg = clientTransportConfig cfg - tcpConnectTimeout `timeout` connectTLS (Just hostName) tCfg clientParams sock >>= \case - Nothing -> do - close sock - logError "connection timed out" - fail "connection timed out" - Just tls -> do - chain <- - atomically (tryTakeTMVar serverCert) >>= \case - Nothing -> do - logError "onServerCertificate didn't fire or failed to get cert chain" - closeTLS tls >> error "onServerCertificate failed" - Just c -> pure c - getClientConnection tCfg chain tls + -- No TLS timeout to avoid failing connections via SOCKS + tls <- connectTLS (Just hostName) tCfg clientParams sock + chain <- + atomically (tryTakeTMVar serverCert) >>= \case + Nothing -> do + logError "onServerCertificate didn't fire or failed to get cert chain" + closeTLS tls >> error "onServerCertificate failed" + Just c -> pure c + getClientConnection tCfg chain tls client c `E.finally` closeConnection c where hostAddr = \case diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs index d701d4114..71757ca6d 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs @@ -14,6 +14,7 @@ import Control.Monad import Data.ByteString.Char8 (ByteString) import Data.Functor (($>)) import Data.Time (UTCTime, getCurrentTime) +import qualified Data.X509 as X import qualified Data.X509.CertificateStore as XS import Network.HPACK (BufferSize) import Network.HTTP2.Client (ClientConfig (..), Request, Response) @@ -29,7 +30,6 @@ import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Util (eitherToMaybe) import UnliftIO.STM import UnliftIO.Timeout -import qualified Data.X509 as X data HTTP2Client = HTTP2Client { action :: Maybe (Async HTTP2Response), diff --git a/src/Simplex/Messaging/Transport/HTTP2/File.hs b/src/Simplex/Messaging/Transport/HTTP2/File.hs index 10238f161..aef98acaa 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/File.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/File.hs @@ -23,7 +23,7 @@ hReceiveFile getBody h size = get $ fromIntegral size if | chSize > sz -> pure (chSize - sz) | chSize > 0 -> B.hPut h ch >> get (sz - chSize) - | otherwise -> pure (-fromIntegral sz) + | otherwise -> pure (-sz) hSendFile :: Handle -> (Builder -> IO ()) -> Word32 -> IO () hSendFile h send = go diff --git a/src/Simplex/Messaging/Transport/HTTP2/Server.hs b/src/Simplex/Messaging/Transport/HTTP2/Server.hs index c75d8fa31..f8ea1bd1d 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Server.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Server.hs @@ -51,7 +51,7 @@ data HTTP2Server = HTTP2Server -- This server is for testing only, it processes all requests in a single queue. getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do - tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile + tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile (alpn transportConfig) started <- newEmptyTMVarIO reqQ <- newTBQueueIO qSize action <- async $ diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index e7360b21b..ffde39991 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -19,7 +19,7 @@ module Simplex.Messaging.Transport.Server loadTLSServerParams, loadFingerprint, smpServerHandshake, - tlsServerCredentials + tlsServerCredentials, ) where @@ -28,18 +28,21 @@ import Control.Logger.Simple import Control.Monad import qualified Crypto.Store.X509 as SX import Data.Default (def) -import Data.List (find) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM -import Data.Maybe (fromJust) +import Data.List (find) +import Data.Maybe (fromJust, fromMaybe) import qualified Data.X509 as X import Data.X509.Validation (Fingerprint (..)) import qualified Data.X509.Validation as XV +import Foreign.C.Error +import GHC.IO.Exception (ioe_errno) import Network.Socket import qualified Network.TLS as T import Simplex.Messaging.Transport import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow) import System.Exit (exitFailure) +import System.IO.Error (tryIOError) import System.Mem.Weak (Weak, deRefWeak) import UnliftIO (timeout) import UnliftIO.Concurrent @@ -113,15 +116,36 @@ runTCPServer started port server = do runTCPServerSocket :: SocketState -> TMVar Bool -> IO Socket -> (Socket -> IO ()) -> IO () runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket server = E.bracket getSocket (closeServer started clients) $ \sock -> - forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do + forever . E.bracketOnError (safeAccept sock) (close . fst) $ \(conn, _peer) -> do cId <- atomically $ stateTVar accepted $ \cId -> let cId' = cId + 1 in cId `seq` (cId', cId') let closeConn _ = do atomically $ modifyTVar' clients $ IM.delete cId gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier - atomically $ modifyTVar' gracefullyClosed (+1) + atomically $ modifyTVar' gracefullyClosed (+ 1) tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn atomically $ modifyTVar' clients $ IM.insert cId tId +-- | Recover from errors in `accept` whenever it is safe. +-- Some errors are safe to ignore, while blindly restaring `accept` may trigger a busy loop. +-- +-- man accept says: +-- @ +-- For reliable operation the application should detect the network errors defined for the protocol after accept() and treat them like EAGAIN by retrying. +-- In the case of TCP/IP, these are ENETDOWN, EPROTO, ENOPROTOOPT, EHOSTDOWN, ENONET, EHOSTUNREACH, EOPNOTSUPP, and ENETUNREACH. +-- @ +safeAccept :: Socket -> IO (Socket, SockAddr) +safeAccept sock = + tryIOError (accept sock) >>= \case + Right r -> pure r + Left e + | retryAccept -> logWarn err >> safeAccept sock + | otherwise -> logError err >> E.throwIO e + where + retryAccept = maybe False ((`elem` again) . Errno) errno + again = [eAGAIN, eNETDOWN, ePROTO, eNOPROTOOPT, eHOSTDOWN, eNONET, eHOSTUNREACH, eOPNOTSUPP, eNETUNREACH] + err = "socket accept error: " <> tshow e <> maybe "" ((", errno=" <>) . tshow) errno + errno = ioe_errno e + type SocketState = (TVar Int, TVar Int, TVar (IntMap (Weak ThreadId))) newSocketState :: STM SocketState @@ -152,12 +176,13 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted pure sock setStarted sock = atomically (tryPutTMVar started True) >> pure sock -loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams +loadTLSServerParams :: FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams loadTLSServerParams = loadSupportedTLSServerParams supportedParameters -loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> IO T.ServerParams -loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile = - fromCredential <$> loadServerCredential +loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams +loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile alpn_ = do + tlsServerParams <- fromCredential <$> loadServerCredential + pure tlsServerParams {T.serverHooks = maybe def alpnHooks alpn_} where loadServerCredential :: IO T.Credential loadServerCredential = @@ -172,6 +197,7 @@ loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile p T.serverHooks = def, T.serverSupported = serverSupported } + alpnHooks supported = def {T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supported)} loadFingerprint :: FilePath -> IO Fingerprint loadFingerprint certificateFile = do diff --git a/src/Simplex/Messaging/Transport/WebSockets.hs b/src/Simplex/Messaging/Transport/WebSockets.hs index 062f4f0f0..0883fcc28 100644 --- a/src/Simplex/Messaging/Transport/WebSockets.hs +++ b/src/Simplex/Messaging/Transport/WebSockets.hs @@ -14,7 +14,8 @@ import Network.WebSockets import Network.WebSockets.Stream (Stream) import qualified Network.WebSockets.Stream as S import Simplex.Messaging.Transport - ( TProxy, + ( ALPN, + TProxy, Transport (..), TransportConfig (..), TransportError (..), @@ -28,6 +29,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR) data WS = WS { wsPeer :: TransportPeer, tlsUniq :: ByteString, + wsALPN :: Maybe ALPN, wsStream :: Stream, wsConnection :: Connection, wsTransportConfig :: TransportConfig, @@ -61,6 +63,9 @@ instance Transport WS where getServerCerts :: WS -> X.CertificateChain getServerCerts = wsServerCerts + getSessionALPN :: WS -> Maybe ALPN + getSessionALPN = wsALPN + tlsUnique :: WS -> ByteString tlsUnique = tlsUniq @@ -90,7 +95,8 @@ getWS wsPeer cfg wsServerCerts cxt = withTlsUnique wsPeer cxt connectWS connectWS tlsUniq = do s <- makeTLSContextStream cxt wsConnection <- connectPeer wsPeer s - pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts} + wsALPN <- T.getNegotiatedProtocol cxt + pure $ WS {wsPeer, tlsUniq, wsALPN, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts} connectPeer :: TransportPeer -> Stream -> IO Connection connectPeer TServer = acceptClientRequest connectPeer TClient = sendClientRequest diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index a880cfaad..b023f460a 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -7,16 +7,20 @@ import qualified Control.Exception as E import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift +import Control.Monad.Trans.Except +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as J import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) import Data.List (groupBy, sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Time (NominalDiffTime) import GHC.Conc (labelThread, myThreadId, threadDelay) import UnliftIO @@ -97,15 +101,15 @@ catchAll_ :: IO a -> IO a -> IO a catchAll_ a = catchAll a . const {-# INLINE catchAll_ #-} -tryAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m (Either e a) -tryAllErrors err action = tryError action `UE.catch` (pure . Left . err) +tryAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m (Either e a) +tryAllErrors err action = ExceptT $ Right <$> runExceptT action `UE.catch` (pure . Left . err) {-# INLINE tryAllErrors #-} tryAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> m (Either e a) tryAllErrors' err action = runExceptT action `UE.catch` (pure . Left . err) {-# INLINE tryAllErrors' #-} -catchAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> (e -> m a) -> m a +catchAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a catchAllErrors err action handler = tryAllErrors err action >>= either handler pure {-# INLINE catchAllErrors #-} @@ -113,12 +117,12 @@ catchAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> catchAllErrors' err action handler = tryAllErrors' err action >>= either handler pure {-# INLINE catchAllErrors' #-} -catchThrow :: (MonadUnliftIO m, MonadError e m) => m a -> (E.SomeException -> e) -> m a -catchThrow action err = catchAllErrors err action throwError +catchThrow :: MonadUnliftIO m => ExceptT e m a -> (E.SomeException -> e) -> ExceptT e m a +catchThrow action err = catchAllErrors err action throwE {-# INLINE catchThrow #-} -allFinally :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m b -> m a -allFinally err action final = tryAllErrors err action >>= \r -> final >> either throwError pure r +allFinally :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m b -> ExceptT e m a +allFinally err action final = tryAllErrors err action >>= \r -> final >> either throwE pure r {-# INLINE allFinally #-} eitherToMaybe :: Either a b -> Maybe b @@ -149,15 +153,17 @@ safeDecodeUtf8 = decodeUtf8With onError onError _ _ = Just '?' timeoutThrow :: MonadUnliftIO m => e -> Int -> ExceptT e m a -> ExceptT e m a -timeoutThrow e ms action = ExceptT (sequence <$> (ms `timeout` runExceptT action)) >>= maybe (throwError e) pure +timeoutThrow e ms action = ExceptT (sequence <$> (ms `timeout` runExceptT action)) >>= maybe (throwE e) pure threadDelay' :: Int64 -> IO () -threadDelay' time - | time <= 0 = pure () -threadDelay' time = do - let maxWait = min time $ fromIntegral (maxBound :: Int) - threadDelay $ fromIntegral maxWait - when (maxWait /= time) $ threadDelay' (time - maxWait) +threadDelay' = loop + where + loop time + | time <= 0 = pure () + | otherwise = do + let maxWait = min time $ fromIntegral (maxBound :: Int) + threadDelay $ fromIntegral maxWait + loop $ time - maxWait diffToMicroseconds :: NominalDiffTime -> Int64 diffToMicroseconds diff = fromIntegral ((truncate $ diff * 1000000) :: Integer) @@ -167,3 +173,9 @@ diffToMilliseconds diff = fromIntegral ((truncate $ diff * 1000) :: Integer) labelMyThread :: MonadIO m => String -> m () labelMyThread label = liftIO $ myThreadId >>= (`labelThread` label) + +encodeJSON :: ToJSON a => a -> Text +encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode + +decodeJSON :: FromJSON a => Text -> Maybe a +decodeJSON = J.decode . LB.fromStrict . encodeUtf8 diff --git a/src/Simplex/Messaging/Version.hs b/src/Simplex/Messaging/Version.hs index 25f7368d1..5576cfa9f 100644 --- a/src/Simplex/Messaging/Version.hs +++ b/src/Simplex/Messaging/Version.hs @@ -23,6 +23,8 @@ module Simplex.Messaging.Version isCompatibleRange, proveCompatible, compatibleVersion, + compatibleVRange, + compatibleVRange', ) where @@ -98,6 +100,7 @@ class VersionScope v => VersionI v a | a -> v where class VersionScope v => VersionRangeI v a | a -> v where type VersionT v a versionRange :: a -> VersionRange v + toVersionRange :: a -> VersionRange v -> a toVersionT :: a -> Version v -> VersionT v a instance VersionScope v => VersionI v (Version v) where @@ -108,6 +111,7 @@ instance VersionScope v => VersionI v (Version v) where instance VersionScope v => VersionRangeI v (VersionRange v) where type VersionT v (VersionRange v) = Version v versionRange = id + toVersionRange _ vr = vr toVersionT _ v = v newtype Compatible a = Compatible_ a @@ -135,5 +139,24 @@ compatibleVersion x vr = max1 = maxVersion $ versionRange x max2 = maxVersion vr +-- | intersection of version ranges +compatibleVRange :: VersionRangeI v a => a -> VersionRange v -> Maybe (Compatible a) +compatibleVRange x vr = + compatibleVRange_ x (max min1 min2) (min max1 max2) + where + VRange min1 max1 = versionRange x + VRange min2 max2 = vr + +-- | version range capped by compatible version +compatibleVRange' :: VersionRangeI v a => a -> Version v -> Maybe (Compatible a) +compatibleVRange' x v + | v <= max1 = compatibleVRange_ x min1 v + | otherwise = Nothing + where + VRange min1 max1 = versionRange x + +compatibleVRange_ :: VersionRangeI v a => a -> Version v -> Version v -> Maybe (Compatible a) +compatibleVRange_ x v1 v2 = Compatible_ . toVersionRange x <$> safeVersionRange v1 v2 + mkCompatibleIf :: a -> Bool -> Maybe (Compatible a) x `mkCompatibleIf` cond = if cond then Just $ Compatible_ x else Nothing diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index 9ef1f820a..de0cbce3b 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -30,6 +30,7 @@ import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J import Data.ByteString (ByteString) @@ -106,9 +107,9 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct action <- liftIO $ runClient c r hostKeys -- wait for the port to make invitation portNum <- atomically $ readTMVar startedPort - signedInv@RCSignedInvitation {invitation} <- maybe (throwError RCETLSStartFailed) (liftIO . mkInvitation hostKeys address) portNum + signedInv@RCSignedInvitation {invitation} <- maybe (throwE RCETLSStartFailed) (liftIO . mkInvitation hostKeys address) portNum when multicast $ case knownHost of - Nothing -> throwError RCENewController + Nothing -> throwE RCENewController Just KnownHostPairing {hostDhPubKey} -> do ann <- liftIO . async . runExceptT $ announceRC drg 60 idPrivKey hostDhPubKey hostKeys invitation atomically $ putTMVar announcer ann @@ -117,7 +118,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct findCtrlAddress :: ExceptT RCErrorType IO (NonEmpty RCCtrlAddress) findCtrlAddress = do found' <- liftIO $ getLocalAddress rcAddrPrefs_ - maybe (throwError RCENoLocalAddress) pure $ L.nonEmpty found' + maybe (throwE RCENoLocalAddress) pure $ L.nonEmpty found' mkClient :: IO RCHClient_ mkClient = do startedPort <- newEmptyTMVarIO @@ -211,10 +212,10 @@ prepareHostSession 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 + unless (ca == tlsHostFingerprint) $ throwE RCEIdentity (kemCiphertext, kemSharedKey) <- liftIO $ sntrup761Enc drg kemPubKey let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey - unless (isCompatible v supportedRCPVRange) $ throwError RCEVersion + unless (isCompatible v supportedRCPVRange) $ throwE RCEVersion let keys = HostSessKeys {hybridKey, idPrivKey, sessPrivKey} knownHost' <- updateKnownHost ca dhPubKey let ctrlHello = RCCtrlHello {} @@ -227,7 +228,7 @@ prepareHostSession updateKnownHost :: C.KeyHash -> C.PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing updateKnownHost ca hostDhPubKey = case knownHost_ of Just h -> do - unless (hostFingerprint h == tlsHostFingerprint) . throwError $ + unless (hostFingerprint h == tlsHostFingerprint) . throwE $ 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} @@ -257,7 +258,7 @@ connectRCCtrl drg (RCVerifiedInvitation inv@RCInvitation {ca, idkey}) pairing_ h 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 + unless (ca == ctrlFingerprint && idPubKey == idkey) $ throwE RCEIdentity (_, dhPrivKey) <- atomically $ C.generateKeyPair drg pure pairing {dhPrivKey, prevDhPrivKey = Just currDhPrivKey} @@ -278,7 +279,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, clientCredentials <- liftIO (genTLSCredentials drg caKey caCert) >>= \case TLS.Credentials (creds : _) -> pure $ Just creds - _ -> throwError $ RCEInternal "genTLSCredentials must generate credentials" + _ -> throwE $ RCEInternal "genTLSCredentials must generate credentials" let clientConfig = defaultTransportClientConfig {clientCredentials} ExceptT . runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls@TLS {tlsBuffer, tlsContext} -> runExceptT $ do -- pump socket to detect connection problems @@ -303,11 +304,13 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, logDebug "Session ended" catchRCError :: ExceptT RCErrorType IO a -> (RCErrorType -> ExceptT RCErrorType IO a) -> ExceptT RCErrorType IO a -catchRCError = catchAllErrors (RCEException . show) +catchRCError = catchAllErrors $ \e -> case fromException e of + Just (TLS.Terminated _ _ (TLS.Error_Protocol (_, _, TLS.UnknownCa))) -> RCEIdentity + _ -> RCEException $ show e {-# 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 +a `putRCError` r = a `catchRCError` \e -> atomically (tryPutTMVar r $ Left e) >> throwE e sendRCPacket :: Encoding a => TLS -> a -> ExceptT RCErrorType IO () sendRCPacket tls pkt = do @@ -317,7 +320,7 @@ sendRCPacket tls pkt = do receiveRCPacket :: Encoding a => TLS -> ExceptT RCErrorType IO a receiveRCPacket tls = do b <- liftIO $ cGet tls xrcpBlockSize - when (B.length b /= xrcpBlockSize) $ throwError RCEBlockSize + when (B.length b /= xrcpBlockSize) $ throwE RCEBlockSize b' <- liftEitherWith (const RCEBlockSize) $ C.unPad b liftEitherWith RCESyntax $ smpDecode b' @@ -329,7 +332,7 @@ prepareHostHello hostAppInfo = do logDebug "Preparing session" case compatibleVersion v supportedRCPVRange of - Nothing -> throwError RCEVersion + Nothing -> throwE RCEVersion Just (Compatible v') -> do nonce <- liftIO . atomically $ C.randomCbNonce drg (kemPubKey, kemPrivKey) <- liftIO $ sntrup761Keypair drg @@ -355,7 +358,7 @@ prepareCtrlSession 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 + throwE $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message -- * Multicast discovery @@ -382,7 +385,7 @@ discoverRCCtrl subscribers pairings = r@(_, RCVerifiedInvitation RCInvitation {host}) <- findRCCtrlPairing pairings encInvitation case source of SockAddrInet _ ha | THIPv4 (hostAddressToTuple ha) == host -> pure () - _ -> throwError RCEInvitation + _ -> throwE RCEInvitation pure r where loop :: ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a @@ -392,8 +395,8 @@ findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErro 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 + inv@(RCVerifiedInvitation RCInvitation {dh = invDh}) <- maybe (throwE RCEInvitation) pure $ verifySignedInvitation signedInv + unless (invDh == dhPubKey) $ throwE RCEInvitation pure (pairing, inv) where decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString) @@ -433,7 +436,7 @@ rcEncryptBody drg hybridKey s = do 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 + when (len < 0) $ throwE RCEDecrypt (ok, s) <- liftEitherWith (const RCEDecrypt) $ LC.kcbDecryptTailTag hybridKey nonce len ct - unless ok $ throwError RCEDecrypt + unless ok $ throwE RCEDecrypt pure s diff --git a/src/Simplex/RemoteControl/Invitation.hs b/src/Simplex/RemoteControl/Invitation.hs index 712c41a9d..d606c4ff0 100644 --- a/src/Simplex/RemoteControl/Invitation.hs +++ b/src/Simplex/RemoteControl/Invitation.hs @@ -123,7 +123,7 @@ instance StrEncoding RCSignedInvitation where idsig <- requiredP sigs "idsig" $ parseAll strP pure RCSignedInvitation {invitation, ssig, idsig} -signInvitation :: C.PrivateKey C.Ed25519 -> C.PrivateKey C.Ed25519 -> RCInvitation -> RCSignedInvitation +signInvitation :: C.PrivateKey 'C.Ed25519 -> C.PrivateKey 'C.Ed25519 -> RCInvitation -> RCSignedInvitation signInvitation sKey idKey invitation = RCSignedInvitation {invitation, ssig, idsig} where uri = strEncode invitation diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index b890c2c00..c9e11f296 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -7,38 +7,17 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module AgentTests (agentTests) where import AgentTests.ConnectionRequestTests import AgentTests.DoubleRatchetTests (doubleRatchetTests) -import AgentTests.FunctionalAPITests (functionalAPITests, inAnyOrder, pattern Msg, pattern Msg') +import AgentTests.FunctionalAPITests (functionalAPITests) import AgentTests.MigrationTests (migrationTests) import AgentTests.NotificationTests (notificationTests) import AgentTests.SQLiteTests (storeTests) -import Control.Concurrent -import Control.Monad (forM_, when) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Maybe (fromJust) -import Data.Type.Equality -import GHC.Stack (withFrozenCallStack) -import Network.HTTP.Types (urlEncode) -import SMPAgentClient -import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn) -import Simplex.Messaging.Agent.Protocol hiding (MID, CONF, INFO, REQ) -import qualified Simplex.Messaging.Agent.Protocol as A -import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOn, pattern IKPQOff, pattern PQEncOn, pattern PQSupportOn, pattern PQSupportOff) -import qualified Simplex.Messaging.Crypto.Ratchet as CR -import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (ErrorType (..)) -import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..)) -import Simplex.Messaging.Util (bshow) -import System.Directory (removeFile) -import System.Timeout +import Simplex.Messaging.Transport (ATransport (..)) import Test.Hspec -import Util agentTests :: ATransport -> Spec agentTests (ATransport t) = do @@ -48,596 +27,3 @@ agentTests (ATransport t) = do describe "Notification tests" $ notificationTests (ATransport t) describe "SQLite store" storeTests describe "Migration tests" migrationTests - describe "SMP agent protocol syntax" $ syntaxTests t - describe "Establishing duplex connection (via agent protocol)" $ do - skip "These tests are disabled because the agent does not work correctly with multiple connected TCP clients" $ - describe "one agent" $ do - it "should connect via one server and one agent" $ do - smpAgentTest2_1_1 $ testDuplexConnection t - it "should connect via one server and one agent (random IDs)" $ do - smpAgentTest2_1_1 $ testDuplexConnRandomIds t - it "should connect via one server and 2 agents" $ do - smpAgentTest2_2_1 $ testDuplexConnection t - it "should connect via one server and 2 agents (random IDs)" $ do - smpAgentTest2_2_1 $ testDuplexConnRandomIds t - describe "should connect via 2 servers and 2 agents" $ do - pqMatrix2 t smpAgentTest2_2_2 testDuplexConnection' - describe "should connect via 2 servers and 2 agents (random IDs)" $ do - pqMatrix2 t smpAgentTest2_2_2 testDuplexConnRandomIds' - describe "Establishing connections via `contact connection`" $ do - describe "should connect via contact connection with one server and 3 agents" $ do - pqMatrix3 t smpAgentTest3 testContactConnection - describe "should connect via contact connection with one server and 2 agents (random IDs)" $ do - pqMatrix2NoInv t smpAgentTest2_2_1 testContactConnRandomIds - it "should support rejecting contact request" $ do - smpAgentTest2_2_1 $ testRejectContactRequest t - describe "Connection subscriptions" $ do - it "should connect via one server and one agent" $ do - smpAgentTest3_1_1 $ testSubscription t - it "should send notifications to client when server disconnects" $ do - smpAgentServerTest $ testSubscrNotification t - describe "Message delivery and server reconnection" $ do - describe "should deliver messages after losing server connection and re-connecting" $ - pqMatrix2 t smpAgentTest2_2_2_needs_server testMsgDeliveryServerRestart - it "should connect to the server when server goes up if it initially was down" $ do - smpAgentTestN [] $ testServerConnectionAfterError t - it "should deliver pending messages after agent restarting" $ do - smpAgentTest1_1_1 $ testMsgDeliveryAgentRestart t - it "should concurrently deliver messages to connections without blocking" $ do - smpAgentTest2_2_1 $ testConcurrentMsgDelivery t - it "should deliver messages if one of connections has quota exceeded" $ do - smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t - it "should resume delivering messages after exceeding quota once all messages are received" $ do - smpAgentTest2_2_1 $ testResumeDeliveryQuotaExceeded t - -type AEntityTransmission p e = (ACorrId, ConnId, ACommand p e) - -type AEntityTransmissionOrError p e = (ACorrId, ConnId, Either AgentErrorType (ACommand p e)) - -tGetAgent :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn) -tGetAgent = tGetAgent' - -tGetAgent' :: forall c e. (Transport c, AEntityI e) => c -> IO (AEntityTransmissionOrError 'Agent e) -tGetAgent' h = do - (corrId, connId, cmdOrErr) <- pGetAgent h - case cmdOrErr of - Right (APC e cmd) -> case testEquality e (sAEntity @e) of - Just Refl -> pure (corrId, connId, Right cmd) - _ -> error $ "unexpected command " <> show cmd - Left err -> pure (corrId, connId, Left err) - -pGetAgent :: forall c. Transport c => c -> IO (ATransmissionOrError 'Agent) -pGetAgent h = do - (corrId, connId, cmdOrErr) <- tGet SAgent h - case cmdOrErr of - Right (APC _ CONNECT {}) -> pGetAgent h - Right (APC _ DISCONNECT {}) -> pGetAgent h - cmd -> pure (corrId, connId, cmd) - --- | receive message to handle `h` -(<#:) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn) -(<#:) = tGetAgent - -(<#:?) :: Transport c => c -> IO (ATransmissionOrError 'Agent) -(<#:?) = pGetAgent - -(<#:.) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AENone) -(<#:.) = tGetAgent' - --- | send transmission `t` to handle `h` and get response -(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (AEntityTransmissionOrError 'Agent 'AEConn) -h #: t = tPutRaw h t >> (<#:) h - --- | action and expected response --- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r` -(#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> AEntityTransmission 'Agent 'AEConn -> Expectation -action #> (corrId, connId, cmd) = withFrozenCallStack $ action `shouldReturn` (corrId, connId, Right cmd) - --- | action and predicate for the response --- `h #:t =#> p` is the test that sends `t` to `h` and validates the response using `p` -(=#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation -action =#> p = withFrozenCallStack $ action >>= (`shouldSatisfy` p . correctTransmission) - -pattern MID :: AgentMsgId -> ACommand 'Agent 'AEConn -pattern MID msgId = A.MID msgId PQEncOn - -correctTransmission :: (ACorrId, ConnId, Either AgentErrorType cmd) -> (ACorrId, ConnId, cmd) -correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of - Right cmd -> (corrId, connId, cmd) - Left e -> error $ show e - --- | receive message to handle `h` and validate that it is the expected one -(<#) :: (HasCallStack, Transport c) => c -> AEntityTransmission 'Agent 'AEConn -> Expectation -h <# (corrId, connId, cmd) = timeout 5000000 (h <#:) `shouldReturn` Just (corrId, connId, Right cmd) - -(<#.) :: (HasCallStack, Transport c) => c -> AEntityTransmission 'Agent 'AENone -> Expectation -h <#. (corrId, connId, cmd) = timeout 5000000 (h <#:.) `shouldReturn` Just (corrId, connId, Right cmd) - --- | receive message to handle `h` and validate it using predicate `p` -(<#=) :: (HasCallStack, Transport c) => c -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation -h <#= p = timeout 5000000 (h <#:) >>= (`shouldSatisfy` p . correctTransmission . fromJust) - -(<#=?) :: (HasCallStack, Transport c) => c -> (ATransmission 'Agent -> Bool) -> Expectation -h <#=? p = timeout 5000000 (h <#:?) >>= (`shouldSatisfy` p . correctTransmission . fromJust) - --- | test that nothing is delivered to handle `h` during 10ms -(#:#) :: Transport c => c -> String -> Expectation -h #:# err = tryGet `shouldReturn` () - where - tryGet = - 10000 `timeout` tGetAgent h >>= \case - Just _ -> error err - _ -> return () - -type PQMatrix2 c = - HasCallStack => - TProxy c -> - (HasCallStack => (c -> c -> IO ()) -> Expectation) -> - (HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> IO ()) -> - Spec - -pqMatrix2 :: PQMatrix2 c -pqMatrix2 = pqMatrix2_ True - -pqMatrix2NoInv :: PQMatrix2 c -pqMatrix2NoInv = pqMatrix2_ False - -pqMatrix2_ :: Bool -> PQMatrix2 c -pqMatrix2_ pqInv _ smpTest test = do - it "dh/dh handshake" $ smpTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff) - it "dh/pq handshake" $ smpTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn) - it "pq/dh handshake" $ smpTest $ \a b -> test (a, IKPQOn) (b, PQSupportOff) - it "pq/pq handshake" $ smpTest $ \a b -> test (a, IKPQOn) (b, PQSupportOn) - when pqInv $ do - it "pq-inv/dh handshake" $ smpTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff) - it "pq-inv/pq handshake" $ smpTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn) - -pqMatrix3 :: - HasCallStack => - TProxy c -> - (HasCallStack => (c -> c -> c -> IO ()) -> Expectation) -> - (HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()) -> - Spec -pqMatrix3 _ smpTest test = do - it "dh" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff) - it "dh/dh/pq" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOn) - it "dh/pq/dh" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOff) - it "dh/pq/pq" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOn) - it "pq/dh/dh" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOff) - it "pq/dh/pq" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOn) - it "pq/pq/dh" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOff) - it "pq" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn) - -testDuplexConnection :: (HasCallStack, Transport c) => TProxy c -> c -> c -> IO () -testDuplexConnection _ alice bob = testDuplexConnection' (alice, IKPQOn) (bob, PQSupportOn) - -testDuplexConnection' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO () -testDuplexConnection' (alice, aPQ) (bob, bPQ) = do - let pq = pqConnectionMode aPQ bPQ - ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe") - let cReq' = strEncode cReq - bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK) - ("", "bob", Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:) - pqSup' `shouldBe` CR.connPQEncryption aPQ - alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK) - bob <# ("", "alice", A.INFO bPQ "alice's connInfo") - bob <# ("", "alice", CON pq) - alice <# ("", "bob", CON pq) - -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4 - alice #: ("3", "bob", "SEND F :hello") #> ("3", "bob", A.MID 4 pq) - alice <# ("", "bob", SENT 4) - bob <#= \case ("", "alice", Msg' 4 pq' "hello") -> pq == pq'; _ -> False - bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK) - alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", A.MID 5 pq) - alice <# ("", "bob", SENT 5) - bob <#= \case ("", "alice", Msg' 5 pq' "how are you?") -> pq == pq'; _ -> False - bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK) - bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", A.MID 6 pq) - bob <# ("", "alice", SENT 6) - alice <#= \case ("", "bob", Msg' 6 pq' "hello too") -> pq == pq'; _ -> False - alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK) - bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", A.MID 7 pq) - bob <# ("", "alice", SENT 7) - alice <#= \case ("", "bob", Msg' 7 pq' "message 1") -> pq == pq'; _ -> False - alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK) - alice #: ("5", "bob", "OFF") #> ("5", "bob", OK) - bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", A.MID 8 pq) - bob <# ("", "alice", MERR 8 (SMP AUTH)) - alice #: ("6", "bob", "DEL") #> ("6", "bob", OK) - alice #:# "nothing else should be delivered to alice" - -testDuplexConnRandomIds :: (HasCallStack, Transport c) => TProxy c -> c -> c -> IO () -testDuplexConnRandomIds _ alice bob = testDuplexConnRandomIds' (alice, IKPQOn) (bob, PQSupportOn) - -testDuplexConnRandomIds' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO () -testDuplexConnRandomIds' (alice, aPQ) (bob, bPQ) = do - let pq = pqConnectionMode aPQ bPQ - ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe") - let cReq' = strEncode cReq - ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") - ("", bobConn', Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:) - pqSup' `shouldBe` CR.connPQEncryption aPQ - bobConn' `shouldBe` bobConn - alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False - bob <# ("", aliceConn, A.INFO bPQ "alice's connInfo") - bob <# ("", aliceConn, CON pq) - alice <# ("", bobConn, CON pq) - alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, A.MID 4 pq) - alice <# ("", bobConn, SENT 4) - bob <#= \case ("", c, Msg' 4 pq' "hello") -> c == aliceConn && pq == pq'; _ -> False - bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK) - alice #: ("3", bobConn, "SEND F :how are you?") #> ("3", bobConn, A.MID 5 pq) - alice <# ("", bobConn, SENT 5) - bob <#= \case ("", c, Msg' 5 pq' "how are you?") -> c == aliceConn && pq == pq'; _ -> False - bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK) - bob #: ("14", aliceConn, "SEND F 9\nhello too") #> ("14", aliceConn, A.MID 6 pq) - bob <# ("", aliceConn, SENT 6) - alice <#= \case ("", c, Msg' 6 pq' "hello too") -> c == bobConn && pq == pq'; _ -> False - alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK) - bob #: ("15", aliceConn, "SEND F 9\nmessage 1") #> ("15", aliceConn, A.MID 7 pq) - bob <# ("", aliceConn, SENT 7) - alice <#= \case ("", c, Msg' 7 pq' "message 1") -> c == bobConn && pq == pq'; _ -> False - alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK) - alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK) - bob #: ("17", aliceConn, "SEND F 9\nmessage 3") #> ("17", aliceConn, A.MID 8 pq) - bob <# ("", aliceConn, MERR 8 (SMP AUTH)) - alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK) - alice #:# "nothing else should be delivered to alice" - -testContactConnection :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO () -testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do - ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe") - let cReq' = strEncode cReq - abPQ = pqConnectionMode aPQ bPQ - aPQMode = CR.connPQEncryption aPQ - - bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK) - ("", "alice_contact", Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:) - alice #: ("2", "bob", "ACPT " <> aInvId <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("2", "bob", OK) - ("", "alice", Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:) - pqSup'' `shouldBe` bPQ - bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK) - alice <# ("", "bob", A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2") - alice <# ("", "bob", CON abPQ) - bob <# ("", "alice", CON abPQ) - alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", A.MID 4 abPQ) - alice <# ("", "bob", SENT 4) - bob <#= \case ("", "alice", Msg' 4 pq' "hi") -> pq' == abPQ; _ -> False - bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK) - - let atPQ = pqConnectionMode aPQ tPQ - tom #: ("21", "alice", "JOIN T " <> cReq' <> enableKEMStr tPQ <> " subscribe 14\ntom's connInfo") #> ("21", "alice", OK) - ("", "alice_contact", Right (A.REQ aInvId' PQSupportOn _ "tom's connInfo")) <- (alice <#:) - alice #: ("4", "tom", "ACPT " <> aInvId' <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("4", "tom", OK) - ("", "alice", Right (A.CONF tConfId pqSup4 _ "alice's connInfo")) <- (tom <#:) - pqSup4 `shouldBe` tPQ - tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK) - alice <# ("", "tom", A.INFO (CR.connPQEncryption aPQ) "tom's connInfo 2") - alice <# ("", "tom", CON atPQ) - tom <# ("", "alice", CON atPQ) - alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", A.MID 4 atPQ) - alice <# ("", "tom", SENT 4) - tom <#= \case ("", "alice", Msg' 4 pq' "hi there") -> pq' == atPQ; _ -> False - tom #: ("23", "alice", "ACK 4") #> ("23", "alice", OK) - -testContactConnRandomIds :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO () -testContactConnRandomIds (alice, aPQ) (bob, bPQ) = do - let pq = pqConnectionMode aPQ bPQ - ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe") - let cReq' = strEncode cReq - - ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") - ("", aliceContact', Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:) - aliceContact' `shouldBe` aliceContact - - ("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> enableKEMStr (CR.connPQEncryption aPQ) <> " 16\nalice's connInfo") - ("", aliceConn', Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:) - pqSup'' `shouldBe` bPQ - aliceConn' `shouldBe` aliceConn - - bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK) - alice <# ("", bobConn, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2") - alice <# ("", bobConn, CON pq) - bob <# ("", aliceConn, CON pq) - - alice #: ("3", bobConn, "SEND F :hi") #> ("3", bobConn, A.MID 4 pq) - alice <# ("", bobConn, SENT 4) - bob <#= \case ("", c, Msg' 4 pq' "hi") -> c == aliceConn && pq == pq'; _ -> False - bob #: ("13", aliceConn, "ACK 4") #> ("13", aliceConn, OK) - -testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO () -testRejectContactRequest _ alice bob = do - ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON subscribe") - let cReq' = strEncode cReq - bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 10\nbob's info") #> ("11", "alice", OK) - ("", "a_contact", Right (A.REQ aInvId PQSupportOn _ "bob's info")) <- (alice <#:) - -- RJCT must use correct contact connection - alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND) - alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK) - alice #: ("3", "bob", "ACPT " <> aInvId <> " 12\nalice's info") #> ("3", "bob", ERR $ A.CMD PROHIBITED) - bob #:# "nothing should be delivered to bob" - -testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO () -testSubscription _ alice1 alice2 bob = do - (alice1, "alice") `connect` (bob, "bob") - bob #: ("12", "alice", "SEND F 5\nhello") #> ("12", "alice", MID 4) - bob <# ("", "alice", SENT 4) - alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False - alice1 #: ("1", "bob", "ACK 4") #> ("1", "bob", OK) - bob #: ("13", "alice", "SEND F 11\nhello again") #> ("13", "alice", MID 5) - bob <# ("", "alice", SENT 5) - alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False - alice1 #: ("2", "bob", "ACK 5") #> ("2", "bob", OK) - alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK) - alice1 <# ("", "bob", END) - bob #: ("14", "alice", "SEND F 2\nhi") #> ("14", "alice", MID 6) - bob <# ("", "alice", SENT 6) - alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False - alice2 #: ("22", "bob", "ACK 6") #> ("22", "bob", OK) - alice1 #:# "nothing else should be delivered to alice1" - -testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO () -testSubscrNotification t (server, _) client = do - client #: ("1", "conn1", "NEW T INV subscribe") =#> \case ("1", "conn1", INV {}) -> True; _ -> False - client #:# "nothing should be delivered to client before the server is killed" - killThread server - client <#. ("", "", DOWN testSMPServer ["conn1"]) - withSmpServer (ATransport t) $ - client <# ("", "conn1", ERR (SMP AUTH)) -- this new server does not have the queue - -testMsgDeliveryServerRestart :: forall c. Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO () -testMsgDeliveryServerRestart (alice, aPQ) (bob, bPQ) = do - let pq = pqConnectionMode aPQ bPQ - withServer $ do - connect' (alice, "alice", aPQ) (bob, "bob", bPQ) - bob #: ("1", "alice", "SEND F 2\nhi") #> ("1", "alice", A.MID 4 pq) - bob <# ("", "alice", SENT 4) - alice <#= \case ("", "bob", Msg' _ pq' "hi") -> pq == pq'; _ -> False - alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK) - alice #:# "nothing else delivered before the server is killed" - - let server = SMPServer "localhost" testPort2 testKeyHash - alice <#. ("", "", DOWN server ["bob"]) - bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", A.MID 5 pq) - bob #:# "nothing else delivered before the server is restarted" - alice #:# "nothing else delivered before the server is restarted" - - withServer $ do - bob <# ("", "alice", SENT 5) - alice <#. ("", "", UP server ["bob"]) - alice <#= \case ("", "bob", Msg' _ pq' "hello again") -> pq == pq'; _ -> False - alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK) - - removeFile testStoreLogFile - where - withServer test' = withSmpServerStoreLogOn (transport @c) testPort2 (const test') `shouldReturn` () - -testServerConnectionAfterError :: forall c. Transport c => TProxy c -> [c] -> IO () -testServerConnectionAfterError t _ = do - withAgent1 $ \bob -> do - withAgent2 $ \alice -> do - withServer $ do - connect (bob, "bob") (alice, "alice") - bob <#. ("", "", DOWN server ["alice"]) - alice <#. ("", "", DOWN server ["bob"]) - alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4) - alice #:# "nothing else delivered before the server is restarted" - bob #:# "nothing else delivered before the server is restarted" - - withAgent1 $ \bob -> do - withAgent2 $ \alice -> do - bob #: ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT - alice #: ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT - withServer $ do - alice <#=? \case ("", "bob", APC _ (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False - alice <#=? \case ("", "bob", APC _ (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False - bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False - bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False - bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK) - alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5) - alice <# ("", "bob", SENT 5) - bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False - - removeFile testStoreLogFile - removeFile testDB - removeFile testDB2 - where - server = SMPServer "localhost" testPort2 testKeyHash - withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` () - withAgent1 = withAgent agentTestPort testDB 0 - withAgent2 = withAgent agentTestPort2 testDB2 10 - withAgent :: String -> FilePath -> Int -> (c -> IO a) -> IO a - withAgent agentPort agentDB initClientId = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) initClientId (pure ()) . const . testSMPAgentClientOn agentPort - -testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO () -testMsgDeliveryAgentRestart t bob = do - let server = SMPServer "localhost" testPort2 testKeyHash - withAgent $ \alice -> do - withServer $ do - connect (bob, "bob") (alice, "alice") - alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4) - alice <# ("", "bob", SENT 4) - bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False - bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK) - bob #:# "nothing else delivered before the server is down" - - bob <#. ("", "", DOWN server ["alice"]) - alice #: ("2", "bob", "SEND F 11\nhello again") #> ("2", "bob", MID 5) - alice #:# "nothing else delivered before the server is restarted" - bob #:# "nothing else delivered before the server is restarted" - - withAgent $ \alice -> do - withServer $ do - tPutRaw alice ("3", "bob", "SUB") - alice <#= \case - (corrId, "bob", cmd) -> - (corrId == "3" && cmd == OK) - || (corrId == "" && cmd == SENT 5) - _ -> False - bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False - bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False - bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK) - - removeFile testStoreLogFile - removeFile testDB - where - withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` () - withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) 0 (pure ()) . const . testSMPAgentClientOn agentTestPort - -testConcurrentMsgDelivery :: Transport c => TProxy c -> c -> c -> IO () -testConcurrentMsgDelivery _ alice bob = do - connect (alice, "alice") (bob, "bob") - - ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW T INV subscribe") - let cReq' = strEncode cReq - bob #: ("11", "alice2", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") #> ("11", "alice2", OK) - ("", "bob2", Right (A.CONF _confId PQSupportOff _ "bob's connInfo")) <- (alice <#:) - -- below commands would be needed to accept bob's connection, but alice does not - -- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK) - -- bob <# ("", "alice", INFO "alice's connInfo") - -- bob <# ("", "alice", CON) - -- alice <# ("", "bob", CON) - - -- the first connection should not be blocked by the second one - sendMessage (alice, "alice") (bob, "bob") "hello" - -- alice #: ("2", "bob", "SEND F :hello") #> ("2", "bob", MID 1) - -- alice <# ("", "bob", SENT 1) - -- bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False - -- bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK) - bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 5) - bob <# ("", "alice", SENT 5) - -- if delivery is blocked it won't go further - alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False - alice #: ("3", "bob", "ACK 5") #> ("3", "bob", OK) - -testMsgDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO () -testMsgDeliveryQuotaExceeded _ alice bob = do - connect (alice, "alice") (bob, "bob") - connect (alice, "alice2") (bob, "bob2") - forM_ [1 .. 4 :: Int] $ \i -> do - let corrId = bshow i - msg = "message " <> bshow i - (_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND F :" <> msg) - alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False - (_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND F :over quota") - - alice #: ("1", "bob2", "SEND F :hello") #> ("1", "bob2", MID 4) - -- if delivery is blocked it won't go further - alice <# ("", "bob2", SENT 4) - -testResumeDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO () -testResumeDeliveryQuotaExceeded _ alice bob = do - connect (alice, "alice") (bob, "bob") - forM_ [1 .. 4 :: Int] $ \i -> do - let corrId = bshow i - msg = "message " <> bshow i - (_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND F :" <> msg) - alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False - ("5", "bob", Right (MID 8)) <- alice #: ("5", "bob", "SEND F :over quota") - alice #:# "the last message not sent yet" - bob <#= \case ("", "alice", Msg "message 1") -> True; _ -> False - bob #: ("1", "alice", "ACK 4") #> ("1", "alice", OK) - alice #:# "the last message not sent" - bob <#= \case ("", "alice", Msg "message 2") -> True; _ -> False - bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK) - alice #:# "the last message not sent" - bob <#= \case ("", "alice", Msg "message 3") -> True; _ -> False - bob #: ("3", "alice", "ACK 6") #> ("3", "alice", OK) - alice #:# "the last message not sent" - bob <#= \case ("", "alice", Msg "message 4") -> True; _ -> False - bob #: ("4", "alice", "ACK 7") #> ("4", "alice", OK) - inAnyOrder - (tGetAgent alice) - [ \case ("", c, Right (SENT 8)) -> c == "bob"; _ -> False, - \case ("", c, Right QCONT) -> c == "bob"; _ -> False - ] - bob <#= \case ("", "alice", Msg "over quota") -> True; _ -> False - -- message 8 is skipped because of alice agent sending "QCONT" message - bob #: ("5", "alice", "ACK 9") #> ("5", "alice", OK) - -connect :: Transport c => (c, ByteString) -> (c, ByteString) -> IO () -connect (h1, name1) (h2, name2) = connect' (h1, name1, IKPQOn) (h2, name2, PQSupportOn) - -connect' :: forall c. Transport c => (c, ByteString, InitialKeys) -> (c, ByteString, PQSupport) -> IO () -connect' (h1, name1, pqMode1) (h2, name2, pqMode2) = do - ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV" <> pqConnModeStr pqMode1 <> " subscribe") - let cReq' = strEncode cReq - pq = pqConnectionMode pqMode1 pqMode2 - h2 #: ("c2", name1, "JOIN T " <> cReq' <> enableKEMStr pqMode2 <> " subscribe 5\ninfo2") #> ("c2", name1, OK) - ("", _, Right (A.CONF connId pqSup' _ "info2")) <- (h1 <#:) - pqSup' `shouldBe` CR.connPQEncryption pqMode1 - h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK) - h2 <# ("", name1, A.INFO pqMode2 "info1") - h2 <# ("", name1, CON pq) - h1 <# ("", name2, CON pq) - -pqConnectionMode :: InitialKeys -> PQSupport -> PQEncryption -pqConnectionMode pqMode1 pqMode2 = PQEncryption $ supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2 - -enableKEMStr :: PQSupport -> ByteString -enableKEMStr PQSupportOn = " " <> strEncode PQSupportOn -enableKEMStr _ = "" - -pqConnModeStr :: InitialKeys -> ByteString -pqConnModeStr (IKNoPQ PQSupportOff) = "" -pqConnModeStr pq = " " <> strEncode pq - -sendMessage :: Transport c => (c, ConnId) -> (c, ConnId) -> ByteString -> IO () -sendMessage (h1, name1) (h2, name2) msg = do - ("m1", name2', Right (MID mId)) <- h1 #: ("m1", name2, "SEND F :" <> msg) - name2' `shouldBe` name2 - h1 <#= \case ("", n, SENT m) -> n == name2 && m == mId; _ -> False - ("", name1', Right (MSG MsgMeta {recipient = (msgId', _)} _ msg')) <- (h2 <#:) - name1' `shouldBe` name1 - msg' `shouldBe` msg - h2 #: ("m2", name1, "ACK " <> bshow msgId') =#> \case ("m2", n, OK) -> n == name1; _ -> False - --- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString) --- connect' h1 h2 = do --- ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW T INV subscribe") --- let cReq' = strEncode cReq --- ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN T " <> cReq' <> " subscribe 5\ninfo2") --- ("", _, Right (REQ connId _ "info2")) <- (h1 <#:) --- h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False --- h2 <# ("", conn1, INFO "info1") --- h2 <# ("", conn1, CON) --- h1 <# ("", conn2, CON) --- pure (conn1, conn2) - -sampleDhKey :: ByteString -sampleDhKey = "MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o=" - -syntaxTests :: forall c. Transport c => TProxy c -> Spec -syntaxTests t = do - it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX") - describe "NEW" $ do - describe "valid" $ do - it "with correct parameter" $ ("211", "", "NEW T INV subscribe") >#>= \case ("211", _, "INV" : _) -> True; _ -> False - describe "invalid" $ do - it "with incorrect parameter" $ ("222", "", "NEW T hi subscribe") >#> ("222", "", "ERR CMD SYNTAX") - - describe "JOIN" $ do - describe "valid" $ do - it "using same server as in invitation" $ - ( "311", - "a", - "JOIN T https://simpex.chat/invitation#/?smp=smp%3A%2F%2F" - <> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=" - <> "%40localhost%3A5001%2F3456-w%3D%3D%23" - <> urlEncode True sampleDhKey - <> "&v=2" - <> "&e2e=v%3D2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> " subscribe " - <> "14\nbob's connInfo" - ) - >#> ("311", "a", "ERR SMP AUTH") - describe "invalid" $ do - it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX") - where - -- simple test for one command with the expected response - (>#>) :: ARawTransmission -> ARawTransmission -> Expectation - command >#> response = withFrozenCallStack $ smpAgentTest t command `shouldReturn` response - - -- simple test for one command with a predicate for the expected response - (>#>=) :: ARawTransmission -> ((ByteString, ByteString, [ByteString]) -> Bool) -> Expectation - command >#>= p = withFrozenCallStack $ smpAgentTest t command >>= (`shouldSatisfy` p . \(cId, connId, cmd) -> (cId, connId, B.words cmd)) diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 20480f84c..8684c787c 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -7,7 +7,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} -module AgentTests.ConnectionRequestTests where +module AgentTests.ConnectionRequestTests + ( connectionRequestTests, + connReqData, + queueAddr, + testE2ERatchetParams12, + ) where import Data.ByteString (ByteString) import Network.HTTP.Types (urlEncode) @@ -15,179 +20,228 @@ import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (ProtocolServer (..), pattern VersionSMPC, supportedSMPClientVRange) +import Simplex.Messaging.Protocol (ProtocolServer (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC) import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import Simplex.Messaging.Version import Test.Hspec -uri :: String -uri = "smp.simplex.im" - srv :: SMPServer -srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251") +srv = SMPServer "smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" "5223" (C.KeyHash "\215m\248\251") + +srv1 :: SMPServer +srv1 = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251") queueAddr :: SMPQueueAddress queueAddr = SMPQueueAddress { smpServer = srv, senderId = "\223\142z\251", - dhPublicKey = testDhKey + dhPublicKey = testDhKey, + sndSecure = False } +queueAddrSK :: SMPQueueAddress +queueAddrSK = queueAddr {sndSecure = True} + +queueAddr1 :: SMPQueueAddress +queueAddr1 = queueAddr {smpServer = srv1} + queueAddrNoPort :: SMPQueueAddress queueAddrNoPort = queueAddr {smpServer = srv {port = ""}} +queueAddrNoPort1 :: SMPQueueAddress +queueAddrNoPort1 = queueAddr {smpServer = srv1 {port = ""}} + +-- current version range includes version 1 and it uses legacy encoding queue :: SMPQueueUri queue = SMPQueueUri supportedSMPClientVRange queueAddr +queueSK :: SMPQueueUri +queueSK = SMPQueueUri supportedSMPClientVRange queueAddrSK + +queueStr :: ByteString +queueStr = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" + +queueStrSK :: ByteString +queueStrSK = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr <> "&k=s" <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" + +queue1 :: SMPQueueUri +queue1 = SMPQueueUri supportedSMPClientVRange queueAddr1 + +queue1Str :: ByteString +queue1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr + queueV1 :: SMPQueueUri queueV1 = SMPQueueUri (mkVersionRange (VersionSMPC 1) (VersionSMPC 1)) queueAddr +queueV1NoPort :: SMPQueueUri +queueV1NoPort = (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort} + +-- version range 2-3 uses new encoding +-- it is fixed/changed in v5.8.2. +queueNew :: SMPQueueUri +queueNew = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr + +queueNewStr :: ByteString +queueNewStr = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr + +queueNewStr' :: ByteString +queueNewStr' = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-3&dh=" <> testDhKeyStr + +queueNewNoPort :: SMPQueueUri +queueNewNoPort = (queueNew :: SMPQueueUri) {queueAddress = queueAddrNoPort} + +queueNew1 :: SMPQueueUri +queueNew1 = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr1 + +queueNew1Str :: ByteString +queueNew1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr + +queueNew1NoPort :: SMPQueueUri +queueNew1NoPort = (queueNew1 :: SMPQueueUri) {queueAddress = queueAddrNoPort1} + testDhKey :: C.PublicKeyX25519 testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o=" testDhKeyStr :: ByteString testDhKeyStr = strEncode testDhKey -testDhKeyStrUri :: ByteString -testDhKeyStrUri = urlEncode True testDhKeyStr - connReqData :: ConnReqUriData connReqData = ConnReqUriData { crScheme = SSSimplex, - crAgentVRange = mkVersionRange (VersionSMPA 2) (VersionSMPA 2), - crSmpQueues = [queueV1], + crAgentVRange = supportedSMPAgentVRange, + crSmpQueues = [queue], crClientData = Nothing } +connReqDataSK :: ConnReqUriData +connReqDataSK = connReqData {crSmpQueues = [queueSK]} + +connReqData1 :: ConnReqUriData +connReqData1 = connReqData {crSmpQueues = [queue1]} + +connReqDataV1 :: ConnReqUriData +connReqDataV1 = connReqData {crAgentVRange = mkVersionRange (VersionSMPA 1) (VersionSMPA 1)} + +connReqDataV2 :: ConnReqUriData +connReqDataV2 = connReqData {crAgentVRange = mkVersionRange (VersionSMPA 2) (VersionSMPA 2)} + +connReqDataNew :: ConnReqUriData +connReqDataNew = connReqData {crSmpQueues = [queueNew]} + +connReqDataNew1 :: ConnReqUriData +connReqDataNew1 = connReqData {crSmpQueues = [queueNew1]} + testDhPubKey :: C.PublicKeyX448 testDhPubKey = "MEIwBQYDK2VvAzkAmKuSYeQ/m0SixPDS8Wq8VBaTS1cW+Lp0n0h4Diu+kUpR+qXx4SDJ32YGEFoGFGSbGPry5Ychr6U=" testE2ERatchetParams :: RcvE2ERatchetParamsUri 'C.X448 testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange (VersionE2E 1) (VersionE2E 1)) testDhPubKey testDhPubKey Nothing +testE2ERatchetParamsStrUri :: ByteString +testE2ERatchetParamsStrUri = "v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" + testE2ERatchetParams12 :: RcvE2ERatchetParamsUri 'C.X448 testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey Nothing connectionRequest :: AConnectionRequestUri -connectionRequest = - ACR SCMInvitation $ - CRInvitationUri connReqData testE2ERatchetParams +connectionRequest = ACR SCMInvitation $ CRInvitationUri connReqData testE2ERatchetParams + +connectionRequestSK :: AConnectionRequestUri +connectionRequestSK = ACR SCMInvitation $ CRInvitationUri connReqDataSK testE2ERatchetParams + +connectionRequestV1 :: AConnectionRequestUri +connectionRequestV1 = ACR SCMInvitation $ CRInvitationUri connReqDataV1 testE2ERatchetParams + +connectionRequest1 :: AConnectionRequestUri +connectionRequest1 = ACR SCMInvitation $ CRInvitationUri connReqData1 testE2ERatchetParams + +connectionRequestNew :: AConnectionRequestUri +connectionRequestNew = ACR SCMInvitation $ CRInvitationUri connReqDataNew testE2ERatchetParams + +connectionRequestNew1 :: AConnectionRequestUri +connectionRequestNew1 = ACR SCMInvitation $ CRInvitationUri connReqDataNew1 testE2ERatchetParams contactAddress :: AConnectionRequestUri contactAddress = ACR SCMContact $ CRContactUri connReqData -connectionRequestCurrentRange :: AConnectionRequestUri -connectionRequestCurrentRange = - ACR SCMInvitation $ - CRInvitationUri - connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]} - testE2ERatchetParams12 +contactAddressV2 :: AConnectionRequestUri +contactAddressV2 = ACR SCMContact $ CRContactUri connReqDataV2 + +contactAddressNew :: AConnectionRequestUri +contactAddressNew = ACR SCMContact $ CRContactUri connReqDataNew + +connectionRequest2queues :: AConnectionRequestUri +connectionRequest2queues = ACR SCMInvitation $ CRInvitationUri connReqData {crSmpQueues = [queue, queue]} testE2ERatchetParams + +connectionRequest2queuesNew :: AConnectionRequestUri +connectionRequest2queuesNew = ACR SCMInvitation $ CRInvitationUri connReqDataNew {crSmpQueues = [queueNew, queueNew]} testE2ERatchetParams + +contactAddress2queues :: AConnectionRequestUri +contactAddress2queues = ACR SCMContact $ CRContactUri connReqData {crSmpQueues = [queue, queue]} + +contactAddress2queuesNew :: AConnectionRequestUri +contactAddress2queuesNew = ACR SCMContact $ CRContactUri connReqDataNew {crSmpQueues = [queueNew, queueNew]} connectionRequestClientDataEmpty :: AConnectionRequestUri -connectionRequestClientDataEmpty = - ACR SCMInvitation $ - CRInvitationUri connReqData {crClientData = Just "{}"} testE2ERatchetParams +connectionRequestClientDataEmpty = ACR SCMInvitation $ CRInvitationUri connReqData {crClientData = Just "{}"} testE2ERatchetParams -connectionRequestClientData :: AConnectionRequestUri -connectionRequestClientData = - ACR SCMInvitation $ - CRInvitationUri connReqData {crClientData = Just "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}"} testE2ERatchetParams +contactAddressClientData :: AConnectionRequestUri +contactAddressClientData = ACR SCMContact $ CRContactUri connReqData {crClientData = Just "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}"} + +url :: ByteString -> ByteString +url = urlEncode True + +(==#) :: (StrEncoding a, HasCallStack) => a -> ByteString -> Expectation +a ==# s = strEncode a `shouldBe` s + +(#==) :: (StrEncoding a, Eq a, Show a, HasCallStack) => a -> ByteString -> Expectation +a #== s = strDecode s `shouldBe` Right a + +(#==#) :: (StrEncoding a, Eq a, Show a, HasCallStack) => a -> ByteString -> Expectation +a #==# s = do + a ==# s + a #== s connectionRequestTests :: Spec connectionRequestTests = describe "connection request parsing / serializing" $ do - it "should serialize SMP queue URIs" $ do - strEncode (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort} - `shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri - strEncode queue {clientVRange = mkVersionRange (VersionSMPC 1) (VersionSMPC 2)} - `shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri - it "should parse SMP queue URIs" $ do - strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-2&dh=" <> testDhKeyStr) - `shouldBe` Right (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort} - strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr) - `shouldBe` Right (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort} - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr) - `shouldBe` Right queueV1 - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-2&extra_param=abc") - `shouldBe` Right queue - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr) - `shouldBe` Right queueV1 - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc") - `shouldBe` Right queueV1 - it "should serialize connection requests" $ do - strEncode connectionRequest - `shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - strEncode connectionRequestCurrentRange - `shouldBe` "simplex:/invitation#/?v=2-5&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - strEncode connectionRequestClientDataEmpty - `shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%7D" - strEncode connectionRequestClientData - `shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D" - it "should parse connection requests" $ do - strDecode - ( "https://simplex.chat/contact#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23" - <> testDhKeyStrUri - <> "&v=1" -- adjusted to v2 - ) - `shouldBe` Right contactAddress - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&v=2" - ) - `shouldBe` Right connectionRequest - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&v=2" - ) - `shouldBe` Right connectionRequest - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1-1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&v=2-2" - ) - `shouldBe` Right connectionRequest - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26extra_param%3Dabc%26dh%3D" - <> testDhKeyStrUri - <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=extra_key%3Dnew%26v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&some_new_param=abc" - <> "&v=2-5" - ) - `shouldBe` Right connectionRequestCurrentRange - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%7D" - <> "&v=2-2" - ) - `shouldBe` Right connectionRequestClientDataEmpty - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D" - <> "&v=2" - ) - `shouldBe` Right connectionRequestClientData + it "should serialize and parse SMP queue URIs" $ do + queue #==# queueStr + queue #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-3&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueSK #==# queueStrSK + queue1 #==# queue1Str + queueNew #==# queueNewStr + queueNew #== queueNewStr' + queueNew1 #==# queueNew1Str + queueNewNoPort #==# ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr) + queueNew1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr) + queueV1 #==# ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1 #== ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#" <> testDhKeyStr) + queueV1 #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1 #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1NoPort #== ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1NoPort #== ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#" <> testDhKeyStr) + it "should serialize and parse connection invitations and contact addresses" $ do + connectionRequest #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest #== ("https://simplex.chat/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestSK #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStrSK <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest1 #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queue1Str <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest2queues #==# ("simplex:/invitation#/?v=2-6&smp=" <> url (queueStr <> ";" <> queueStr) <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestNew #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueNewStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestNew1 #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueNew1Str <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest2queuesNew #==# ("simplex:/invitation#/?v=2-6&smp=" <> url (queueNewStr <> ";" <> queueNewStr) <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestV1 #== ("https://simplex.chat/invitation#/?v=1&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestClientDataEmpty #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri <> "&data=" <> url "{}") + contactAddress #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueStr) + contactAddress #== ("https://simplex.chat/contact#/?v=2-6&smp=" <> url queueStr) + contactAddress2queues #==# ("simplex:/contact#/?v=2-6&smp=" <> url (queueStr <> ";" <> queueStr)) + contactAddressNew #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueNewStr) + contactAddress2queuesNew #==# ("simplex:/contact#/?v=2-6&smp=" <> url (queueNewStr <> ";" <> queueNewStr)) + contactAddressV2 #==# ("simplex:/contact#/?v=2&smp=" <> url queueStr) + contactAddressV2 #== ("https://simplex.chat/contact#/?v=1&smp=" <> url queueStr) -- adjusted to v2 + contactAddressV2 #== ("https://simplex.chat/contact#/?v=1-2&smp=" <> url queueStr) -- adjusted to v2 + contactAddressV2 #== ("https://simplex.chat/contact#/?v=2-2&smp=" <> url queueStr) + contactAddressClientData #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueStr <> "&data=" <> url "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}") diff --git a/tests/AgentTests/EqInstances.hs b/tests/AgentTests/EqInstances.hs index aaaa2de51..a810247fe 100644 --- a/tests/AgentTests/EqInstances.hs +++ b/tests/AgentTests/EqInstances.hs @@ -6,6 +6,7 @@ module AgentTests.EqInstances where import Data.Type.Equality import Simplex.Messaging.Agent.Store +import Simplex.Messaging.Client (ProxiedRelay (..)) instance Eq SomeConn where SomeConn d c == SomeConn d' c' = case testEquality d d' of @@ -23,3 +24,7 @@ deriving instance Eq (StoredSndQueue q) deriving instance Eq (DBQueueId q) deriving instance Eq ClientNtfCreds + +deriving instance Show ProxiedRelay + +deriving instance Eq ProxiedRelay diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 79742efab..3f70ad6ab 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} @@ -12,7 +14,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module AgentTests.FunctionalAPITests ( functionalAPITests, @@ -24,7 +25,7 @@ module AgentTests.FunctionalAPITests withAgentClients2, withAgentClients3, makeConnection, - exchangeGreetingsMsgId, + exchangeGreetings, switchComplete, createConnection, joinConnection, @@ -45,53 +46,57 @@ module AgentTests.FunctionalAPITests pattern REQ, pattern Msg, pattern Msg', - agentCfgV7, + pattern SENT, + agentCfgVPrevPQ, ) where import AgentTests.ConnectionRequestTests (connReqData, queueAddr, testE2ERatchetParams12) -import Control.Concurrent (killThread, threadDelay) +import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Data.Bifunctor (first) +import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Either (isRight) import Data.Int (Int64) -import Data.List (nub) +import Data.List (find, nub) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M -import Data.Maybe (isNothing) +import Data.Maybe (isJust, isNothing) import qualified Data.Set as S +import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) -import Data.Type.Equality +import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Word (Word16) import qualified Database.SQLite.Simple as SQL import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, withSmpServerV7) +import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A -import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) +import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore) -import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ) +import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT) import qualified Simplex.Messaging.Agent.Protocol as A -import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..)) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew)) import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') -import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultSMPClientConfig) +import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) +import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Transport (NTFVersion, authBatchCmdsNTFVersion, pattern VersionNTF) +import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF) import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), supportedSMPClientVRange) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion) -import Simplex.Messaging.Util (diffToMicroseconds) +import Simplex.Messaging.Server.QueueStore.QueueInfo +import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) +import Simplex.Messaging.Util (bshow, diffToMicroseconds) import Simplex.Messaging.Version (VersionRange (..)) import qualified Simplex.Messaging.Version as V import Simplex.Messaging.Version.Internal (Version (..)) @@ -101,12 +106,15 @@ import UnliftIO import Util import XFTPClient (testXFTPServer) -type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e) +type AEntityTransmission e = (ACorrId, ConnId, AEvent e) -- deriving instance Eq (ValidFileDescription p) +shouldRespond :: (HasCallStack, MonadUnliftIO m, Eq a, Show a) => m a -> a -> m () +a `shouldRespond` r = withFrozenCallStack $ withTimeout a (`shouldBe` r) + (##>) :: (HasCallStack, MonadUnliftIO m) => m (AEntityTransmission e) -> AEntityTransmission e -> m () -a ##> t = withTimeout a (`shouldBe` t) +a ##> t = a `shouldRespond` t (=##>) :: (Show a, HasCallStack, MonadUnliftIO m) => m a -> (HasCallStack => a -> Bool) -> m () a =##> p = @@ -134,90 +142,83 @@ nGet c = withFrozenCallStack $ get' @'AENone c get' :: forall e m. (MonadIO m, AEntityI e, HasCallStack) => AgentClient -> m (AEntityTransmission e) get' c = withFrozenCallStack $ do - (corrId, connId, APC e cmd) <- pGet c + (corrId, connId, AEvt e cmd) <- pGet c case testEquality e (sAEntity @e) of Just Refl -> pure (corrId, connId, cmd) _ -> error $ "unexpected command " <> show cmd -pGet :: forall m. MonadIO m => AgentClient -> m (ATransmission 'Agent) -pGet c = do - t@(_, _, APC _ cmd) <- atomically (readTBQueue $ subQ c) +pGet :: forall m. MonadIO m => AgentClient -> m ATransmission +pGet c = pGet' c True + +pGet' :: forall m. MonadIO m => AgentClient -> Bool -> m ATransmission +pGet' c skipWarn = do + t@(_, _, AEvt _ cmd) <- atomically (readTBQueue $ subQ c) case cmd of CONNECT {} -> pGet c DISCONNECT {} -> pGet c + ERR (BROKER _ NETWORK) -> pGet c + MWARN {} | skipWarn -> pGet c + RFWARN {} | skipWarn -> pGet c + SFWARN {} | skipWarn -> pGet c _ -> pure t -pattern CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand 'Agent e +pattern CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> AEvent e pattern CONF conId srvs connInfo <- A.CONF conId PQSupportOn srvs connInfo -pattern INFO :: ConnInfo -> ACommand 'Agent 'AEConn +pattern INFO :: ConnInfo -> AEvent 'AEConn pattern INFO connInfo = A.INFO PQSupportOn connInfo -pattern REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> ACommand 'Agent e +pattern REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> AEvent e pattern REQ invId srvs connInfo <- A.REQ invId PQSupportOn srvs connInfo -pattern CON :: ACommand 'Agent 'AEConn +pattern CON :: AEvent 'AEConn pattern CON = A.CON PQEncOn -pattern Msg :: MsgBody -> ACommand 'Agent e +pattern Msg :: MsgBody -> AEvent e pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk, pqEncryption = PQEncOn} _ msgBody -pattern Msg' :: AgentMsgId -> PQEncryption -> MsgBody -> ACommand 'Agent e +pattern Msg' :: AgentMsgId -> PQEncryption -> MsgBody -> AEvent e pattern Msg' aMsgId pq msgBody <- MSG MsgMeta {integrity = MsgOk, recipient = (aMsgId, _), pqEncryption = pq} _ msgBody -pattern MsgErr :: AgentMsgId -> MsgErrorType -> MsgBody -> ACommand 'Agent 'AEConn +pattern MsgErr :: AgentMsgId -> MsgErrorType -> MsgBody -> AEvent 'AEConn pattern MsgErr msgId err msgBody <- MSG MsgMeta {recipient = (msgId, _), integrity = MsgError err} _ msgBody -pattern MsgErr' :: AgentMsgId -> MsgErrorType -> PQEncryption -> MsgBody -> ACommand 'Agent 'AEConn +pattern MsgErr' :: AgentMsgId -> MsgErrorType -> PQEncryption -> MsgBody -> AEvent 'AEConn pattern MsgErr' msgId err pq msgBody <- MSG MsgMeta {recipient = (msgId, _), integrity = MsgError err, pqEncryption = pq} _ msgBody -pattern Rcvd :: AgentMsgId -> ACommand 'Agent 'AEConn +pattern SENT :: AgentMsgId -> AEvent 'AEConn +pattern SENT msgId = A.SENT msgId Nothing + +pattern Rcvd :: AgentMsgId -> AEvent 'AEConn pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}] smpCfgVPrev :: ProtocolClientConfig SMPVersion -smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg agentCfg} +smpCfgVPrev = (smpCfg agentCfg) {clientALPN = Nothing, serverVRange = prevRange $ serverVRange $ smpCfg agentCfg} -smpCfgV7 :: ProtocolClientConfig SMPVersion -smpCfgV7 = (smpCfg agentCfg) {serverVRange = V.mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} - -ntfCfgV2 :: ProtocolClientConfig NTFVersion -ntfCfgV2 = (smpCfg agentCfg) {serverVRange = V.mkVersionRange (VersionNTF 1) authBatchCmdsNTFVersion} +ntfCfgVPrev :: ProtocolClientConfig NTFVersion +ntfCfgVPrev = (ntfCfg agentCfg) {clientALPN = Nothing, serverVRange = V.mkVersionRange (VersionNTF 1) (VersionNTF 1)} agentCfgVPrev :: AgentConfig -agentCfgVPrev = +agentCfgVPrev = agentCfgVPrevPQ {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg} + +agentCfgVPrevPQ :: AgentConfig +agentCfgVPrevPQ = agentCfg { sndAuthAlg = C.AuthAlg C.SEd25519, smpAgentVRange = prevRange $ smpAgentVRange agentCfg, smpClientVRange = prevRange $ smpClientVRange agentCfg, - e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg, - smpCfg = smpCfgVPrev - } - --- agent config for the next client version -agentCfgV7 :: AgentConfig -agentCfgV7 = - agentCfg - { sndAuthAlg = C.AuthAlg C.SX25519, - smpAgentVRange = V.mkVersionRange duplexHandshakeSMPAgentVersion $ max pqdrSMPAgentVersion currentSMPAgentVersion, - e2eEncryptVRange = V.mkVersionRange CR.kdfX3DHE2EEncryptVersion $ max CR.pqRatchetE2EEncryptVersion CR.currentE2EEncryptVersion, - smpCfg = smpCfgV7, - ntfCfg = ntfCfgV2 + smpCfg = smpCfgVPrev, + ntfCfg = ntfCfgVPrev } agentCfgRatchetVPrev :: AgentConfig agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg} -prevRange :: VersionRange v -> VersionRange v -prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)} - -prevVersion :: Version v -> Version v -prevVersion (Version v) = Version (v - 1) - mkVersionRange :: Word16 -> Word16 -> VersionRange v mkVersionRange v1 v2 = V.mkVersionRange (Version v1) (Version v2) runRight_ :: (Eq e, Show e, HasCallStack) => ExceptT e IO () -> Expectation -runRight_ action = runExceptT action `shouldReturn` Right () +runRight_ action = withFrozenCallStack $ runExceptT action `shouldReturn` Right () runRight :: (Show e, HasCallStack) => ExceptT e IO a -> IO a runRight action = @@ -225,13 +226,13 @@ runRight action = Right x -> pure x Left e -> error $ "Unexpected error: " <> show e -getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission 'Agent -> Bool] -> Expectation +getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission -> Bool] -> Expectation getInAnyOrder c ts = withFrozenCallStack $ inAnyOrder (pGet c) ts -inAnyOrder :: (Show a, MonadIO m, HasCallStack) => m a -> [a -> Bool] -> m () +inAnyOrder :: (Show a, MonadUnliftIO m, HasCallStack) => m a -> [a -> Bool] -> m () inAnyOrder _ [] = pure () inAnyOrder g rs = withFrozenCallStack $ do - r <- g + r <- 5000000 `timeout` g >>= maybe (error "inAnyOrder timeout") pure let rest = filter (not . expected r) rs if length rest < length rs then inAnyOrder g rest @@ -244,7 +245,7 @@ createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe createConnection c userId enableNtfs cMode clientData = A.createConnection c userId enableNtfs cMode clientData (IKNoPQ PQSupportOn) joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE ConnId -joinConnection c userId enableNtfs cReq connInfo = A.joinConnection c userId enableNtfs cReq connInfo PQSupportOn +joinConnection c userId enableNtfs cReq connInfo = A.joinConnection c userId Nothing enableNtfs cReq connInfo PQSupportOn sendMessage :: AgentClient -> ConnId -> SMP.MsgFlags -> MsgBody -> AE AgentMsgId sendMessage c connId msgFlags msgBody = do @@ -262,12 +263,25 @@ functionalAPITests t = do withSmpServer t testAgentClient3 it "should establish connection without PQ encryption and enable it" $ withSmpServer t testEnablePQEncryption + describe "Duplex connection - delivery stress test" $ do + describe "one way (50)" $ testMatrix2Stress t $ runAgentClientStressTestOneWay 50 + xdescribe "one way (1000)" $ testMatrix2Stress t $ runAgentClientStressTestOneWay 1000 + describe "two way concurrently (50)" $ testMatrix2Stress t $ runAgentClientStressTestConc 25 + xdescribe "two way concurrently (1000)" $ testMatrix2Stress t $ runAgentClientStressTestConc 500 + describe "Establishing duplex connection, different PQ settings" $ do + testPQMatrix2 t $ runAgentClientTestPQ True describe "Establishing duplex connection v2, different Ratchet versions" $ testRatchetMatrix2 t runAgentClientTest describe "Establish duplex connection via contact address" $ testMatrix2 t runAgentClientContactTest + describe "Establish duplex connection via contact address, different PQ settings" $ do + testPQMatrix2NoInv t $ runAgentClientContactTestPQ True PQSupportOn describe "Establish duplex connection via contact address v2, different Ratchet versions" $ testRatchetMatrix2 t runAgentClientContactTest + describe "Establish duplex connection via contact address, different PQ settings" $ do + testPQMatrix3 t $ runAgentClientContactTestPQ3 True + it "should support rejecting contact request" $ + withSmpServer t testRejectContactRequest describe "Establishing connection asynchronously" $ do it "should connect with initiating client going offline" $ withSmpServer t testAsyncInitiatingOffline @@ -294,6 +308,10 @@ functionalAPITests t = do testDuplicateMessage t it "should report error via msg integrity on skipped messages" $ testSkippedMessages t + it "should connect to the server when server goes up if it initially was down" $ + testDeliveryAfterSubscriptionError t + it "should deliver messages if one of connections has quota exceeded" $ + testMsgDeliveryQuotaExceeded t describe "message expiration" $ do it "should expire one message" $ testExpireMessage t it "should expire multiple messages" $ testExpireManyMessages t @@ -311,6 +329,8 @@ functionalAPITests t = do it "should synchronize ratchets when clients start synchronization simultaneously" $ testRatchetSyncSimultaneous t describe "Subscription mode OnlyCreate" $ do + it "messages delivered only when polled (v8 - slow handshake)" $ + withSmpServer t testOnlyCreatePullSlowHandshake it "messages delivered only when polled" $ withSmpServer t testOnlyCreatePull describe "Inactive client disconnection" $ do @@ -333,15 +353,20 @@ functionalAPITests t = do skip "faster version of the previous test (200 subscriptions gets very slow with test coverage)" $ it "should subscribe to multiple (6) subscriptions with batching" $ testBatchedSubscriptions 6 3 t + it "should subscribe to multiple connections with pending messages" $ + withSmpServer t $ + testBatchedPendingMessages 10 5 describe "Async agent commands" $ do - it "should connect using async agent commands" $ - withSmpServer t testAsyncCommands + describe "connect using async agent commands" $ + testBasicMatrix2 t testAsyncCommands it "should restore and complete async commands on restart" $ testAsyncCommandsRestore t - it "should accept connection using async command" $ - withSmpServer t testAcceptContactAsync + describe "accept connection using async command" $ + testBasicMatrix2 t testAcceptContactAsync it "should delete connections using async command when server connection fails" $ testDeleteConnectionAsync t + it "join connection when reply queue creation fails (v8 - slow handshake)" $ + testJoinConnectionAsyncReplyErrorV8 t it "join connection when reply queue creation fails" $ testJoinConnectionAsyncReplyError t describe "delete connection waiting for delivery" $ do @@ -384,29 +409,30 @@ functionalAPITests t = do describe "SMP basic auth" $ do let v4 = prevVersion basicAuthSMPVersion forM_ (nub [prevVersion authCmdsSMPVersion, authCmdsSMPVersion, currentServerSMPRelayVersion]) $ \v -> do + let baseId = if v >= sndAuthKeySMPVersion then 1 else 3 describe ("v" <> show v <> ": with server auth") $ do -- allow NEW | server auth, v | clnt1 auth, v | clnt2 auth, v | 2 - success, 1 - JOIN fail, 0 - NEW fail - it "success " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 2 - it "disabled " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 0 - it "NEW fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) `shouldReturn` 0 - it "NEW fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) `shouldReturn` 0 - it "NEW fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v4) (Just "abcd", v) `shouldReturn` 0 - it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) `shouldReturn` 1 - it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) `shouldReturn` 1 - it "JOIN fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v4) `shouldReturn` 1 + it "success " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 2 + it "disabled " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 0 + it "NEW fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) baseId `shouldReturn` 0 + it "NEW fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) baseId `shouldReturn` 0 + it "NEW fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v4) (Just "abcd", v) baseId `shouldReturn` 0 + it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) baseId `shouldReturn` 1 + it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) baseId `shouldReturn` 1 + it "JOIN fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v4) baseId `shouldReturn` 1 describe ("v" <> show v <> ": no server auth") $ do - it "success " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) `shouldReturn` 2 - it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) `shouldReturn` 0 - it "version srv " $ testBasicAuth t True (Nothing, v4) (Nothing, v) (Nothing, v) `shouldReturn` 2 - it "version fst " $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v) `shouldReturn` 2 - it "version snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v4) `shouldReturn` 2 - it "version both" $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v4) `shouldReturn` 2 - it "version all " $ testBasicAuth t True (Nothing, v4) (Nothing, v4) (Nothing, v4) `shouldReturn` 2 - it "auth fst " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) `shouldReturn` 2 - it "auth fst 2 " $ testBasicAuth t True (Nothing, v4) (Just "abcd", v) (Nothing, v) `shouldReturn` 2 - it "auth snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) `shouldReturn` 2 - it "auth both " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 2 - it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 0 + it "success " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) baseId `shouldReturn` 2 + it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) baseId `shouldReturn` 0 + it "version srv " $ testBasicAuth t True (Nothing, v4) (Nothing, v) (Nothing, v) 3 `shouldReturn` 2 + it "version fst " $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v) baseId `shouldReturn` 2 + it "version snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v4) 3 `shouldReturn` 2 + it "version both" $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v4) 3 `shouldReturn` 2 + it "version all " $ testBasicAuth t True (Nothing, v4) (Nothing, v4) (Nothing, v4) 3 `shouldReturn` 2 + it "auth fst " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) baseId `shouldReturn` 2 + it "auth fst 2 " $ testBasicAuth t True (Nothing, v4) (Just "abcd", v) (Nothing, v) 3 `shouldReturn` 2 + it "auth snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) baseId `shouldReturn` 2 + it "auth both " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 2 + it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 0 describe "SMP server test via agent API" $ do it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing let srv1 = testSMPServer2 {keyHash = "1234"} @@ -415,7 +441,7 @@ functionalAPITests t = do describe "server with password" $ do let auth = Just "abcd" srv = ProtoServerWithAuth testSMPServer2 - authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP AUTH) + authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP (B.unpack $ strEncode testSMPServer2) AUTH) it "should pass with correct password" $ testSMPServerConnectionTest t auth (srv auth) `shouldReturn` Nothing it "should fail without password" $ testSMPServerConnectionTest t auth (srv Nothing) `shouldReturn` authErr it "should fail with incorrect password" $ testSMPServerConnectionTest t auth (srv $ Just "wrong") `shouldReturn` authErr @@ -428,10 +454,14 @@ functionalAPITests t = do it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent t describe "user network info" $ do it "should wait for user network" testWaitForUserNetwork - it "should not reset offline interval while offline" testDoNotResetOfflineInterval + it "should not reset online to offline if happens too quickly" testDoNotResetOnlineToOffline + it "should resume multiple threads" testResumeMultipleThreads + describe "SMP queue info" $ do + it "server should respond with queue and subscription information" $ + withSmpServer t testServerQueueInfo -testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> IO Int -testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do +testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> AgentMsgId -> IO Int +testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 baseId = do let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange batchCmdsSMPVersion srvVersion} canCreate1 = canCreateQueue allowNewQueues srv clnt1 canCreate2 = canCreateQueue allowNewQueues srv clnt2 @@ -439,7 +469,7 @@ testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do | canCreate1 && canCreate2 = 2 | canCreate1 = 1 | otherwise = 0 - created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth srvVersion clnt1 clnt2 + created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth srvVersion clnt1 clnt2 baseId created `shouldBe` expected pure created @@ -448,48 +478,108 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) = let v = basicAuthSMPVersion in allowNew && (isNothing srvAuth || (srvVersion >= v && clntVersion >= v && srvAuth == clntAuth)) -testMatrix2 :: ATransport -> (PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2 t runTest = do - it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn - it "v7 to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn - it "current to v7" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn - it "current with v7 server" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn - it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn - it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff - it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff - it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff + it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True + it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True + it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn False + it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False + it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False + it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False -testRatchetMatrix2 :: ATransport -> (PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testMatrix2Stress :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testMatrix2Stress t runTest = do + it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aCfg aCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True + it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True + it "current" $ withSmpServer t $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn False + it "prev" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfgVPrev 3 $ runTest PQSupportOff False + it "prev to current" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfg 3 $ runTest PQSupportOff False + it "current to prev" $ withSmpServer t $ runTestCfg2 aCfg aCfgVPrev 3 $ runTest PQSupportOff False + where + aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} + aProxyCfgV8 = agentProxyCfgV8 {messageRetryInterval = fastMessageRetryInterval} + aCfgVPrev = agentCfgVPrev {messageRetryInterval = fastMessageRetryInterval} + +testBasicMatrix2 :: HasCallStack => ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testBasicMatrix2 t runTest = do + it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest + it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 3 $ runTest + it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfg 3 $ runTest + it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrevPQ 3 $ runTest + +testRatchetMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testRatchetMatrix2 t runTest = do - it "ratchet next" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn - it "ratchet next to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn - it "ratchet current to next" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn - it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn - it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 3 $ runTest PQSupportOff - it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 3 $ runTest PQSupportOff - it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 3 $ runTest PQSupportOff + it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True + it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True + it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn False + it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff False + it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff False + it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff False -testServerMatrix2 :: ATransport -> (InitialAgentServers -> IO ()) -> Spec +testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec testServerMatrix2 t runTest = do it "1 server" $ withSmpServer t $ runTest initAgentServers it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2 +testPQMatrix2 :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +testPQMatrix2 = pqMatrix2_ True + +testPQMatrix2NoInv :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +testPQMatrix2NoInv = pqMatrix2_ False + +pqMatrix2_ :: HasCallStack => Bool -> ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +pqMatrix2_ pqInv t test = do + it "dh/dh handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff) + it "dh/pq handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn) + it "pq/dh handshake" $ runTest $ \a b -> test (a, IKPQOn) (b, PQSupportOff) + it "pq/pq handshake" $ runTest $ \a b -> test (a, IKPQOn) (b, PQSupportOn) + when pqInv $ do + it "pq-inv/dh handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff) + it "pq-inv/pq handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn) + where + runTest = withSmpServerProxy t . runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 + +testPQMatrix3 :: + HasCallStack => + ATransport -> + (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> + Spec +testPQMatrix3 t test = do + it "dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff) + it "dh/dh/pq" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOn) + it "dh/pq/dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOff) + it "dh/pq/pq" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOn) + it "pq/dh/dh" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOff) + it "pq/dh/pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOn) + it "pq/pq/dh" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOff) + it "pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn) + where + runTest test' = + withSmpServerProxy t $ + runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 servers 3 $ \a b baseMsgId -> + withAgent 3 agentProxyCfgV8 servers testDB3 $ \c -> test' a b c baseMsgId + servers = initAgentServersProxy SPMAlways SPFProhibit + runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () -runTestCfg2 aCfg bCfg baseMsgId runTest = - withAgentClientsCfg2 aCfg bCfg $ \a b -> runTest a b baseMsgId +runTestCfg2 aCfg bCfg = runTestCfgServers2 aCfg bCfg initAgentServers {-# INLINE runTestCfg2 #-} -withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO () +runTestCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () +runTestCfgServers2 aCfg bCfg servers baseMsgId runTest = + withAgentClientsCfgServers2 aCfg bCfg servers $ \a b -> runTest a b baseMsgId +{-# INLINE runTestCfgServers2 #-} + +withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a withAgentClientsCfgServers2 aCfg bCfg servers runTest = withAgent 1 aCfg servers testDB $ \a -> withAgent 2 bCfg servers testDB2 $ \b -> runTest a b -withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a withAgentClientsCfg2 aCfg bCfg = withAgentClientsCfgServers2 aCfg bCfg initAgentServers {-# INLINE withAgentClientsCfg2 #-} -withAgentClients2 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClients2 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a withAgentClients2 = withAgentClientsCfg2 agentCfg agentCfg {-# INLINE withAgentClients2 #-} @@ -499,43 +589,116 @@ withAgentClients3 runTest = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> runTest a b c -runAgentClientTest :: HasCallStack => PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO () -runAgentClientTest pqSupport alice@AgentClient {} bob baseId = +runAgentClientTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () +runAgentClientTest pqSupport viaProxy alice bob baseId = + runAgentClientTestPQ viaProxy (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId + +runAgentClientTestPQ :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () +runAgentClientTestPQ viaProxy (alice, aPQ) (bob, bPQ) baseId = runRight_ $ do - (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (IKNoPQ pqSupport) SMSubscribe - aliceId <- A.joinConnection bob 1 True qInfo "bob's connInfo" pqSupport SMSubscribe + (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing aPQ SMSubscribe + aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" bPQ SMSubscribe ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice - liftIO $ pqSup' `shouldBe` pqSupport + liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ allowConnection alice bobId confId "alice's connInfo" - let pqEnc = CR.pqSupportToEnc pqSupport + let pqEnc = PQEncryption $ pqConnectionMode aPQ bPQ get alice ##> ("", bobId, A.CON pqEnc) - get bob ##> ("", aliceId, A.INFO pqSupport "alice's connInfo") + get bob ##> ("", aliceId, A.INFO bPQ "alice's connInfo") get bob ##> ("", aliceId, A.CON pqEnc) -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4 + let proxySrv = if viaProxy then Just testSMPServer else Nothing 1 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT $ baseId + 1) + get alice ##> ("", bobId, A.SENT (baseId + 1) proxySrv) 2 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "how are you?" - get alice ##> ("", bobId, SENT $ baseId + 2) + get alice ##> ("", bobId, A.SENT (baseId + 2) proxySrv) get bob =##> \case ("", c, Msg' _ pq "hello") -> c == aliceId && pq == pqEnc; _ -> False ackMessage bob aliceId (baseId + 1) Nothing get bob =##> \case ("", c, Msg' _ pq "how are you?") -> c == aliceId && pq == pqEnc; _ -> False ackMessage bob aliceId (baseId + 2) Nothing 3 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too" - get bob ##> ("", aliceId, SENT $ baseId + 3) + get bob ##> ("", aliceId, A.SENT (baseId + 3) proxySrv) 4 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 1" - get bob ##> ("", aliceId, SENT $ baseId + 4) + get bob ##> ("", aliceId, A.SENT (baseId + 4) proxySrv) get alice =##> \case ("", c, Msg' _ pq "hello too") -> c == bobId && pq == pqEnc; _ -> False ackMessage alice bobId (baseId + 3) Nothing get alice =##> \case ("", c, Msg' _ pq "message 1") -> c == bobId && pq == pqEnc; _ -> False ackMessage alice bobId (baseId + 4) Nothing suspendConnection alice bobId 5 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 2" - get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH)) + get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 5); _ -> False deleteConnection alice bobId liftIO $ noMessages alice "nothing else should be delivered to alice" where msgId = subtract baseId . fst +pqConnectionMode :: InitialKeys -> PQSupport -> Bool +pqConnectionMode pqMode1 pqMode2 = supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2 + +runAgentClientStressTestOneWay :: HasCallStack => Int64 -> PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () +runAgentClientStressTestOneWay n pqSupport viaProxy alice bob baseId = runRight_ $ do + let pqEnc = PQEncryption $ supportPQ pqSupport + (aliceId, bobId) <- makeConnection_ pqSupport alice bob + let proxySrv = if viaProxy then Just testSMPServer else Nothing + message i = "message " <> bshow i + concurrently_ + ( forM_ ([1 .. n] :: [Int64]) $ \i -> do + mId <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags (message i) + liftIO $ do + mId >= i `shouldBe` True + let getEvent = + get alice >>= \case + ("", c, A.SENT mId' srv) -> c == bobId && mId' >= baseId + i && srv == proxySrv `shouldBe` True + ("", c, QCONT) -> do + c == bobId `shouldBe` True + getEvent + r -> expectationFailure $ "wrong message: " <> show r + getEvent + ) + ( forM_ ([1 .. n] :: [Int64]) $ \i -> do + get bob >>= \case + ("", c, Msg' mId pq msg) -> do + liftIO $ c == aliceId && mId >= baseId + i && pq == pqEnc && msg == message i `shouldBe` True + ackMessage bob aliceId mId Nothing + r -> liftIO $ expectationFailure $ "wrong message: " <> show r + ) + liftIO $ noMessagesIngoreQCONT alice "nothing else should be delivered to alice" + liftIO $ noMessagesIngoreQCONT bob "nothing else should be delivered to bob" + where + msgId = subtract baseId . fst + +runAgentClientStressTestConc :: HasCallStack => Int64 -> PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () +runAgentClientStressTestConc n pqSupport viaProxy alice bob baseId = runRight_ $ do + let pqEnc = PQEncryption $ supportPQ pqSupport + (aliceId, bobId) <- makeConnection_ pqSupport alice bob + let proxySrv = if viaProxy then Just testSMPServer else Nothing + message i = "message " <> bshow i + loop a bId mIdVar i = do + when (i <= n) $ do + mId <- msgId <$> A.sendMessage a bId pqEnc SMP.noMsgFlags (message i) + liftIO $ mId >= i `shouldBe` True + let getEvent = do + get a >>= \case + ("", c, A.SENT _ srv) -> liftIO $ c == bId && srv == proxySrv `shouldBe` True + ("", c, QCONT) -> do + liftIO $ c == bId `shouldBe` True + getEvent + ("", c, Msg' mId pq msg) -> do + -- tests that mId increases + liftIO $ (mId >) <$> atomically (swapTVar mIdVar mId) `shouldReturn` True + liftIO $ c == bId && pq == pqEnc && ("message " `B.isPrefixOf` msg) `shouldBe` True + ackMessage a bId mId Nothing + r -> liftIO $ expectationFailure $ "wrong message: " <> show r + getEvent + amId <- newTVarIO 0 + bmId <- newTVarIO 0 + concurrently_ + (forM_ ([1 .. n * 2] :: [Int64]) $ loop alice bobId amId) + (forM_ ([1 .. n * 2] :: [Int64]) $ loop bob aliceId bmId) + liftIO $ noMessagesIngoreQCONT alice "nothing else should be delivered to alice" + liftIO $ noMessagesIngoreQCONT bob "nothing else should be delivered to bob" + where + msgId = subtract baseId . fst + testEnablePQEncryption :: HasCallStack => IO () testEnablePQEncryption = withAgentClients2 $ \ca cb -> runRight_ $ do @@ -543,51 +706,51 @@ testEnablePQEncryption = (aId, bId) <- makeConnection_ PQSupportOff ca cb let a = (ca, aId) b = (cb, bId) - (a, 4, "msg 1") \#>\ b - (b, 5, "msg 2") \#>\ a + (a, 2, "msg 1") \#>\ b + (b, 3, "msg 2") \#>\ a -- 45 bytes is used by agent message envelope inside double ratchet message envelope let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncAgentMsgLength pqdrSMPAgentVersion pqEnc - 45) g' lrg <- largeMsg g PQSupportOff - (a, 6, lrg) \#>\ b - (b, 7, lrg) \#>\ a + (a, 4, lrg) \#>\ b + (b, 5, lrg) \#>\ a -- switched to smaller envelopes (before reporting PQ encryption enabled) sml <- largeMsg g PQSupportOn -- fail because of message size - Left (A.CMD LARGE) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg - (9, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml - get ca =##> \case ("", connId, SENT 9) -> connId == bId; _ -> False - get cb =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False - ackMessage cb aId 8 Nothing + Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg + (7, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml + get ca =##> \case ("", connId, SENT 7) -> connId == bId; _ -> False + get cb =##> \case ("", connId, MsgErr' 6 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False + ackMessage cb aId 6 Nothing -- -- fail in reply to sync IDss - Left (A.CMD LARGE) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg - (10, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml - get cb =##> \case ("", connId, SENT 10) -> connId == aId; _ -> False - get ca =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False - ackMessage ca bId 10 Nothing - (a, 11, sml) \#>! b + Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg + (8, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml + get cb =##> \case ("", connId, SENT 8) -> connId == aId; _ -> False + get ca =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False + ackMessage ca bId 8 Nothing + (a, 9, sml) \#>! b -- PQ encryption now enabled + (b, 10, sml) !#>! a + (a, 11, sml) !#>! b (b, 12, sml) !#>! a - (a, 13, sml) !#>! b - (b, 14, sml) !#>! a -- disabling PQ encryption - (a, 15, sml) !#>\ b - (b, 16, sml) !#>\ a - (a, 17, sml) \#>\ b - (b, 18, sml) \#>\ a + (a, 13, sml) !#>\ b + (b, 14, sml) !#>\ a + (a, 15, sml) \#>\ b + (b, 16, sml) \#>\ a -- enabling PQ encryption again + (a, 17, sml) \#>! b + (b, 18, sml) \#>! a (a, 19, sml) \#>! b - (b, 20, sml) \#>! a - (a, 21, sml) \#>! b - (b, 22, sml) !#>! a - (a, 23, sml) !#>! b + (b, 20, sml) !#>! a + (a, 21, sml) !#>! b -- disabling PQ encryption again - (b, 24, sml) !#>\ a - (a, 25, sml) !#>\ b - (b, 26, sml) \#>\ a - (a, 27, sml) \#>\ b + (b, 22, sml) !#>\ a + (a, 23, sml) !#>\ b + (b, 24, sml) \#>\ a + (a, 25, sml) \#>\ b -- PQ encryption is now disabled, but support remained enabled, so we still cannot send larger messages - Left (A.CMD LARGE) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456") - Left (A.CMD LARGE) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456") + Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456") + Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456") pure () where (\#>\) = PQEncOff `sndRcv` PQEncOff @@ -609,71 +772,132 @@ testAgentClient3 = (aIdForB, bId) <- makeConnection a b (aIdForC, cId) <- makeConnection a c - 4 <- sendMessage a bId SMP.noMsgFlags "b4" - 4 <- sendMessage a cId SMP.noMsgFlags "c4" - 5 <- sendMessage a bId SMP.noMsgFlags "b5" - 5 <- sendMessage a cId SMP.noMsgFlags "c5" - get a =##> \case ("", connId, SENT 4) -> connId == bId || connId == cId; _ -> False - get a =##> \case ("", connId, SENT 4) -> connId == bId || connId == cId; _ -> False - get a =##> \case ("", connId, SENT 5) -> connId == bId || connId == cId; _ -> False - get a =##> \case ("", connId, SENT 5) -> connId == bId || connId == cId; _ -> False + 2 <- sendMessage a bId SMP.noMsgFlags "b4" + 2 <- sendMessage a cId SMP.noMsgFlags "c4" + 3 <- sendMessage a bId SMP.noMsgFlags "b5" + 3 <- sendMessage a cId SMP.noMsgFlags "c5" + get a =##> \case ("", connId, SENT 2) -> connId == bId || connId == cId; _ -> False + get a =##> \case ("", connId, SENT 2) -> connId == bId || connId == cId; _ -> False + get a =##> \case ("", connId, SENT 3) -> connId == bId || connId == cId; _ -> False + get a =##> \case ("", connId, SENT 3) -> connId == bId || connId == cId; _ -> False get b =##> \case ("", connId, Msg "b4") -> connId == aIdForB; _ -> False - ackMessage b aIdForB 4 Nothing + ackMessage b aIdForB 2 Nothing get b =##> \case ("", connId, Msg "b5") -> connId == aIdForB; _ -> False - ackMessage b aIdForB 5 Nothing + ackMessage b aIdForB 3 Nothing get c =##> \case ("", connId, Msg "c4") -> connId == aIdForC; _ -> False - ackMessage c aIdForC 4 Nothing + ackMessage c aIdForC 2 Nothing get c =##> \case ("", connId, Msg "c5") -> connId == aIdForC; _ -> False - ackMessage c aIdForC 5 Nothing + ackMessage c aIdForC 3 Nothing -runAgentClientContactTest :: HasCallStack => PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO () -runAgentClientContactTest pqSupport alice bob baseId = +runAgentClientContactTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () +runAgentClientContactTest pqSupport viaProxy alice bob baseId = + runAgentClientContactTestPQ viaProxy pqSupport (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId + +runAgentClientContactTestPQ :: HasCallStack => Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () +runAgentClientContactTestPQ viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId = runRight_ $ do - (_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing (IKNoPQ pqSupport) SMSubscribe - aliceId <- A.joinConnection bob 1 True qInfo "bob's connInfo" pqSupport SMSubscribe + (_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe + aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ + aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" bPQ SMSubscribe + liftIO $ aliceId' `shouldBe` aliceId ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice - liftIO $ pqSup' `shouldBe` pqSupport - bobId <- acceptContact alice True invId "alice's connInfo" PQSupportOn SMSubscribe + liftIO $ pqSup' `shouldBe` reqPQSupport + bobId <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob - liftIO $ pqSup'' `shouldBe` pqSupport + liftIO $ pqSup'' `shouldBe` bPQ allowConnection bob aliceId confId "bob's connInfo" - let pqEnc = CR.pqSupportToEnc pqSupport - get alice ##> ("", bobId, A.INFO pqSupport "bob's connInfo") + let pqEnc = PQEncryption $ pqConnectionMode aPQ bPQ + get alice ##> ("", bobId, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo") get alice ##> ("", bobId, A.CON pqEnc) get bob ##> ("", aliceId, A.CON pqEnc) -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4 + let proxySrv = if viaProxy then Just testSMPServer else Nothing 1 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT $ baseId + 1) + get alice ##> ("", bobId, A.SENT (baseId + 1) proxySrv) 2 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "how are you?" - get alice ##> ("", bobId, SENT $ baseId + 2) + get alice ##> ("", bobId, A.SENT (baseId + 2) proxySrv) get bob =##> \case ("", c, Msg' _ pq "hello") -> c == aliceId && pq == pqEnc; _ -> False ackMessage bob aliceId (baseId + 1) Nothing get bob =##> \case ("", c, Msg' _ pq "how are you?") -> c == aliceId && pq == pqEnc; _ -> False ackMessage bob aliceId (baseId + 2) Nothing 3 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too" - get bob ##> ("", aliceId, SENT $ baseId + 3) + get bob ##> ("", aliceId, A.SENT (baseId + 3) proxySrv) 4 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 1" - get bob ##> ("", aliceId, SENT $ baseId + 4) + get bob ##> ("", aliceId, A.SENT (baseId + 4) proxySrv) get alice =##> \case ("", c, Msg' _ pq "hello too") -> c == bobId && pq == pqEnc; _ -> False ackMessage alice bobId (baseId + 3) Nothing get alice =##> \case ("", c, Msg' _ pq "message 1") -> c == bobId && pq == pqEnc; _ -> False ackMessage alice bobId (baseId + 4) Nothing suspendConnection alice bobId 5 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 2" - get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH)) + get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 5); _ -> False deleteConnection alice bobId liftIO $ noMessages alice "nothing else should be delivered to alice" where msgId = subtract baseId . fst +runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () +runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do + (_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe + (bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo + sentMessages abPQEnc alice bobId bob bAliceId + (tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo + sentMessages atPQEnc alice tomId tom tAliceId + where + msgId = subtract baseId . fst + connectViaContact b pq qInfo = do + aId <- A.prepareConnectionToJoin b 1 True qInfo pq + aId' <- A.joinConnection b 1 (Just aId) True qInfo "bob's connInfo" pq SMSubscribe + liftIO $ aId' `shouldBe` aId + ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice + liftIO $ pqSup' `shouldBe` PQSupportOn + bId <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe + ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b + liftIO $ pqSup'' `shouldBe` pq + allowConnection b aId confId "bob's connInfo" + let pqEnc = PQEncryption $ pqConnectionMode aPQ pq + get alice ##> ("", bId, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo") + get alice ##> ("", bId, A.CON pqEnc) + get b ##> ("", aId, A.CON pqEnc) + pure (aId, bId, pqEnc) + sentMessages pqEnc a bId b aId = do + let proxySrv = if viaProxy then Just testSMPServer else Nothing + 1 <- msgId <$> A.sendMessage a bId pqEnc SMP.noMsgFlags "hello" + get a ##> ("", bId, A.SENT (baseId + 1) proxySrv) + get b =##> \case ("", c, Msg' _ pq "hello") -> c == aId && pq == pqEnc; _ -> False + ackMessage b aId (baseId + 1) Nothing + 2 <- msgId <$> A.sendMessage b aId pqEnc SMP.noMsgFlags "hello too" + get b ##> ("", aId, A.SENT (baseId + 2) proxySrv) + get a =##> \case ("", c, Msg' _ pq "hello too") -> c == bId && pq == pqEnc; _ -> False + ackMessage a bId (baseId + 2) Nothing + noMessages :: HasCallStack => AgentClient -> String -> Expectation -noMessages c err = tryGet `shouldReturn` () +noMessages = noMessages_ False + +noMessagesIngoreQCONT :: AgentClient -> String -> Expectation +noMessagesIngoreQCONT = noMessages_ True + +noMessages_ :: Bool -> HasCallStack => AgentClient -> String -> Expectation +noMessages_ ingoreQCONT c err = tryGet `shouldReturn` () where tryGet = 10000 `timeout` get c >>= \case + Just (_, _, QCONT) | ingoreQCONT -> noMessages_ ingoreQCONT c err Just msg -> error $ err <> ": " <> show msg _ -> return () +testRejectContactRequest :: HasCallStack => IO () +testRejectContactRequest = + withAgentClients2 $ \alice bob -> runRight_ $ do + (addrConnId, qInfo) <- A.createConnection alice 1 True SCMContact Nothing IKPQOn SMSubscribe + aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn + aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe + liftIO $ aliceId' `shouldBe` aliceId + ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice + liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND) + rejectContact alice addrConnId invId + liftIO $ noMessages bob "nothing delivered to bob" + testAsyncInitiatingOffline :: HasCallStack => IO () testAsyncInitiatingOffline = withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> runRight_ $ do @@ -756,7 +980,7 @@ testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do testAllowConnectionClientRestart :: HasCallStack => ATransport -> IO () testAllowConnectionClientRestart t = do - let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} + let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2 withSmpServerStoreLogOn t testPort $ \_ -> do @@ -772,11 +996,12 @@ testAllowConnectionClientRestart t = do runRight_ $ do allowConnectionAsync alice "1" bobId confId "alice's connInfo" - get alice =##> \case ("1", _, OK) -> True; _ -> False + get alice ##> ("1", bobId, OK) pure () threadDelay 100000 -- give time to enqueue confirmation (enqueueConfirmation) disposeAgentClient alice + threadDelay 250000 alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB @@ -789,8 +1014,7 @@ testAllowConnectionClientRestart t = do get alice2 ##> ("", bobId, CON) get bob ##> ("", aliceId, INFO "alice's connInfo") get bob ##> ("", aliceId, CON) - - exchangeGreetingsMsgId 4 alice2 bobId bob aliceId + exchangeGreetings alice2 bobId bob aliceId disposeAgentClient alice2 disposeAgentClient bob @@ -801,7 +1025,7 @@ testIncreaseConnAgentVersion t = do withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob - exchangeGreetingsMsgId_ PQEncOff 4 alice bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId checkVersion alice bobId 2 checkVersion bob aliceId 2 pure (aliceId, bobId) @@ -809,42 +1033,46 @@ testIncreaseConnAgentVersion t = do -- version doesn't increase if incompatible disposeAgentClient alice + threadDelay 250000 alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB runRight_ $ do subscribeConnection alice2 bobId - exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob aliceId checkVersion alice2 bobId 2 checkVersion bob aliceId 2 -- version increases if compatible disposeAgentClient bob + threadDelay 250000 bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2 runRight_ $ do subscribeConnection bob2 aliceId - exchangeGreetingsMsgId_ PQEncOff 8 alice2 bobId bob2 aliceId + exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob2 aliceId checkVersion alice2 bobId 3 checkVersion bob2 aliceId 3 -- version doesn't decrease, even if incompatible disposeAgentClient alice2 + threadDelay 250000 alice3 <- getSMPAgentClient' 5 agentCfg {smpAgentVRange = mkVersionRange 2 2} initAgentServers testDB runRight_ $ do subscribeConnection alice3 bobId - exchangeGreetingsMsgId_ PQEncOff 10 alice3 bobId bob2 aliceId + exchangeGreetingsMsgId_ PQEncOff 8 alice3 bobId bob2 aliceId checkVersion alice3 bobId 3 checkVersion bob2 aliceId 3 disposeAgentClient bob2 + threadDelay 250000 bob3 <- getSMPAgentClient' 6 agentCfg {smpAgentVRange = mkVersionRange 1 1} initAgentServers testDB2 runRight_ $ do subscribeConnection bob3 aliceId - exchangeGreetingsMsgId_ PQEncOff 12 alice3 bobId bob3 aliceId + exchangeGreetingsMsgId_ PQEncOff 10 alice3 bobId bob3 aliceId checkVersion alice3 bobId 3 checkVersion bob3 aliceId 3 disposeAgentClient alice3 @@ -862,7 +1090,7 @@ testIncreaseConnAgentVersionMaxCompatible t = do withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob - exchangeGreetingsMsgId_ PQEncOff 4 alice bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId checkVersion alice bobId 2 checkVersion bob aliceId 2 pure (aliceId, bobId) @@ -870,14 +1098,16 @@ testIncreaseConnAgentVersionMaxCompatible t = do -- version increases to max compatible disposeAgentClient alice + threadDelay 250000 alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB disposeAgentClient bob + threadDelay 250000 bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = supportedSMPAgentVRange} initAgentServers testDB2 runRight_ $ do subscribeConnection alice2 bobId subscribeConnection bob2 aliceId - exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob2 aliceId + exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob2 aliceId checkVersion alice2 bobId 3 checkVersion bob2 aliceId 3 disposeAgentClient alice2 @@ -890,7 +1120,7 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob - exchangeGreetingsMsgId_ PQEncOff 4 alice bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId checkVersion alice bobId 2 checkVersion bob aliceId 2 pure (aliceId, bobId) @@ -898,11 +1128,12 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do -- version increases to max compatible disposeAgentClient alice + threadDelay 250000 alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB runRight_ $ do subscribeConnection alice2 bobId - exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob aliceId checkVersion alice2 bobId 3 checkVersion bob aliceId 3 disposeAgentClient alice2 @@ -916,13 +1147,13 @@ testDeliverClientRestart t = do (aliceId, bobId) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do runRight $ do (aliceId, bobId) <- makeConnection alice bob - exchangeGreetingsMsgId 4 alice bobId bob aliceId + exchangeGreetings alice bobId bob aliceId pure (aliceId, bobId) ("", "", DOWN _ _) <- nGet alice ("", "", DOWN _ _) <- nGet bob - 6 <- runRight $ sendMessage bob aliceId SMP.noMsgFlags "hello" + 4 <- runRight $ sendMessage bob aliceId SMP.noMsgFlags "hello" disposeAgentClient bob @@ -934,7 +1165,7 @@ testDeliverClientRestart t = do subscribeConnection bob2 aliceId - get bob2 ##> ("", aliceId, SENT 6) + get bob2 ##> ("", aliceId, SENT 4) get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False disposeAgentClient alice disposeAgentClient bob2 @@ -946,19 +1177,20 @@ testDuplicateMessage t = do (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do - 4 <- sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT 4) + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False disposeAgentClient bob + threadDelay 250000 -- if the agent user did not send ACK, the message will be delivered again bob1 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 runRight_ $ do subscribeConnection bob1 aliceId get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob1 aliceId 4 Nothing - 5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" - get alice ##> ("", bobId, SENT 5) + ackMessage bob1 aliceId 2 Nothing + 3 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" + get alice ##> ("", bobId, SENT 3) get bob1 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False pure (aliceId, bobId, bob1) @@ -968,10 +1200,11 @@ testDuplicateMessage t = do -- commenting two lines below and uncommenting further two lines would also runRight_, -- it is the scenario tested above, when the message was not acknowledged by the user threadDelay 200000 - Left (BROKER _ NETWORK) <- runExceptT $ ackMessage bob1 aliceId 5 Nothing + Left (BROKER _ NETWORK) <- runExceptT $ ackMessage bob1 aliceId 3 Nothing disposeAgentClient alice disposeAgentClient bob1 + threadDelay 250000 alice2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB bob2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB2 @@ -983,8 +1216,8 @@ testDuplicateMessage t = do -- get bob2 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False -- ackMessage bob2 aliceId 5 Nothing -- message 2 is not delivered again, even though it was delivered to the agent - 6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3" - get alice2 ##> ("", bobId, SENT 6) + 4 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3" + get alice2 ##> ("", bobId, SENT 4) get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False disposeAgentClient alice2 disposeAgentClient bob2 @@ -996,20 +1229,20 @@ testSkippedMessages t = do (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do - 4 <- sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT 4) + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId 4 Nothing + ackMessage bob aliceId 2 Nothing disposeAgentClient bob runRight_ $ do - 5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" + 3 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" + get alice ##> ("", bobId, SENT 3) + 4 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" + get alice ##> ("", bobId, SENT 4) + 5 <- sendMessage alice bobId SMP.noMsgFlags "hello 4" get alice ##> ("", bobId, SENT 5) - 6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" - get alice ##> ("", bobId, SENT 6) - 7 <- sendMessage alice bobId SMP.noMsgFlags "hello 4" - get alice ##> ("", bobId, SENT 7) pure (aliceId, bobId) @@ -1026,72 +1259,117 @@ testSkippedMessages t = do subscribeConnection bob2 aliceId subscribeConnection alice2 bobId - 8 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 5" - get alice2 ##> ("", bobId, SENT 8) - get bob2 =##> \case ("", c, MSG MsgMeta {integrity = MsgError {errorInfo = MsgSkipped {fromMsgId = 4, toMsgId = 6}}} _ "hello 5") -> c == aliceId; _ -> False - ackMessage bob2 aliceId 5 Nothing + 6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 5" + get alice2 ##> ("", bobId, SENT 6) + get bob2 =##> \case ("", c, MSG MsgMeta {integrity = MsgError {errorInfo = MsgSkipped {fromMsgId = 3, toMsgId = 5}}} _ "hello 5") -> c == aliceId; _ -> False + ackMessage bob2 aliceId 3 Nothing - 9 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 6" - get alice2 ##> ("", bobId, SENT 9) + 7 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 6" + get alice2 ##> ("", bobId, SENT 7) get bob2 =##> \case ("", c, Msg "hello 6") -> c == aliceId; _ -> False - ackMessage bob2 aliceId 6 Nothing + ackMessage bob2 aliceId 4 Nothing disposeAgentClient alice2 disposeAgentClient bob2 +testDeliveryAfterSubscriptionError :: HasCallStack => ATransport -> IO () +testDeliveryAfterSubscriptionError t = do + (aId, bId) <- withAgentClients2 $ \a b -> do + (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False + 2 <- runRight $ sendMessage a bId SMP.noMsgFlags "hello" + liftIO $ noMessages b "not delivered" + pure (aId, bId) + + withAgentClients2 $ \a b -> do + Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection a bId + Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection b aId + withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + withUP a bId $ \case ("", c, SENT 2) -> c == bId; _ -> False + withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False + ackMessage b aId 2 Nothing + +testMsgDeliveryQuotaExceeded :: HasCallStack => ATransport -> IO () +testMsgDeliveryQuotaExceeded t = + withAgentClients2 $ \a b -> withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + (aId, bId) <- makeConnection a b + (aId', bId') <- makeConnection a b + forM_ ([1 .. 4] :: [Int]) $ \i -> do + mId <- sendMessage a bId SMP.noMsgFlags $ "message " <> bshow i + get a =##> \case ("", c, SENT mId') -> bId == c && mId == mId'; _ -> False + 6 <- sendMessage a bId SMP.noMsgFlags "over quota" + pGet' a False =##> \case ("", c, AEvt _ (MWARN 6 (SMP _ QUOTA))) -> bId == c; _ -> False + 2 <- sendMessage a bId' SMP.noMsgFlags "hello" + get a =##> \case ("", c, SENT 2) -> bId' == c; _ -> False + get b =##> \case ("", c, Msg "message 1") -> aId == c; _ -> False + get b =##> \case ("", c, Msg "hello") -> aId' == c; _ -> False + ackMessage b aId' 2 Nothing + ackMessage b aId 2 Nothing + get b =##> \case ("", c, Msg "message 2") -> aId == c; _ -> False + ackMessage b aId 3 Nothing + get b =##> \case ("", c, Msg "message 3") -> aId == c; _ -> False + ackMessage b aId 4 Nothing + get b =##> \case ("", c, Msg "message 4") -> aId == c; _ -> False + ackMessage b aId 5 Nothing + get a =##> \case ("", c, QCONT) -> bId == c; _ -> False + get b =##> \case ("", c, Msg "over quota") -> aId == c; _ -> False + ackMessage b aId 7 Nothing -- msg 8 was QCONT + get a =##> \case ("", c, SENT 6) -> bId == c; _ -> False + liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events") + testExpireMessage :: HasCallStack => ATransport -> IO () testExpireMessage t = - withAgent 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> + withAgent 1 agentCfg {messageTimeout = 1.5, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" - threadDelay 1000000 - 5 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire - get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + 2 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" + threadDelay 1500000 + 3 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire + get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False - withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 3) "2") -> True; _ -> False - ackMessage b aId 4 Nothing + withUP a bId $ \case ("", _, SENT 3) -> True; _ -> False + withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 2) "2") -> True; _ -> False + ackMessage b aId 2 Nothing testExpireManyMessages :: HasCallStack => ATransport -> IO () testExpireManyMessages t = - withAgent 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> + withAgent 1 agentCfg {messageTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b runRight_ $ do nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- sendMessage a bId SMP.noMsgFlags "1" - 5 <- sendMessage a bId SMP.noMsgFlags "2" - 6 <- sendMessage a bId SMP.noMsgFlags "3" - liftIO $ threadDelay 1000000 - 7 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire - get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False - -- get a =##> \case ("", c, MERRS [5, 6] (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + 2 <- sendMessage a bId SMP.noMsgFlags "1" + 3 <- sendMessage a bId SMP.noMsgFlags "2" + 4 <- sendMessage a bId SMP.noMsgFlags "3" + liftIO $ threadDelay 2000000 + 5 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire + get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False let expected c e = bId == c && (e == TIMEOUT || e == NETWORK) get a >>= \case - ("", c, MERR 5 (BROKER _ e)) -> do + ("", c, MERR 3 (BROKER _ e)) -> do liftIO $ expected c e `shouldBe` True - get a =##> \case ("", c', MERR 6 (BROKER _ e')) -> expected c' e'; ("", c', MERRS [6] (BROKER _ e')) -> expected c' e'; _ -> False - ("", c, MERRS [5] (BROKER _ e)) -> do + get a =##> \case ("", c', MERR 4 (BROKER _ e')) -> expected c' e'; ("", c', MERRS [4] (BROKER _ e')) -> expected c' e'; _ -> False + ("", c, MERRS [3] (BROKER _ e)) -> do liftIO $ expected c e `shouldBe` True - get a =##> \case ("", c', MERR 6 (BROKER _ e')) -> expected c' e'; _ -> False - ("", c, MERRS [5, 6] (BROKER _ e)) -> + get a =##> \case ("", c', MERR 4 (BROKER _ e')) -> expected c' e'; _ -> False + ("", c, MERRS [3, 4] (BROKER _ e)) -> liftIO $ expected c e `shouldBe` True r -> error $ show r withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - withUP a bId $ \case ("", _, SENT 7) -> True; _ -> False - withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 5) "4") -> True; _ -> False - ackMessage b aId 4 Nothing + withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False + withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 4) "4") -> True; _ -> False + ackMessage b aId 2 Nothing -withUP :: AgentClient -> ConnId -> (AEntityTransmission 'AEConn -> Bool) -> ExceptT AgentErrorType IO () +withUP :: HasCallStack => AgentClient -> ConnId -> (AEntityTransmission 'AEConn -> Bool) -> ExceptT AgentErrorType IO () withUP a bId p = liftIO $ getInAnyOrder a - [ \case ("", "", APC SAENone (UP _ [c])) -> c == bId; _ -> False, - \case (corrId, c, APC SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False + [ \case ("", "", AEvt SAENone (UP _ [c])) -> c == bId; _ -> False, + \case (corrId, c, AEvt SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False ] testExpireMessageQuota :: HasCallStack => ATransport -> IO () @@ -1101,60 +1379,60 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP (aId, bId) <- runRight $ do (aId, bId) <- makeConnection a b liftIO $ threadDelay 500000 >> disposeAgentClient b - 4 <- sendMessage a bId SMP.noMsgFlags "1" - get a ##> ("", bId, SENT 4) - 5 <- sendMessage a bId SMP.noMsgFlags "2" + 2 <- sendMessage a bId SMP.noMsgFlags "1" + get a ##> ("", bId, SENT 2) + 3 <- sendMessage a bId SMP.noMsgFlags "2" liftIO $ threadDelay 1000000 - 6 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire - get a =##> \case ("", c, MERR 5 (SMP QUOTA)) -> bId == c; _ -> False + 4 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire + get a =##> \case ("", c, MERR 3 (SMP _ QUOTA)) -> bId == c; _ -> False pure (aId, bId) withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do subscribeConnection b' aId get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False - ackMessage b' aId 4 Nothing + ackMessage b' aId 2 Nothing liftIO . getInAnyOrder a $ - [ \case ("", c, APC SAEConn (SENT 6)) -> c == bId; _ -> False, - \case ("", c, APC SAEConn QCONT) -> c == bId; _ -> False + [ \case ("", c, AEvt SAEConn (SENT 4)) -> c == bId; _ -> False, + \case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False ] - get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 4) "3") -> c == aId; _ -> False - ackMessage b' aId 6 Nothing + get b' =##> \case ("", c, MsgErr 4 (MsgSkipped 3 3) "3") -> c == aId; _ -> False + ackMessage b' aId 4 Nothing disposeAgentClient a testExpireManyMessagesQuota :: ATransport -> IO () testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do - a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB + a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (aId, bId) <- runRight $ do (aId, bId) <- makeConnection a b liftIO $ threadDelay 500000 >> disposeAgentClient b - 4 <- sendMessage a bId SMP.noMsgFlags "1" - get a ##> ("", bId, SENT 4) - 5 <- sendMessage a bId SMP.noMsgFlags "2" - 6 <- sendMessage a bId SMP.noMsgFlags "3" - 7 <- sendMessage a bId SMP.noMsgFlags "4" - liftIO $ threadDelay 1000000 - 8 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire - get a =##> \case ("", c, MERR 5 (SMP QUOTA)) -> bId == c; _ -> False + 2 <- sendMessage a bId SMP.noMsgFlags "1" + get a ##> ("", bId, SENT 2) + 3 <- sendMessage a bId SMP.noMsgFlags "2" + 4 <- sendMessage a bId SMP.noMsgFlags "3" + 5 <- sendMessage a bId SMP.noMsgFlags "4" + liftIO $ threadDelay 2000000 + 6 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire + get a =##> \case ("", c, MERR 3 (SMP _ QUOTA)) -> bId == c; _ -> False get a >>= \case - ("", c, MERR 6 (SMP QUOTA)) -> do + ("", c, MERR 4 (SMP _ QUOTA)) -> do liftIO $ bId `shouldBe` c - get a =##> \case ("", c', MERR 7 (SMP QUOTA)) -> bId == c'; ("", c', MERRS [7] (SMP QUOTA)) -> bId == c'; _ -> False - ("", c, MERRS [6] (SMP QUOTA)) -> do + get a =##> \case ("", c', MERR 5 (SMP _ QUOTA)) -> bId == c'; ("", c', MERRS [5] (SMP _ QUOTA)) -> bId == c'; _ -> False + ("", c, MERRS [4] (SMP _ QUOTA)) -> do liftIO $ bId `shouldBe` c - get a =##> \case ("", c', MERR 7 (SMP QUOTA)) -> bId == c'; _ -> False - ("", c, MERRS [6, 7] (SMP QUOTA)) -> liftIO $ bId `shouldBe` c + get a =##> \case ("", c', MERR 5 (SMP _ QUOTA)) -> bId == c'; _ -> False + ("", c, MERRS [4, 5] (SMP _ QUOTA)) -> liftIO $ bId `shouldBe` c r -> error $ show r pure (aId, bId) withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do subscribeConnection b' aId get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False - ackMessage b' aId 4 Nothing + ackMessage b' aId 2 Nothing liftIO . getInAnyOrder a $ - [ \case ("", c, APC SAEConn (SENT 8)) -> c == bId; _ -> False, - \case ("", c, APC SAEConn QCONT) -> c == bId; _ -> False + [ \case ("", c, AEvt SAEConn (SENT 6)) -> c == bId; _ -> False, + \case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False ] - get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 6) "5") -> c == aId; _ -> False - ackMessage b' aId 6 Nothing + get b' =##> \case ("", c, MsgErr 4 (MsgSkipped 3 5) "5") -> c == aId; _ -> False + ackMessage b' aId 4 Nothing disposeAgentClient a testRatchetSync :: HasCallStack => ATransport -> IO () @@ -1168,36 +1446,37 @@ testRatchetSync t = withAgentClients2 $ \alice bob -> get bob2 =##> ratchetSyncP aliceId RSAgreed get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient bob2 setupDesynchronizedRatchet :: HasCallStack => AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient) setupDesynchronizedRatchet alice bob = do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do - 4 <- sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT 4) + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId 4 Nothing + ackMessage bob aliceId 2 Nothing - 5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2" - get bob ##> ("", aliceId, SENT 5) + 3 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2" + get bob ##> ("", aliceId, SENT 3) get alice =##> \case ("", c, Msg "hello 2") -> c == bobId; _ -> False - ackMessage alice bobId 5 Nothing + ackMessage alice bobId 3 Nothing liftIO $ copyFile testDB2 (testDB2 <> ".bak") - 6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" - get alice ##> ("", bobId, SENT 6) + 4 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" + get alice ##> ("", bobId, SENT 4) get bob =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False - ackMessage bob aliceId 6 Nothing + ackMessage bob aliceId 4 Nothing - 7 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4" - get bob ##> ("", aliceId, SENT 7) + 5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4" + get bob ##> ("", aliceId, SENT 5) get alice =##> \case ("", c, Msg "hello 4") -> c == bobId; _ -> False - ackMessage alice bobId 7 Nothing + ackMessage alice bobId 5 Nothing disposeAgentClient bob + threadDelay 250000 -- importing database backup after progressing ratchet de-synchronizes ratchet liftIO $ renameFile (testDB2 <> ".bak") testDB2 @@ -1209,8 +1488,8 @@ setupDesynchronizedRatchet alice bob = do Left A.CMD {cmdErr = PROHIBITED} <- liftIO . runExceptT $ synchronizeRatchet bob2 aliceId PQSupportOn False - 8 <- sendMessage alice bobId SMP.noMsgFlags "hello 5" - get alice ##> ("", bobId, SENT 8) + 6 <- sendMessage alice bobId SMP.noMsgFlags "hello 5" + get alice ##> ("", bobId, SENT 6) get bob2 =##> ratchetSyncP aliceId RSRequired Left A.CMD {cmdErr = PROHIBITED} <- liftIO . runExceptT $ sendMessage bob2 aliceId SMP.noMsgFlags "hello 6" @@ -1224,9 +1503,9 @@ ratchetSyncP cId rss = \case cId' == cId && rss' == rss && ratchetSyncState == rss _ -> False -ratchetSyncP' :: ConnId -> RatchetSyncState -> ATransmission 'Agent -> Bool +ratchetSyncP' :: ConnId -> RatchetSyncState -> ATransmission -> Bool ratchetSyncP' cId rss = \case - (_, cId', APC SAEConn (RSYNC rss' _ ConnectionStats {ratchetSyncState})) -> + (_, cId', AEvt SAEConn (RSYNC rss' _ ConnectionStats {ratchetSyncState})) -> cId' == cId && rss' == rss && ratchetSyncState == rss _ -> False @@ -1242,23 +1521,18 @@ testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do liftIO $ ratchetSyncState `shouldBe` RSStarted withSmpServerStoreMsgLogOn t testPort $ \_ -> do + concurrently_ + (getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP]) + (getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP]) runRight_ $ do - liftIO . getInAnyOrder alice $ - [ ratchetSyncP' bobId RSAgreed, - serverUpP - ] - liftIO . getInAnyOrder bob2 $ - [ ratchetSyncP' aliceId RSAgreed, - serverUpP - ] get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient bob2 -serverUpP :: ATransmission 'Agent -> Bool +serverUpP :: ATransmission -> Bool serverUpP = \case - ("", "", APC SAENone (UP _ _)) -> True + ("", "", AEvt SAENone (UP _ _)) -> True _ -> False testRatchetSyncClientRestart :: HasCallStack => ATransport -> IO () @@ -1281,7 +1555,7 @@ testRatchetSyncClientRestart t = do get bob3 =##> ratchetSyncP aliceId RSAgreed get alice =##> ratchetSyncP bobId RSOk get bob3 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob3 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob3 aliceId 7 disposeAgentClient alice disposeAgentClient bob disposeAgentClient bob3 @@ -1304,18 +1578,13 @@ testRatchetSyncSuspendForeground t = do foregroundAgent bob2 withSmpServerStoreMsgLogOn t testPort $ \_ -> do + concurrently_ + (getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP]) + (getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP]) runRight_ $ do - liftIO . getInAnyOrder alice $ - [ ratchetSyncP' bobId RSAgreed, - serverUpP - ] - liftIO . getInAnyOrder bob2 $ - [ ratchetSyncP' aliceId RSAgreed, - serverUpP - ] get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient alice disposeAgentClient bob disposeAgentClient bob2 @@ -1337,24 +1606,19 @@ testRatchetSyncSimultaneous t = do liftIO $ aRSS `shouldBe` RSStarted withSmpServerStoreMsgLogOn t testPort $ \_ -> do + concurrently_ + (getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP]) + (getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP]) runRight_ $ do - liftIO . getInAnyOrder alice $ - [ ratchetSyncP' bobId RSAgreed, - serverUpP - ] - liftIO . getInAnyOrder bob2 $ - [ ratchetSyncP' aliceId RSAgreed, - serverUpP - ] get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient alice disposeAgentClient bob disposeAgentClient bob2 -testOnlyCreatePull :: IO () -testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do +testOnlyCreatePullSlowHandshake :: IO () +testOnlyCreatePullSlowHandshake = withAgentClientsCfg2 agentProxyCfgV8 agentProxyCfgV8 $ \alice bob -> runRight_ $ do (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice @@ -1378,14 +1642,38 @@ testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do getMsg alice bobId $ get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False ackMessage alice bobId 5 Nothing - where - getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO a -> ExceptT AgentErrorType IO a - getMsg c cId action = do - liftIO $ noMessages c "nothing should be delivered before GET" - Just _ <- getConnectionMessage c cId - r <- action - get c =##> \case ("", cId', MSGNTF _) -> cId == cId'; _ -> False - pure r + +getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO a -> ExceptT AgentErrorType IO a +getMsg c cId action = do + liftIO $ noMessages c "nothing should be delivered before GET" + Just _ <- getConnectionMessage c cId + r <- action + get c =##> \case ("", cId', MSGNTF _) -> cId == cId'; _ -> False + pure r + +testOnlyCreatePull :: IO () +testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate + Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice + allowConnection alice bobId confId "alice's connInfo" + liftIO $ threadDelay 1_000000 + getMsg bob aliceId $ do + get bob ##> ("", aliceId, INFO "alice's connInfo") + get bob ##> ("", aliceId, CON) + liftIO $ threadDelay 1_000000 + get alice ##> ("", bobId, CON) -- sent to initiating party after sending confirmation + -- exchange messages + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) + getMsg bob aliceId $ + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId 2 Nothing + 3 <- sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT 3) + getMsg alice bobId $ + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId 3 Nothing makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnection = makeConnection_ PQSupportOn @@ -1393,13 +1681,15 @@ makeConnection = makeConnection_ PQSupportOn makeConnection_ :: PQSupport -> AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnection_ pqEnc alice bob = makeConnectionForUsers_ pqEnc alice 1 bob 1 -makeConnectionForUsers :: AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId) +makeConnectionForUsers :: HasCallStack => AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn -makeConnectionForUsers_ :: PQSupport -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId) +makeConnectionForUsers_ :: HasCallStack => PQSupport -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnectionForUsers_ pqSupport alice aliceUserId bob bobUserId = do (bobId, qInfo) <- A.createConnection alice aliceUserId True SCMInvitation Nothing (CR.IKNoPQ pqSupport) SMSubscribe - aliceId <- A.joinConnection bob bobUserId True qInfo "bob's connInfo" pqSupport SMSubscribe + aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport + aliceId' <- A.joinConnection bob bobUserId (Just aliceId) True qInfo "bob's connInfo" pqSupport SMSubscribe + liftIO $ aliceId' `shouldBe` aliceId ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` pqSupport allowConnection alice bobId confId "alice's connInfo" @@ -1415,8 +1705,8 @@ testInactiveNoSubs t = do withSmpServerConfigOn t cfg' testPort $ \_ -> withAgent 1 agentCfg initAgentServers testDB $ \alice -> do runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check - Just (_, _, APC SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice) - Just (_, _, APC SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice) + Just (_, _, AEvt SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice) + Just (_, _, AEvt SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice) pure () testInactiveWithSubs :: ATransport -> IO () @@ -1461,14 +1751,14 @@ testSuspendingAgent :: IO () testSuspendingAgent = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing liftIO $ suspendAgent b 1000000 get' b ##> ("", "", SUSPENDED) - 5 <- sendMessage a bId SMP.noMsgFlags "hello 2" - get a ##> ("", bId, SENT 5) + 3 <- sendMessage a bId SMP.noMsgFlags "hello 2" + get a ##> ("", bId, SENT 3) Nothing <- 100000 `timeout` get b liftIO $ foregroundAgent b get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False @@ -1477,47 +1767,47 @@ testSuspendingAgentCompleteSending :: ATransport -> IO () testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing pure (aId, bId) runRight_ $ do ("", "", DOWN {}) <- nGet a ("", "", DOWN {}) <- nGet b - 5 <- sendMessage b aId SMP.noMsgFlags "hello too" - 6 <- sendMessage b aId SMP.noMsgFlags "how are you?" + 3 <- sendMessage b aId SMP.noMsgFlags "hello too" + 4 <- sendMessage b aId SMP.noMsgFlags "how are you?" liftIO $ threadDelay 100000 liftIO $ suspendAgent b 5000000 withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do - pGet b =##> \case ("", c, APC _ (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False - pGet b =##> \case ("", c, APC _ (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False - pGet b =##> \case ("", c, APC _ (SENT 6)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, AEvt SAEConn (SENT 3)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, AEvt SAEConn (SENT 3)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, AEvt SAEConn (SENT 4)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False ("", "", SUSPENDED) <- nGet b - pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False - pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False - ackMessage a bId 5 Nothing + pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False + pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False + ackMessage a bId 3 Nothing get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False - ackMessage a bId 6 Nothing + ackMessage a bId 4 Nothing testSuspendingAgentTimeout :: ATransport -> IO () testSuspendingAgentTimeout t = withAgentClients2 $ \a b -> do (aId, _) <- withSmpServer t . runRight $ do (aId, bId) <- makeConnection a b - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing pure (aId, bId) runRight_ $ do ("", "", DOWN {}) <- nGet a ("", "", DOWN {}) <- nGet b - 5 <- sendMessage b aId SMP.noMsgFlags "hello too" - 6 <- sendMessage b aId SMP.noMsgFlags "how are you?" + 3 <- sendMessage b aId SMP.noMsgFlags "hello too" + 4 <- sendMessage b aId SMP.noMsgFlags "how are you?" liftIO $ suspendAgent b 100000 ("", "", SUSPENDED) <- nGet b pure () @@ -1526,7 +1816,7 @@ testBatchedSubscriptions :: Int -> Int -> ATransport -> IO () testBatchedSubscriptions nCreate nDel t = withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do conns <- runServers $ do - conns <- replicateM (nCreate :: Int) $ makeConnection_ PQSupportOff a b + conns <- replicateM nCreate $ makeConnection_ PQSupportOff a b forM_ conns $ \(aId, bId) -> exchangeGreetings_ PQEncOff a bId b aId let (aIds', bIds') = unzip $ take nDel conns delete a bIds' @@ -1548,10 +1838,10 @@ testBatchedSubscriptions nCreate nDel t = (aIds', bIds') = unzip conns' subscribe a bIds subscribe b aIds - forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 4 a bId b aId void $ resubscribeConnections a bIds void $ resubscribeConnections b aIds - forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 8 a bId b aId + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId delete a bIds' delete b aIds' deleteFail a bIds' @@ -1585,9 +1875,28 @@ testBatchedSubscriptions nCreate nDel t = killThread t1 pure res -testAsyncCommands :: IO () -testAsyncCommands = - withAgentClients2 $ \alice bob -> runRight_ $ do +testBatchedPendingMessages :: Int -> Int -> IO () +testBatchedPendingMessages nCreate nMsgs = + withA $ \a -> do + conns <- withB $ \b -> runRight $ do + replicateM nCreate $ makeConnection a b + let msgConns = take nMsgs conns + runRight_ $ forM_ msgConns $ \(_, bId) -> sendMessage a bId SMP.noMsgFlags "hello" + replicateM_ nMsgs $ get a =##> \case ("", cId, SENT _) -> isJust $ find ((cId ==) . snd) msgConns; _ -> False + withB $ \b -> runRight_ $ do + r <- subscribeConnections b $ map fst conns + liftIO $ all isRight r `shouldBe` True + replicateM_ nMsgs $ do + ("", cId, Msg' msgId _ "hello") <- get b + liftIO $ isJust (find ((cId ==) . fst) msgConns) `shouldBe` True + ackMessage b cId msgId Nothing + where + withA = withAgent 1 agentCfg initAgentServers testDB + withB = withAgent 2 agentCfg initAgentServers testDB2 + +testAsyncCommands :: AgentClient -> AgentClient -> AgentMsgId -> IO () +testAsyncCommands alice bob baseId = + runRight_ $ do bobId <- createConnectionAsync alice 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bobId', INV (ACR _ qInfo)) <- get alice liftIO $ bobId' `shouldBe` bobId @@ -1632,7 +1941,6 @@ testAsyncCommands = get alice =##> \case ("", c, DEL_CONN) -> c == bobId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" where - baseId = 3 msgId = subtract baseId testAsyncCommandsRestore :: ATransport -> IO () @@ -1647,9 +1955,9 @@ testAsyncCommandsRestore t = do get alice' =##> \case ("1", _, INV _) -> True; _ -> False pure () -testAcceptContactAsync :: IO () -testAcceptContactAsync = - withAgentClients2 $ \alice bob -> runRight_ $ do +testAcceptContactAsync :: AgentClient -> AgentClient -> AgentMsgId -> IO () +testAcceptContactAsync alice bob baseId = + runRight_ $ do (_, qInfo) <- createConnection alice 1 True SCMContact Nothing SMSubscribe aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, REQ invId _ "bob's connInfo") <- get alice @@ -1679,11 +1987,10 @@ testAcceptContactAsync = ackMessage alice bobId (baseId + 4) Nothing suspendConnection alice bobId 5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2" - get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH)) + get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 5); _ -> False deleteConnection alice bobId liftIO $ noMessages alice "nothing else should be delivered to alice" where - baseId = 3 msgId = subtract baseId testDeleteConnectionAsync :: ATransport -> IO () @@ -1725,12 +2032,12 @@ testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob -> get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False 3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2" - get bob ##> ("", aliceId, MERR (baseId + 3) (SMP AUTH)) + get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 3); _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDelivery :: ATransport -> IO () @@ -1770,8 +2077,8 @@ testWaitDelivery t = liftIO $ getInAnyOrder bob - [ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, - \case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False + [ \case ("", "", AEvt SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, + \case ("", cId, AEvt SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False ] ackMessage bob aliceId (baseId + 3) Nothing get bob =##> \case ("", c, Msg "message 1") -> c == aliceId; _ -> False @@ -1784,7 +2091,7 @@ testWaitDelivery t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDeliveryAUTHErr :: ATransport -> IO () @@ -1820,14 +2127,14 @@ testWaitDeliveryAUTHErr t = liftIO $ noMessages bob "nothing else should be delivered to bob" withSmpServerStoreLogOn t testPort $ \_ -> do - get alice ##> ("", bobId, MERR (baseId + 3) (SMP AUTH)) - get alice ##> ("", bobId, MERR (baseId + 4) (SMP AUTH)) + get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 3); _ -> False + get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 4); _ -> False get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDeliveryTimeout :: ATransport -> IO () @@ -1867,7 +2174,7 @@ testWaitDeliveryTimeout t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDeliveryTimeout2 :: ATransport -> IO () @@ -1907,20 +2214,20 @@ testWaitDeliveryTimeout2 t = liftIO $ getInAnyOrder bob - [ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, - \case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False + [ \case ("", "", AEvt SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, + \case ("", cId, AEvt SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False ] liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId -testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () -testJoinConnectionAsyncReplyError t = do - let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} - withAgent 1 agentCfg initAgentServers testDB $ \a -> - withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do +testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => ATransport -> IO () +testJoinConnectionAsyncReplyErrorV8 t = do + let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} + withAgent 1 agentCfgVPrevPQ initAgentServers testDB $ \a -> + withAgent 2 agentCfgVPrevPQ initAgentServersSrv2 testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bId', INV (ACR _ qInfo)) <- get a @@ -1934,62 +2241,102 @@ testJoinConnectionAsyncReplyError t = do get b =##> \case ("2", c, OK) -> c == aId; _ -> False confId <- withSmpServerStoreLogOn t testPort $ \_ -> do pGet a >>= \case - ("", "", APC _ (UP _ [_])) -> do + ("", "", AEvt _ (UP _ [_])) -> do ("", _, CONF confId _ "bob's connInfo") <- get a pure confId - ("", _, APC _ (CONF confId _ "bob's connInfo")) -> do + ("", _, AEvt _ (CONF confId _ "bob's connInfo")) -> do ("", "", UP _ [_]) <- nGet a pure confId r -> error $ "unexpected response " <> show r nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False runRight_ $ do allowConnectionAsync a "3" bId confId "alice's connInfo" + get a ##> ("3", bId, OK) liftIO $ threadDelay 500000 ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure () withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False - pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False + nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False get a ##> ("", bId, CON) get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) + exchangeGreetingsMsgId 4 a bId b aId + +testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () +testJoinConnectionAsyncReplyError t = do + let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} + withAgent 1 agentCfg initAgentServers testDB $ \a -> + withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do + (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe + ("1", bId', INV (ACR _ qInfo)) <- get a + liftIO $ bId' `shouldBe` bId + aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe + liftIO $ threadDelay 500000 + ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId + pure (aId, bId) + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + withSmpServerOn t testPort2 $ do + confId <- withSmpServerStoreLogOn t testPort $ \_ -> do + -- both servers need to be online for connection to progress because of SKEY + get b =##> \case ("2", c, OK) -> c == aId; _ -> False + pGet a >>= \case + ("", "", AEvt _ (UP _ [_])) -> do + ("", _, CONF confId _ "bob's connInfo") <- get a + pure confId + ("", _, AEvt _ (CONF confId _ "bob's connInfo")) -> do + ("", "", UP _ [_]) <- nGet a + pure confId + r -> error $ "unexpected response " <> show r + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + runRight_ $ do + allowConnectionAsync a "3" bId confId "alice's connInfo" + get a ##> ("3", bId, OK) + get a ##> ("", bId, CON) + liftIO $ threadDelay 500000 + ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId + pure () + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) exchangeGreetings a bId b aId testUsers :: IO () testUsers = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId - auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] + exchangeGreetings a bId b aId + auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 - exchangeGreetingsMsgId 4 a bId' b aId' + exchangeGreetings a bId' b aId' deleteUser a auId True get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId'; _ -> False get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False - exchangeGreetingsMsgId 6 a bId b aId + exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" testDeleteUserQuietly :: IO () testDeleteUserQuietly = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId - auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] + exchangeGreetings a bId b aId + auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 - exchangeGreetingsMsgId 4 a bId' b aId' + exchangeGreetings a bId' b aId' deleteUser a auId False - exchangeGreetingsMsgId 6 a bId b aId + exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" testUsersNoServer :: HasCallStack => ATransport -> IO () testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId - auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] + exchangeGreetings a bId b aId + auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 - exchangeGreetingsMsgId 4 a bId' b aId' + exchangeGreetings a bId' b aId' pure (aId, bId, auId, aId', bId') nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False @@ -2003,7 +2350,7 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False - exchangeGreetingsMsgId 6 a bId b aId + exchangeGreetingsMsgId 4 a bId b aId where aCfg = agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} @@ -2011,9 +2358,9 @@ testSwitchConnection :: InitialAgentServers -> IO () testSwitchConnection servers = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId - testFullSwitch a bId b aId 10 - testFullSwitch a bId b aId 16 + exchangeGreetings a bId b aId + testFullSwitch a bId b aId 8 + testFullSwitch a bId b aId 14 testFullSwitch :: AgentClient -> ByteString -> AgentClient -> ByteString -> Int64 -> ExceptT AgentErrorType IO () testFullSwitch a bId b aId msgId = do @@ -2064,7 +2411,7 @@ testSwitchAsync :: HasCallStack => InitialAgentServers -> IO () testSwitchAsync servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2085,8 +2432,8 @@ testSwitchAsync servers = do withA $ \a -> withB $ \b -> runRight_ $ do subscribeConnection a bId subscribeConnection b aId - exchangeGreetingsMsgId 10 a bId b aId - testFullSwitch a bId b aId 16 + exchangeGreetingsMsgId 8 a bId b aId + testFullSwitch a bId b aId 14 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2094,7 +2441,7 @@ testSwitchAsync servers = do withB = withAgent 2 agentCfg servers testDB2 withAgent :: HasCallStack => Int -> AgentConfig -> InitialAgentServers -> FilePath -> (HasCallStack => AgentClient -> IO a) -> IO a -withAgent clientId cfg' servers dbPath = bracket (getSMPAgentClient' clientId cfg' servers dbPath) disposeAgentClient +withAgent clientId cfg' servers dbPath = bracket (getSMPAgentClient' clientId cfg' servers dbPath) (\a -> disposeAgentClient a >> threadDelay 100000) sessionSubscribe :: (forall a. (AgentClient -> IO a) -> IO a) -> [ConnId] -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO () sessionSubscribe withC connIds a = @@ -2109,7 +2456,7 @@ testSwitchDelete :: InitialAgentServers -> IO () testSwitchDelete servers = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId liftIO $ disposeAgentClient b stats <- switchConnectionAsync a "" bId liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted] @@ -2124,7 +2471,7 @@ testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO () testAbortSwitchStarted servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2161,9 +2508,9 @@ testAbortSwitchStarted servers = do phaseRcv a bId SPCompleted [Nothing] - exchangeGreetingsMsgId 12 a bId b aId + exchangeGreetingsMsgId 10 a bId b aId - testFullSwitch a bId b aId 18 + testFullSwitch a bId b aId 16 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2174,7 +2521,7 @@ testAbortSwitchStartedReinitiate :: HasCallStack => InitialAgentServers -> IO () testAbortSwitchStartedReinitiate servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2212,36 +2559,36 @@ testAbortSwitchStartedReinitiate servers = do phaseRcv a bId SPCompleted [Nothing] - exchangeGreetingsMsgId 12 a bId b aId + exchangeGreetingsMsgId 10 a bId b aId - testFullSwitch a bId b aId 18 + testFullSwitch a bId b aId 16 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfg servers testDB2 -switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ATransmission 'Agent -> Bool +switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ATransmission -> Bool switchPhaseRcvP cId sphase swchStatuses = switchPhaseP cId QDRcv sphase (\stats -> rcvSwchStatuses' stats == swchStatuses) -switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> ATransmission 'Agent -> Bool +switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> ATransmission -> Bool switchPhaseSndP cId sphase swchStatuses = switchPhaseP cId QDSnd sphase (\stats -> sndSwchStatuses' stats == swchStatuses) -switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> ATransmission 'Agent -> Bool +switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> ATransmission -> Bool switchPhaseP cId qd sphase statsP = \case - (_, cId', APC SAEConn (SWITCH qd' sphase' stats)) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats + (_, cId', AEvt SAEConn (SWITCH qd' sphase' stats)) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats _ -> False -errQueueNotFoundP :: ConnId -> ATransmission 'Agent -> Bool +errQueueNotFoundP :: ConnId -> ATransmission -> Bool errQueueNotFoundP cId = \case - (_, cId', APC SAEConn (ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}})) -> cId' == cId + (_, cId', AEvt SAEConn (ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}})) -> cId' == cId _ -> False testCannotAbortSwitchSecured :: HasCallStack => InitialAgentServers -> IO () testCannotAbortSwitchSecured servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2266,9 +2613,9 @@ testCannotAbortSwitchSecured servers = do phaseRcv a bId SPCompleted [Nothing] - exchangeGreetingsMsgId 10 a bId b aId + exchangeGreetingsMsgId 8 a bId b aId - testFullSwitch a bId b aId 16 + testFullSwitch a bId b aId 14 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2279,9 +2626,9 @@ testSwitch2Connections :: HasCallStack => InitialAgentServers -> IO () testSwitch2Connections servers = do (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do (aId1, bId1) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId1 b aId1 + exchangeGreetings a bId1 b aId1 (aId2, bId2) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId2 b aId2 + exchangeGreetings a bId2 b aId2 pure (aId1, bId1, aId2, bId2) let withA' = sessionSubscribe withA [bId1, bId2] withB' = sessionSubscribe withB [aId1, aId2] @@ -2322,11 +2669,11 @@ testSwitch2Connections servers = do void $ subscribeConnections a [bId1, bId2] void $ subscribeConnections b [aId1, aId2] - exchangeGreetingsMsgId 10 a bId1 b aId1 - exchangeGreetingsMsgId 10 a bId2 b aId2 + exchangeGreetingsMsgId 8 a bId1 b aId1 + exchangeGreetingsMsgId 8 a bId2 b aId2 - testFullSwitch a bId1 b aId1 16 - testFullSwitch a bId2 b aId2 16 + testFullSwitch a bId1 b aId1 14 + testFullSwitch a bId2 b aId2 14 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2337,9 +2684,9 @@ testSwitch2ConnectionsAbort1 :: HasCallStack => InitialAgentServers -> IO () testSwitch2ConnectionsAbort1 servers = do (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do (aId1, bId1) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId1 b aId1 + exchangeGreetings a bId1 b aId1 (aId2, bId2) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId2 b aId2 + exchangeGreetings a bId2 b aId2 pure (aId1, bId1, aId2, bId2) let withA' = sessionSubscribe withA [bId1, bId2] withB' = sessionSubscribe withB [aId1, aId2] @@ -2375,28 +2722,28 @@ testSwitch2ConnectionsAbort1 servers = do phaseRcv a bId1 SPCompleted [Nothing] - exchangeGreetingsMsgId 10 a bId1 b aId1 - exchangeGreetingsMsgId 8 a bId2 b aId2 + exchangeGreetingsMsgId 8 a bId1 b aId1 + exchangeGreetingsMsgId 6 a bId2 b aId2 - testFullSwitch a bId1 b aId1 16 - testFullSwitch a bId2 b aId2 14 + testFullSwitch a bId1 b aId1 14 + testFullSwitch a bId2 b aId2 12 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfg servers testDB2 -testCreateQueueAuth :: HasCallStack => VersionSMP -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> IO Int -testCreateQueueAuth srvVersion clnt1 clnt2 = do +testCreateQueueAuth :: HasCallStack => VersionSMP -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> AgentMsgId -> IO Int +testCreateQueueAuth srvVersion clnt1 clnt2 baseId = do a <- getClient 1 clnt1 testDB b <- getClient 2 clnt2 testDB2 r <- runRight $ do tryError (createConnection a 1 True SCMInvitation Nothing SMSubscribe) >>= \case - Left (SMP AUTH) -> pure 0 + Left (SMP _ AUTH) -> pure 0 Left e -> throwError e Right (bId, qInfo) -> tryError (joinConnection b 1 True qInfo "bob's connInfo" SMSubscribe) >>= \case - Left (SMP AUTH) -> pure 1 + Left (SMP _ AUTH) -> pure 1 Left e -> throwError e Right aId -> do ("", _, CONF confId _ "bob's connInfo") <- get a @@ -2404,15 +2751,16 @@ testCreateQueueAuth srvVersion clnt1 clnt2 = do get a ##> ("", bId, CON) get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) - exchangeGreetings a bId b aId + exchangeGreetingsMsgId (baseId + 1) a bId b aId pure 2 disposeAgentClient a disposeAgentClient b pure r where getClient clientId (clntAuth, clntVersion) db = - let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]} - smpCfg = (defaultSMPClientConfig :: ProtocolClientConfig SMPVersion) {serverVRange = V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion} + let servers = initAgentServers {smp = userServers' [ProtoServerWithAuth testSMPServer clntAuth]} + alpn_ = if clntVersion >= authCmdsSMPVersion then Just supportedSMPHandshakes else Nothing + smpCfg = defaultClientConfig alpn_ $ V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519 in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db @@ -2436,20 +2784,20 @@ testDeliveryReceipts = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b -- a sends, b receives and sends delivery receipt - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 $ Just "" - get a =##> \case ("", c, Rcvd 4) -> c == bId; _ -> False - ackMessage a bId 5 Nothing + ackMessage b aId 2 $ Just "" + get a =##> \case ("", c, Rcvd 2) -> c == bId; _ -> False + ackMessage a bId 3 Nothing -- b sends, a receives and sends delivery receipt - 6 <- sendMessage b aId SMP.noMsgFlags "hello too" - get b ##> ("", aId, SENT 6) + 4 <- sendMessage b aId SMP.noMsgFlags "hello too" + get b ##> ("", aId, SENT 4) get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False - ackMessage a bId 6 $ Just "" - get b =##> \case ("", c, Rcvd 6) -> c == aId; _ -> False - ackMessage b aId 7 (Just "") `catchError` \e -> liftIO $ e `shouldBe` A.CMD PROHIBITED - ackMessage b aId 7 Nothing + ackMessage a bId 4 $ Just "" + get b =##> \case ("", c, Rcvd 4) -> c == aId; _ -> False + ackMessage b aId 5 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e) + ackMessage b aId 5 Nothing testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO () testDeliveryReceiptsVersion t = do @@ -2460,15 +2808,15 @@ testDeliveryReceiptsVersion t = do (aId, bId) <- makeConnection_ PQSupportOff a b checkVersion a bId 3 checkVersion b aId 3 - (4, _) <- A.sendMessage a bId PQEncOff SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) - get b =##> \case ("", c, Msg' 4 PQEncOff "hello") -> c == aId; _ -> False - ackMessage b aId 4 $ Just "" + (2, _) <- A.sendMessage a bId PQEncOff SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) + get b =##> \case ("", c, Msg' 2 PQEncOff "hello") -> c == aId; _ -> False + ackMessage b aId 2 $ Just "" liftIO $ noMessages a "no delivery receipt (unsupported version)" - (5, _) <- A.sendMessage b aId PQEncOff SMP.noMsgFlags "hello too" - get b ##> ("", aId, SENT 5) - get a =##> \case ("", c, Msg' 5 PQEncOff "hello too") -> c == bId; _ -> False - ackMessage a bId 5 $ Just "" + (3, _) <- A.sendMessage b aId PQEncOff SMP.noMsgFlags "hello too" + get b ##> ("", aId, SENT 3) + get a =##> \case ("", c, Msg' 3 PQEncOff "hello too") -> c == bId; _ -> False + ackMessage a bId 3 $ Just "" liftIO $ noMessages b "no delivery receipt (unsupported version)" pure (aId, bId) @@ -2480,27 +2828,27 @@ testDeliveryReceiptsVersion t = do runRight_ $ do subscribeConnection a' bId subscribeConnection b' aId - exchangeGreetingsMsgId_ PQEncOff 6 a' bId b' aId - checkVersion a' bId 5 - checkVersion b' aId 5 - (8, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello" - get a' ##> ("", bId, SENT 8) - get b' =##> \case ("", c, Msg' 8 PQEncOff "hello") -> c == aId; _ -> False - ackMessage b' aId 8 $ Just "" - get a' =##> \case ("", c, Rcvd 8) -> c == bId; _ -> False - ackMessage a' bId 9 Nothing - (10, PQEncOff) <- A.sendMessage b' aId PQEncOn SMP.noMsgFlags "hello too" - get b' ##> ("", aId, SENT 10) - get a' =##> \case ("", c, Msg' 10 PQEncOff "hello too") -> c == bId; _ -> False - ackMessage a' bId 10 $ Just "" - get b' =##> \case ("", c, Rcvd 10) -> c == aId; _ -> False - ackMessage b' aId 11 Nothing - (12, _) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello 2" - get a' ##> ("", bId, SENT 12) - get b' =##> \case ("", c, Msg' 12 PQEncOff "hello 2") -> c == aId; _ -> False - ackMessage b' aId 12 $ Just "" - get a' =##> \case ("", c, Rcvd 12) -> c == bId; _ -> False - ackMessage a' bId 13 Nothing + exchangeGreetingsMsgId_ PQEncOff 4 a' bId b' aId + checkVersion a' bId 6 + checkVersion b' aId 6 + (6, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello" + get a' ##> ("", bId, SENT 6) + get b' =##> \case ("", c, Msg' 6 PQEncOff "hello") -> c == aId; _ -> False + ackMessage b' aId 6 $ Just "" + get a' =##> \case ("", c, Rcvd 6) -> c == bId; _ -> False + ackMessage a' bId 7 Nothing + (8, PQEncOff) <- A.sendMessage b' aId PQEncOn SMP.noMsgFlags "hello too" + get b' ##> ("", aId, SENT 8) + get a' =##> \case ("", c, Msg' 8 PQEncOff "hello too") -> c == bId; _ -> False + ackMessage a' bId 8 $ Just "" + get b' =##> \case ("", c, Rcvd 8) -> c == aId; _ -> False + ackMessage b' aId 9 Nothing + (10, _) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello 2" + get a' ##> ("", bId, SENT 10) + get b' =##> \case ("", c, Msg' 10 PQEncOff "hello 2") -> c == aId; _ -> False + ackMessage b' aId 10 $ Just "" + get a' =##> \case ("", c, Rcvd 10) -> c == bId; _ -> False + ackMessage a' bId 11 Nothing disposeAgentClient a' disposeAgentClient b' @@ -2571,8 +2919,8 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a a `hasClients` 2 - exchangeGreetingsMsgId 6 a bId1 b aId1 - exchangeGreetingsMsgId 6 a bId1' b aId1' + exchangeGreetingsMsgId 4 a bId1 b aId1 + exchangeGreetingsMsgId 4 a bId1' b aId1' liftIO $ threadDelay 250000 liftIO $ setNetworkConfig a nc {sessionMode = TSMUser} liftIO $ threadDelay 250000 @@ -2582,7 +2930,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a a `hasClients` 1 - aUserId2 <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] + aUserId2 <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] (aId2, bId2) <- makeConnectionForUsers a aUserId2 b 1 exchangeGreetings a bId2 b aId2 (aId2', bId2') <- makeConnectionForUsers a aUserId2 b 1 @@ -2596,10 +2944,10 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a ("", "", UP _ _) <- nGet a a `hasClients` 4 - exchangeGreetingsMsgId 8 a bId1 b aId1 - exchangeGreetingsMsgId 8 a bId1' b aId1' - exchangeGreetingsMsgId 6 a bId2 b aId2 - exchangeGreetingsMsgId 6 a bId2' b aId2' + exchangeGreetingsMsgId 6 a bId1 b aId1 + exchangeGreetingsMsgId 6 a bId1' b aId1' + exchangeGreetingsMsgId 4 a bId2 b aId2 + exchangeGreetingsMsgId 4 a bId2' b aId2' liftIO $ threadDelay 250000 liftIO $ setNetworkConfig a nc {sessionMode = TSMUser} liftIO $ threadDelay 250000 @@ -2612,10 +2960,10 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a ("", "", UP _ _) <- nGet a a `hasClients` 2 - exchangeGreetingsMsgId 10 a bId1 b aId1 - exchangeGreetingsMsgId 10 a bId1' b aId1' - exchangeGreetingsMsgId 8 a bId2 b aId2 - exchangeGreetingsMsgId 8 a bId2' b aId2' + exchangeGreetingsMsgId 8 a bId1 b aId1 + exchangeGreetingsMsgId 8 a bId1' b aId1' + exchangeGreetingsMsgId 6 a bId2 b aId2 + exchangeGreetingsMsgId 6 a bId2' b aId2' where hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO () hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n @@ -2642,9 +2990,10 @@ testServerMultipleIdentities = bob' <- liftIO $ do Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True secondIdentityCReq "bob's connInfo" SMSubscribe disposeAgentClient bob + threadDelay 250000 getSMPAgentClient' 3 agentCfg initAgentServers testDB2 subscribeConnection bob' aliceId - exchangeGreetingsMsgId 6 alice bobId bob' aliceId + exchangeGreetingsMsgId 4 alice bobId bob' aliceId liftIO $ disposeAgentClient bob' where secondIdentityCReq :: ConnectionRequestUri 'CMInvitation @@ -2667,9 +3016,7 @@ testWaitForUserNetwork = do noNetworkDelay a setUserNetworkInfo a $ UserNetworkInfo UNNone False networkDelay a 100000 - networkDelay a 150000 - networkDelay a 200000 - networkDelay a 200000 + networkDelay a 100000 setUserNetworkInfo a $ UserNetworkInfo UNCellular True noNetworkDelay a setUserNetworkInfo a $ UserNetworkInfo UNCellular False @@ -2679,36 +3026,151 @@ testWaitForUserNetwork = do (networkDelay a 50000) noNetworkDelay a where - aCfg = agentCfg {userNetworkInterval = RetryInterval {initialInterval = 100000, increaseAfter = 0, maxInterval = 200000}} + aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0} -testDoNotResetOfflineInterval :: IO () -testDoNotResetOfflineInterval = do +testDoNotResetOnlineToOffline :: IO () +testDoNotResetOnlineToOffline = do a <- getSMPAgentClient' 1 aCfg initAgentServers testDB noNetworkDelay a setUserNetworkInfo a $ UserNetworkInfo UNWifi False networkDelay a 100000 - networkDelay a 150000 - setUserNetworkInfo a $ UserNetworkInfo UNCellular False - networkDelay a 200000 - setUserNetworkInfo a $ UserNetworkInfo UNNone False - networkDelay a 200000 - setUserNetworkInfo a $ UserNetworkInfo UNCellular True + setUserNetworkInfo a $ UserNetworkInfo UNWifi False + setUserNetworkInfo a $ UserNetworkInfo UNWifi True noNetworkDelay a - setUserNetworkInfo a $ UserNetworkInfo UNCellular False + setUserNetworkInfo a $ UserNetworkInfo UNWifi False -- ingnored + noNetworkDelay a + threadDelay 100000 + setUserNetworkInfo a $ UserNetworkInfo UNWifi False networkDelay a 100000 + setUserNetworkInfo a $ UserNetworkInfo UNNone False + networkDelay a 100000 + setUserNetworkInfo a $ UserNetworkInfo UNWifi True + setUserNetworkInfo a $ UserNetworkInfo UNNone False -- ingnored + noNetworkDelay a where - aCfg = agentCfg {userNetworkInterval = RetryInterval {initialInterval = 100000, increaseAfter = 0, maxInterval = 200000}} + aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0.1} + +testResumeMultipleThreads :: IO () +testResumeMultipleThreads = do + a <- getSMPAgentClient' 1 aCfg initAgentServers testDB + noNetworkDelay a + setUserNetworkInfo a $ UserNetworkInfo UNNone False + vs <- + replicateM 50000 $ do + v <- newEmptyTMVarIO + void . forkIO $ waitNetwork a >>= atomically . putTMVar v + pure v + threadDelay 1000000 + setUserNetworkInfo a $ UserNetworkInfo UNCellular True + ts <- mapM (atomically . readTMVar) vs + -- print $ minimum ts + -- print $ maximum ts + -- print $ sum ts `div` fromIntegral (length ts) + let average = sum ts `div` fromIntegral (length ts) + average < 3000000 `shouldBe` True + maximum ts < 4000000 `shouldBe` True + where + aCfg = agentCfg {userOfflineDelay = 0} + +testServerQueueInfo :: IO () +testServerQueueInfo = do + withAgentClients2 $ \alice bob -> runRight_ $ do + (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe + liftIO $ threadDelay 200000 + checkEmptyQ alice bobId False + aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe + ("", _, CONF confId _ "bob's connInfo") <- get alice + liftIO $ threadDelay 200000 + checkEmptyQ alice bobId True -- secured by sender + allowConnection alice bobId confId "alice's connInfo" + get alice ##> ("", bobId, CON) + get bob ##> ("", aliceId, INFO "alice's connInfo") + get bob ##> ("", aliceId, CON) + liftIO $ threadDelay 200000 + checkEmptyQ alice bobId True + checkEmptyQ bob aliceId True + let msgId = 2 + (msgId', PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello" + liftIO $ msgId' `shouldBe` msgId + get alice ##> ("", bobId, SENT msgId) + liftIO $ threadDelay 200000 + Just srvMsgId <- checkMsgQ bob aliceId 1 + get bob =##> \case + ("", c, MSG MsgMeta {integrity = MsgOk, broker = (smId, _), recipient = (mId, _), pqEncryption = PQEncOn} _ "hello") -> + c == aliceId && decodeLatin1 (B64.encode smId) == srvMsgId && mId == msgId + _ -> False + ackMessage bob aliceId msgId Nothing + liftIO $ threadDelay 200000 + checkEmptyQ bob aliceId True + (msgId1, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 1" + get alice ##> ("", bobId, SENT msgId1) + Just _ <- checkMsgQ bob aliceId 1 + (msgId2, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 2" + get alice ##> ("", bobId, SENT msgId2) + (msgId3, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 3" + get alice ##> ("", bobId, SENT msgId3) + (msgId4, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 4" + get alice ##> ("", bobId, SENT msgId4) + Just _ <- checkMsgQ bob aliceId 4 + (msgId5, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello: quota exceeded" + liftIO $ threadDelay 200000 + Just _ <- checkMsgQ bob aliceId 5 + get bob =##> \case ("", c, Msg' mId PQEncOn "hello 1") -> c == aliceId && mId == msgId1; _ -> False + ackMessage bob aliceId msgId1 Nothing + liftIO $ threadDelay 200000 + Just _ <- checkMsgQ bob aliceId 4 + get bob =##> \case ("", c, Msg' mId PQEncOn "hello 2") -> c == aliceId && mId == msgId2; _ -> False + ackMessage bob aliceId msgId2 Nothing + get bob =##> \case ("", c, Msg' mId PQEncOn "hello 3") -> c == aliceId && mId == msgId3; _ -> False + ackMessage bob aliceId msgId3 Nothing + liftIO $ threadDelay 200000 + Just _ <- checkMsgQ bob aliceId 2 + get bob =##> \case ("", c, Msg' mId PQEncOn "hello 4") -> c == aliceId && mId == msgId4; _ -> False + ackMessage bob aliceId msgId4 Nothing + liftIO $ threadDelay 200000 + Just _ <- checkMsgQ bob aliceId 1 -- the one that did not fit now accepted + get alice ##> ("", bobId, QCONT) + get alice ##> ("", bobId, SENT msgId5) + liftIO $ threadDelay 200000 + Just _srvMsgId <- checkQ bob aliceId True (Just QNoSub) 1 (Just MTMessage) + get bob =##> \case ("", c, Msg' mId PQEncOn "hello: quota exceeded") -> c == aliceId && mId == msgId5 + 1; _ -> False + ackMessage bob aliceId (msgId5 + 1) Nothing + liftIO $ threadDelay 200000 + checkEmptyQ bob aliceId True + pure () + where + checkEmptyQ c cId qiSnd' = do + r <- checkQ c cId qiSnd' (Just QNoSub) 0 Nothing + liftIO $ r `shouldBe` Nothing + checkMsgQ c cId qiSize' = do + r <- checkQ c cId True (Just QNoSub) qiSize' (Just MTMessage) + liftIO $ isJust r `shouldBe` True + pure r + checkQ c cId qiSnd' qiSubThread_ qiSize' msgType_ = do + ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c cId + liftIO $ do + qiSnd `shouldBe` qiSnd' + qiNtf `shouldBe` False + qSubThread <$> qiSub `shouldBe` qiSubThread_ + qiSize `shouldBe` qiSize' + msgId_ <- forM qiMsg $ \MsgInfo {msgId, msgType} -> msgId <$ (Just msgType `shouldBe` msgType_) + qDelivered <$> qiSub `shouldBe` Just msgId_ + pure msgId_ noNetworkDelay :: AgentClient -> IO () -noNetworkDelay a = (10000 >) <$> waitNetwork a `shouldReturn` True +noNetworkDelay a = do + d <- waitNetwork a + unless (d < 10000) $ expectationFailure $ "expected no delay, d = " <> show d networkDelay :: AgentClient -> Int64 -> IO () -networkDelay a d' = (\d -> d' < d && d < d' + 15000) <$> waitNetwork a `shouldReturn` True +networkDelay a d' = do + d <- waitNetwork a + unless (d' - 1000 < d && d < d' + 15000) $ expectationFailure $ "expected delay " <> show d' <> ", d = " <> show d waitNetwork :: AgentClient -> IO Int64 waitNetwork a = do t <- getCurrentTime - waitForUserNetwork a `runReaderT` agentEnv a + waitForUserNetwork a t' <- getCurrentTime pure $ diffToMicroseconds $ diffUTCTime t' t @@ -2716,7 +3178,7 @@ exchangeGreetings :: HasCallStack => AgentClient -> ConnId -> AgentClient -> Con exchangeGreetings = exchangeGreetings_ PQEncOn exchangeGreetings_ :: HasCallStack => PQEncryption -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () -exchangeGreetings_ pqEnc = exchangeGreetingsMsgId_ pqEnc 4 +exchangeGreetings_ pqEnc = exchangeGreetingsMsgId_ pqEnc 2 exchangeGreetingsMsgId :: HasCallStack => Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () exchangeGreetingsMsgId = exchangeGreetingsMsgId_ PQEncOn @@ -2749,3 +3211,16 @@ exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do get bob ##> ("", aliceId, SENT bobMsgId') get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False ackMessage alice bobId aliceMsgId' Nothing + +newtype InternalException e = InternalException {unInternalException :: e} + deriving (Eq, Show) + +instance Exception e => Exception (InternalException e) + +instance Exception e => MonadUnliftIO (ExceptT e IO) where + {-# INLINE withRunInIO #-} + withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b + withRunInIO inner = + ExceptT . fmap (first unInternalException) . try $ + withRunInIO $ \run -> + inner $ run . (either (throwIO . InternalException) pure <=< runExceptT) diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 2c1045791..92d97d641 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -5,22 +5,18 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module AgentTests.NotificationTests where -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) import AgentTests.FunctionalAPITests - ( agentCfgV7, + ( agentCfgVPrevPQ, createConnection, - exchangeGreetingsMsgId, + exchangeGreetings, get, - withAgent, - withAgentClients2, - withAgentClientsCfgServers2, - withAgentClients3, joinConnection, makeConnection, nGet, @@ -29,13 +25,18 @@ import AgentTests.FunctionalAPITests sendMessage, switchComplete, testServerMatrix2, + withAgent, + withAgentClients2, + withAgentClients3, withAgentClientsCfg2, + withAgentClientsCfgServers2, (##>), (=##>), pattern CON, pattern CONF, pattern INFO, pattern Msg, + pattern SENT, ) import Control.Concurrent (ThreadId, killThread, threadDelay) import Control.Monad @@ -49,20 +50,22 @@ import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Text.Encoding (encodeUtf8) +import Database.SQLite.Simple.QQ (sql) import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) -import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn) +import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) -import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO) -import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken) +import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT) +import Simplex.Messaging.Agent.Store.SQLite (closeSQLiteStore, getSavedNtfToken, reopenSQLiteStore, withTransaction) +import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..)) import Simplex.Messaging.Notifications.Protocol +import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..)) import Simplex.Messaging.Notifications.Server.Push.APNS -import Simplex.Messaging.Notifications.Types (NtfToken (..)) +import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..)) import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..)) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) @@ -70,7 +73,6 @@ import Simplex.Messaging.Transport (ATransport) import System.Directory (doesFileExist, removeFile) import Test.Hspec import UnliftIO -import Util removeFileIfExists :: FilePath -> IO () removeFileIfExists filePath = do @@ -89,9 +91,21 @@ notificationTests t = do it "should allow the second registration with different credentials and delete the first after verification" $ withAPNSMockServer $ \apns -> withNtfServer t $ testNtfTokenSecondRegistration apns - it "should re-register token when notification server is restarted" $ + it "should verify token after notification server is restarted" $ withAPNSMockServer $ \apns -> testNtfTokenServerRestart t apns + it "should re-verify token after notification server is restarted" $ + withAPNSMockServer $ \apns -> + testNtfTokenServerRestartReverify t apns + it "should re-verify token after notification server is restarted when first request timed-out" $ + withAPNSMockServer $ \apns -> + testNtfTokenServerRestartReverifyTimeout t apns + it "should re-register token when notification server is restarted" $ + withAPNSMockServer $ \apns -> + testNtfTokenServerRestartReregister t apns + it "should re-register token when notification server is restarted when first request timed-out" $ + withAPNSMockServer $ \apns -> + testNtfTokenServerRestartReregisterTimeout t apns it "should work with multiple configured servers" $ withAPNSMockServer $ \apns -> testNtfTokenMultipleServers t apns @@ -144,27 +158,27 @@ notificationTests t = do withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf -> testNotificationsNewToken apns ntf -testNtfMatrix :: ATransport -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> Spec +testNtfMatrix :: HasCallStack => ATransport -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec testNtfMatrix t runTest = do describe "next and current" $ do - it "next servers: SMP v7, NTF v2; next clients: v7/v2" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfgV7 agentCfgV7 runTest - it "next servers: SMP v7, NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfg runTest - it "curr servers: SMP v6, NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfg agentCfg agentCfg runTest - skip "this case cannot be supported - see RFC" $ - it "servers: SMP v6, NTF v1; clients: v7/v2 (not supported)" $ runNtfTestCfg t cfg ntfServerCfg agentCfgV7 agentCfgV7 runTest - -- servers can be migrated in any order - it "servers: next SMP v7, curr NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfg agentCfg agentCfg runTest - it "servers: curr SMP v6, next NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfgV2 agentCfg agentCfg runTest - -- clients can be partially migrated - it "servers: next SMP v7, curr NTF v2; clients: next/curr" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfgV7 agentCfg runTest - it "servers: next SMP v7, curr NTF v2; clients: curr/new" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfgV7 runTest + it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest + it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; curr clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest + -- servers can be upgraded in any order + it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + -- one of two clients can be upgraded + it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfg agentCfgVPrevPQ runTest + it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfg runTest -runNtfTestCfg :: ATransport -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> IO () -runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest = +runNtfTestCfg :: HasCallStack => ATransport -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () +runNtfTestCfg t baseId smpCfg ntfCfg aCfg bCfg runTest = do withSmpServerConfigOn t smpCfg testPort $ \_ -> withAPNSMockServer $ \apns -> withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t)]} $ \_ -> - withAgentClientsCfg2 aCfg bCfg $ runTest apns + withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId + threadDelay 100000 testNotificationToken :: APNSMockServer -> IO () testNotificationToken APNSMockServer {apnsQ} = do @@ -180,7 +194,7 @@ testNotificationToken APNSMockServer {apnsQ} = do NTActive <- checkNtfToken a tkn deleteNtfToken a tkn -- agent deleted this token - Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn + Left (CMD PROHIBITED _) <- tryE $ checkNtfToken a tkn pure () (.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString @@ -243,7 +257,7 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = -- now the second token registration is verified verifyNtfToken a' tkn nonce' verification' -- the first registration is removed - Left (NTF AUTH) <- tryE $ checkNtfToken a tkn + Left (NTF _ AUTH) <- tryE $ checkNtfToken a tkn -- and the second is active NTActive <- checkNtfToken a' tkn pure () @@ -252,27 +266,142 @@ testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO () testNtfTokenServerRestart t APNSMockServer {apnsQ} = do let tkn = DeviceToken PPApnsTest "abcd" ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a -> - withNtfServer t . runRight $ do + withNtfServerStoreLog t $ \_ -> runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- atomically $ readTBQueue apnsQ liftIO $ sendApnsResponse APNSRespOk pure ntfData - -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server + -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server threadDelay 1000000 withAgent 2 agentCfg initAgentServers testDB $ \a' -> -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token, -- so that repeat verification happens without restarting the clients, when notification arrives - withNtfServer t . runRight_ $ do + withNtfServerStoreLog t $ \_ -> runRight_ $ do verification <- ntfData .-> "verification" nonce <- C.cbNonce <$> ntfData .-> "nonce" - Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <- + verifyNtfToken a' tkn nonce verification + NTActive <- checkNtfToken a' tkn + pure () + +testNtfTokenServerRestartReverify :: ATransport -> APNSMockServer -> IO () +testNtfTokenServerRestartReverify t APNSMockServer {apnsQ} = do + let tkn = DeviceToken PPApnsTest "abcd" + withAgent 1 agentCfg initAgentServers testDB $ \a -> do + ntfData <- withNtfServerStoreLog t $ \_ -> runRight $ do + NTRegistered <- registerNtfToken a tkn NMPeriodic + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- atomically $ readTBQueue apnsQ - verification' <- ntfData' .-> "verification" - nonce' <- C.cbNonce <$> ntfData' .-> "nonce" - liftIO $ sendApnsResponse' APNSRespOk - verifyNtfToken a' tkn nonce' verification' + liftIO $ sendApnsResponse APNSRespOk + pure ntfData + runRight_ $ do + verification <- ntfData .-> "verification" + nonce <- C.cbNonce <$> ntfData .-> "nonce" + Left (BROKER _ NETWORK) <- tryE $ verifyNtfToken a tkn nonce verification + pure () + threadDelay 1000000 + withAgent 2 agentCfg initAgentServers testDB $ \a' -> + -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token, + -- so that repeat verification happens without restarting the clients, when notification arrives + withNtfServerStoreLog t $ \_ -> runRight_ $ do + NTActive <- registerNtfToken a' tkn NMPeriodic + NTActive <- checkNtfToken a' tkn + pure () + +testNtfTokenServerRestartReverifyTimeout :: ATransport -> APNSMockServer -> IO () +testNtfTokenServerRestartReverifyTimeout t APNSMockServer {apnsQ} = do + let tkn = DeviceToken PPApnsTest "abcd" + withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do + (nonce, verification) <- withNtfServerStoreLog t $ \_ -> runRight $ do + NTRegistered <- registerNtfToken a tkn NMPeriodic + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- + atomically $ readTBQueue apnsQ + liftIO $ sendApnsResponse APNSRespOk + verification <- ntfData .-> "verification" + nonce <- C.cbNonce <$> ntfData .-> "nonce" + verifyNtfToken a tkn nonce verification + pure (nonce, verification) + -- this emulates the situation when server verified token but the client did not receive the response + Just NtfToken {ntfTknStatus = NTActive, ntfTknAction = Just NTACheck, ntfDhSecret = Just dhSecret} <- withTransaction store getSavedNtfToken + Right code <- pure $ NtfRegCode <$> C.cbDecrypt dhSecret nonce verification + withTransaction store $ \db -> + DB.execute + db + [sql| + UPDATE ntf_tokens + SET tkn_status = ?, tkn_action = ? + WHERE provider = ? AND device_token = ? + |] + (NTConfirmed, Just (NTAVerify code), PPApnsTest, "abcd" :: ByteString) + Just NtfToken {ntfTknStatus = NTConfirmed, ntfTknAction = Just (NTAVerify _)} <- withTransaction store getSavedNtfToken + pure () + threadDelay 1000000 + withAgent 2 agentCfg initAgentServers testDB $ \a' -> + -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token, + -- so that repeat verification happens without restarting the clients, when notification arrives + withNtfServerStoreLog t $ \_ -> runRight_ $ do + NTActive <- registerNtfToken a' tkn NMPeriodic + NTActive <- checkNtfToken a' tkn + pure () + +testNtfTokenServerRestartReregister :: ATransport -> APNSMockServer -> IO () +testNtfTokenServerRestartReregister t APNSMockServer {apnsQ} = do + let tkn = DeviceToken PPApnsTest "abcd" + withAgent 1 agentCfg initAgentServers testDB $ \a -> + withNtfServerStoreLog t $ \_ -> runRight $ do + NTRegistered <- registerNtfToken a tkn NMPeriodic + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}, sendApnsResponse} <- + atomically $ readTBQueue apnsQ + liftIO $ sendApnsResponse APNSRespOk + -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server + threadDelay 1000000 + withAgent 2 agentCfg initAgentServers testDB $ \a' -> + -- server stopped before token is verified, and client might have lost verification notification. + -- so that repeat registration happens when client is restarted. + withNtfServerStoreLog t $ \_ -> runRight_ $ do + NTRegistered <- registerNtfToken a' tkn NMPeriodic + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- + atomically $ readTBQueue apnsQ + liftIO $ sendApnsResponse APNSRespOk + verification <- ntfData .-> "verification" + nonce <- C.cbNonce <$> ntfData .-> "nonce" + verifyNtfToken a' tkn nonce verification + NTActive <- checkNtfToken a' tkn + pure () + +testNtfTokenServerRestartReregisterTimeout :: ATransport -> APNSMockServer -> IO () +testNtfTokenServerRestartReregisterTimeout t APNSMockServer {apnsQ} = do + let tkn = DeviceToken PPApnsTest "abcd" + withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do + withNtfServerStoreLog t $ \_ -> runRight $ do + NTRegistered <- registerNtfToken a tkn NMPeriodic + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}, sendApnsResponse} <- + atomically $ readTBQueue apnsQ + liftIO $ sendApnsResponse APNSRespOk + -- this emulates the situation when server registered token but the client did not receive the response + withTransaction store $ \db -> + DB.execute + db + [sql| + UPDATE ntf_tokens + SET tkn_id = NULL, tkn_dh_secret = NULL, tkn_status = ?, tkn_action = ? + WHERE provider = ? AND device_token = ? + |] + (NTNew, Just NTARegister, PPApnsTest, "abcd" :: ByteString) + Just NtfToken {ntfTokenId = Nothing, ntfTknStatus = NTNew, ntfTknAction = Just NTARegister} <- withTransaction store getSavedNtfToken + pure () + threadDelay 1000000 + withAgent 2 agentCfg initAgentServers testDB $ \a' -> + -- server stopped before token is verified, and client might have lost verification notification. + -- so that repeat registration happens when client is restarted. + withNtfServerStoreLog t $ \_ -> runRight_ $ do + NTRegistered <- registerNtfToken a' tkn NMPeriodic + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- + atomically $ readTBQueue apnsQ + liftIO $ sendApnsResponse APNSRespOk + verification <- ntfData .-> "verification" + nonce <- C.cbNonce <$> ntfData .-> "nonce" + verifyNtfToken a' tkn nonce verification NTActive <- checkNtfToken a' tkn pure () @@ -333,6 +462,7 @@ testNtfTokenChangeServers t APNSMockServer {apnsQ} = getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated killThread ntf withNtfServerOn t ntfTestPort2 $ runRight_ $ do + liftIO $ threadDelay 1000000 -- for notification server to reconnect tkn <- registerTestToken a "qwer" NMInstant apnsQ checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive @@ -342,8 +472,8 @@ testRunNTFServerTests t srv = withAgent 1 agentCfg initAgentServers testDB $ \a -> testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing -testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () -testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg}} bob = do +testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () +testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do (bobId, aliceId, nonce, message) <- runRight $ do -- establish connection (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -372,13 +502,23 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen pure (bobId, aliceId, nonce, message) -- alice client already has subscription for the connection - Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message + Left (CMD PROHIBITED _) <- runExceptT $ getNotificationMessage alice nonce message + + threadDelay 500000 + suspendAgent alice 0 + closeSQLiteStore store + threadDelay 500000 -- aliceNtf client doesn't have subscription and is allowed to get notification message withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message pure () + threadDelay 500000 + reopenSQLiteStore store + foregroundAgent alice + threadDelay 500000 + runRight_ $ do get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False ackMessage alice bobId (baseId + 1) Nothing @@ -391,11 +531,10 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen -- no notifications should follow noNotification apnsQ where - baseId = 3 msgId = subtract baseId -testNotificationSubscriptionNewConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () -testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob = +testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () +testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} baseId alice bob = runRight_ $ do -- alice registers notification token DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ @@ -413,9 +552,9 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob = allowConnection alice bobId confId "alice's connInfo" void $ messageNotificationData bob apnsQ get bob ##> ("", aliceId, INFO "alice's connInfo") - void $ messageNotificationData alice apnsQ + when (baseId == 3) $ void $ messageNotificationData alice apnsQ get alice ##> ("", bobId, CON) - void $ messageNotificationData bob apnsQ + when (baseId == 3) $ void $ messageNotificationData bob apnsQ get bob ##> ("", aliceId, CON) -- bob sends message 1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello" @@ -432,7 +571,6 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob = -- no unexpected notifications should follow noNotification apnsQ where - baseId = 3 msgId = subtract baseId registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken @@ -507,7 +645,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = -- no notifications should follow noNotification apnsQ where - baseId = 3 + baseId = 1 msgId = subtract baseId testChangeToken :: APNSMockServer -> IO () @@ -546,7 +684,7 @@ testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers t -- no notifications should follow noNotification apnsQ where - baseId = 3 + baseId = 1 msgId = subtract baseId testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO () @@ -555,11 +693,11 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apnsQ liftIO $ threadDelay 250000 - 4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" - get bob ##> ("", aliceId, SENT 4) + 2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" + get bob ##> ("", aliceId, SENT 2) void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False - ackMessage alice bobId 4 Nothing + ackMessage alice bobId 2 Nothing liftIO $ killThread threadId pure (aliceId, bobId) @@ -567,8 +705,8 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice withNtfServerStoreLog t $ \threadId -> runRight_ $ do liftIO $ threadDelay 250000 - 5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" - get bob ##> ("", aliceId, SENT 5) + 3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" + get bob ##> ("", aliceId, SENT 3) void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId @@ -579,11 +717,11 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alic (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apnsQ liftIO $ threadDelay 250000 - 4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" - get bob ##> ("", aliceId, SENT 4) + 2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" + get bob ##> ("", aliceId, SENT 2) void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False - ackMessage alice bobId 4 Nothing + ackMessage alice bobId 2 Nothing liftIO $ killThread threadId pure (aliceId, bobId) @@ -595,8 +733,8 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alic nGet alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False nGet bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False liftIO $ threadDelay 1000000 - 5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" - get bob ##> ("", aliceId, SENT 5) + 3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" + get bob ##> ("", aliceId, SENT 3) _ <- messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId @@ -651,7 +789,7 @@ testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO () testSwitchNotifications servers APNSMockServer {apnsQ} = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId _ <- registerTestToken a "abcd" NMInstant apnsQ liftIO $ threadDelay 250000 let testMessage msg = do @@ -726,7 +864,7 @@ messageNotification apnsQ = do pure (nonce, message) _ -> error "bad notification" -messageNotificationData :: AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData +messageNotificationData :: HasCallStack => AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData messageNotificationData c apnsQ = do (nonce, message) <- messageNotification apnsQ NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 4bac4fb83..39a4b1b95 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -5,8 +5,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -17,6 +17,7 @@ module AgentTests.SQLiteTests (storeTests) where import AgentTests.EqInstances () import Control.Concurrent.Async (concurrently_) +import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception (SomeException) import Control.Monad (replicateM_) @@ -45,9 +46,9 @@ import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR -import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Protocol (SubscriptionMode (..), pattern VersionSMPC) import qualified Simplex.Messaging.Protocol as SMP @@ -88,7 +89,7 @@ removeStore db = do removeFile $ dbFilePath db where close :: SQLiteStore -> IO () - close st = mapM_ DB.close =<< atomically (tryTakeTMVar $ dbConnection st) + close st = mapM_ DB.close =<< tryTakeMVar (dbConnection st) storeTests :: Spec storeTests = do @@ -196,6 +197,9 @@ cData1 = testPrivateAuthKey :: C.APrivateAuthKey testPrivateAuthKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" +testPublicAuthKey :: C.APublicAuthKey +testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe") + testPrivDhKey :: C.PrivateKeyX25519 testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk" @@ -217,6 +221,7 @@ rcvQueue1 = e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, sndId = "2345", + sndSecure = True, status = New, dbQueueId = DBNewQueue, primary = True, @@ -234,7 +239,8 @@ sndQueue1 = connId = "conn1", server = smpServer1, sndId = "3456", - sndPublicKey = Nothing, + sndSecure = True, + sndPublicKey = testPublicAuthKey, sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, e2eDhSecret = testDhSecret, @@ -378,7 +384,8 @@ testUpgradeRcvConnToDuplex = connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, sndId = "2345", - sndPublicKey = Nothing, + sndSecure = True, + sndPublicKey = testPublicAuthKey, sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, e2eDhSecret = testDhSecret, @@ -411,6 +418,7 @@ testUpgradeSndConnToDuplex = e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, sndId = "4567", + sndSecure = True, status = New, dbQueueId = DBNewQueue, rcvSwchStatus = Nothing, @@ -662,7 +670,7 @@ testGetPendingServerCommand st = do Right (Just PendingCommand {corrId = corrId'}) <- getPendingServerCommand db (Just smpServer1) corrId' `shouldBe` "4" where - command = AClientCommand $ APC SAEConn $ NEW True (ACM SCMInvitation) (IKNoPQ PQSupportOn) SMSubscribe + command = AClientCommand $ NEW True (ACM SCMInvitation) (IKNoPQ PQSupportOn) SMSubscribe corruptCmd :: DB.Connection -> ByteString -> ConnId -> IO () corruptCmd db corrId connId = DB.execute db "UPDATE commands SET command = cast('bad' as blob) WHERE conn_id = ? AND corr_id = ?" (connId, corrId) @@ -708,15 +716,15 @@ testGetNextRcvChunkToDownload st = do withTransaction st $ \db -> do Right Nothing <- getNextRcvChunkToDownload db xftpServer1 86400 - Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) + Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1" - Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) + Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True Left e <- getNextRcvChunkToDownload db xftpServer1 86400 show e `shouldContain` "ConversionFailed" DB.query_ db "SELECT rcv_file_id FROM rcv_files WHERE failed = 1" `shouldReturn` [Only (1 :: Int)] - Right (Just RcvFileChunk {rcvFileEntityId}) <- getNextRcvChunkToDownload db xftpServer1 86400 + Right (Just (RcvFileChunk {rcvFileEntityId}, _)) <- getNextRcvChunkToDownload db xftpServer1 86400 rcvFileEntityId `shouldBe` fId2 testGetNextRcvFileToDecrypt :: SQLiteStore -> Expectation @@ -725,10 +733,10 @@ testGetNextRcvFileToDecrypt st = do withTransaction st $ \db -> do Right Nothing <- getNextRcvFileToDecrypt db 86400 - Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) + Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True DB.execute_ db "UPDATE rcv_files SET status = 'received' WHERE rcv_file_id = 1" DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1" - Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) + Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True DB.execute_ db "UPDATE rcv_files SET status = 'received' WHERE rcv_file_id = 2" Left e <- getNextRcvFileToDecrypt db 86400 diff --git a/tests/CLITests.hs b/tests/CLITests.hs index 3bc48c5ce..1310665ee 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -57,7 +57,7 @@ smpServerTest :: Bool -> Bool -> IO () smpServerTest storeLog basicAuth = do -- init capture_ (withArgs (["init", "-y"] <> ["-l" | storeLog] <> ["--no-password" | not basicAuth]) $ smpServerCLI cfgPath logPath) - >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> cfgPath <> "/smp-server.ini") `isPrefixOf`)) + >>= (`shouldSatisfy` (("Server initialized, please provide additional server information in " <> cfgPath <> "/smp-server.ini") `isPrefixOf`)) Right ini <- readIniFile $ cfgPath <> "/smp-server.ini" lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off") lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off" @@ -77,13 +77,13 @@ smpServerTest storeLog basicAuth = do let certPath = cfgPath "server.crt" oldCrt@X.Certificate {} <- XF.readSignedObject certPath >>= \case - [cert] -> pure . X.signedObject $ X.getSigned cert + [cert'] -> pure . X.signedObject $ X.getSigned cert' _ -> error "bad crt format" r' <- lines <$> capture_ (withArgs ["cert"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ())) r' `shouldContain` ["Generated new server credentials"] newCrt <- XF.readSignedObject certPath >>= \case - [cert] -> pure . X.signedObject $ X.getSigned cert + [cert'] -> pure . X.signedObject $ X.getSigned cert' _ -> error "bad crt format after cert" X.certSignatureAlg oldCrt `shouldBe` X.certSignatureAlg newCrt X.certSubjectDN oldCrt `shouldBe` X.certSubjectDN newCrt diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 5a60a1635..caab0637a 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -281,12 +281,12 @@ randomSUB_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSM randomSUB_ a v sessId = do g <- C.newRandom rId <- atomically $ C.randomBytes 24 g - corrId <- atomically $ CorrId <$> C.randomBytes 24 g + nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g (rKey, rpKey) <- atomically $ C.generateAuthKeyPair a g thAuth_ <- testTHandleAuth v g rKey let thParams = testTHandleParams v sessId - TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, rId, Cmd SRecipient SUB) - pure $ (,tToSend) <$> authTransmission thAuth_ (Just rpKey) corrId tForAuth + TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, rId, Cmd SRecipient SUB) + pure $ (,tToSend) <$> authTransmission thAuth_ (Just rpKey) nonce tForAuth randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) randomSUBCmd = randomSUBCmd_ C.SEd25519 @@ -311,13 +311,13 @@ randomSEND_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionS randomSEND_ a v sessId len = do g <- C.newRandom sId <- atomically $ C.randomBytes 24 g - corrId <- atomically $ CorrId <$> C.randomBytes 3 g + nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g (sKey, spKey) <- atomically $ C.generateAuthKeyPair a g thAuth_ <- testTHandleAuth v g sKey msg <- atomically $ C.randomBytes len g let thParams = testTHandleParams v sessId - TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, sId, Cmd SSender $ SEND noMsgFlags msg) - pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) corrId tForAuth + TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, sId, Cmd SSender $ SEND noMsgFlags msg) + pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) nonce tForAuth testTHandleParams :: VersionSMP -> ByteString -> THandleParams SMPVersion 'TClient testTHandleParams v sessionId = @@ -325,6 +325,7 @@ testTHandleParams v sessionId = { sessionId, blockSize = smpBlockSize, thVersion = v, + thServerVRange = supportedServerSMPRelayVRange, thAuth = Nothing, implySessId = v >= authCmdsSMPVersion, batch = True diff --git a/tests/CoreTests/ProtocolErrorTests.hs b/tests/CoreTests/ProtocolErrorTests.hs deleted file mode 100644 index 7b1a7b813..000000000 --- a/tests/CoreTests/ProtocolErrorTests.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module CoreTests.ProtocolErrorTests where - -import qualified Data.ByteString.Char8 as B -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import GHC.Generics (Generic) -import Generic.Random (genericArbitraryU) -import Simplex.FileTransfer.Transport (XFTPErrorType (..)) -import Simplex.Messaging.Agent.Protocol -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 - -protocolErrorTests :: Spec -protocolErrorTests = modifyMaxSuccess (const 1000) $ do - describe "errors parsing / serializing" $ do - it "should parse SMP protocol errors" . property $ \(err :: ErrorType) -> - smpDecode (smpEncode err) == Right err - it "should parse SMP agent errors" . property $ \(err :: AgentErrorType) -> - errHasSpaces err - || strDecode (strEncode err) == Right err - where - errHasSpaces = \case - BROKER srv (RESPONSE e) -> hasSpaces srv || hasSpaces e - BROKER srv _ -> hasSpaces srv - _ -> False - hasSpaces s = ' ' `B.elem` encodeUtf8 (T.pack s) - -deriving instance Generic AgentErrorType - -deriving instance Generic CommandErrorType - -deriving instance Generic ConnectionErrorType - -deriving instance Generic BrokerErrorType - -deriving instance Generic SMPAgentError - -deriving instance Generic AgentCryptoError - -deriving instance Generic ErrorType - -deriving instance Generic CommandError - -deriving instance Generic TransportError - -deriving instance Generic HandshakeError - -deriving instance Generic XFTPErrorType - -deriving instance Generic RCErrorType - -instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU - -instance Arbitrary CommandErrorType where arbitrary = genericArbitraryU - -instance Arbitrary ConnectionErrorType where arbitrary = genericArbitraryU - -instance Arbitrary BrokerErrorType where arbitrary = genericArbitraryU - -instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU - -instance Arbitrary AgentCryptoError where arbitrary = genericArbitraryU - -instance Arbitrary ErrorType where arbitrary = genericArbitraryU - -instance Arbitrary CommandError where arbitrary = genericArbitraryU - -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/CoreTests/TRcvQueuesTests.hs b/tests/CoreTests/TRcvQueuesTests.hs index 91722228b..9f7c4932e 100644 --- a/tests/CoreTests/TRcvQueuesTests.hs +++ b/tests/CoreTests/TRcvQueuesTests.hs @@ -22,10 +22,13 @@ tRcvQueuesTests = do describe "connection API" $ do it "hasConn" hasConnTest it "hasConn, batch add" hasConnTestBatch + it "hasConn, batch idempotent" batchIdempotentTest it "deleteConn" deleteConnTest describe "session API" $ do it "getSessQueues" getSessQueuesTest it "getDelSessQueues" getDelSessQueuesTest + describe "queue transfer" $ do + it "getDelSessQueues-batchAddQueues preserves total length" removeSubsTest checkDataInvariant :: RQ.TRcvQueues -> IO Bool checkDataInvariant trq = atomically $ do @@ -62,6 +65,19 @@ hasConnTestBatch = do atomically (RQ.hasConn "c3" trq) `shouldReturn` True atomically (RQ.hasConn "nope" trq) `shouldReturn` False +batchIdempotentTest :: IO () +batchIdempotentTest = do + trq <- atomically RQ.empty + let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1", dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@beta" "c3"] + atomically $ RQ.batchAddQueues trq qs + checkDataInvariant trq `shouldReturn` True + qs' <- readTVarIO $ RQ.getRcvQueues trq + cs' <- readTVarIO $ RQ.getConnections trq + atomically $ RQ.batchAddQueues trq qs + checkDataInvariant trq `shouldReturn` True + readTVarIO (RQ.getRcvQueues trq) `shouldReturn` qs' + fmap L.nub <$> readTVarIO (RQ.getConnections trq) `shouldReturn`cs' -- connections get duplicated, but that doesn't appear to affect anybody + deleteConnTest :: IO () deleteConnTest = do trq <- atomically RQ.empty @@ -121,6 +137,40 @@ getDelSessQueuesTest = do atomically (RQ.hasConn "c3" trq) `shouldReturn` True atomically (RQ.hasConn "c4" trq) `shouldReturn` True +removeSubsTest :: IO () +removeSubsTest = do + aq <- atomically RQ.empty + let qs = + [ dummyRQ 0 "smp://1234-w==@alpha" "c1", + dummyRQ 0 "smp://1234-w==@alpha" "c2", + dummyRQ 0 "smp://1234-w==@beta" "c3", + dummyRQ 1 "smp://1234-w==@beta" "c4" + ] + atomically $ RQ.batchAddQueues aq qs + + pq <- atomically RQ.empty + atomically (totalSize aq pq) `shouldReturn` (4, 4) + + atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) aq >>= RQ.batchAddQueues pq . fst + atomically (totalSize aq pq) `shouldReturn` (4, 4) + + atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@beta", Just "non-existent") aq >>= RQ.batchAddQueues pq . fst + atomically (totalSize aq pq) `shouldReturn` (4, 4) + + atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@localhost", Nothing) aq >>= RQ.batchAddQueues pq . fst + atomically (totalSize aq pq) `shouldReturn` (4, 4) + + atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@beta", Just "c3") aq >>= RQ.batchAddQueues pq . fst + atomically (totalSize aq pq) `shouldReturn` (4, 4) + +totalSize :: RQ.TRcvQueues -> RQ.TRcvQueues -> STM (Int, Int) +totalSize a b = do + qsizeA <- M.size <$> readTVar (RQ.getRcvQueues a) + qsizeB <- M.size <$> readTVar (RQ.getRcvQueues b) + csizeA <- M.size <$> readTVar (RQ.getConnections a) + csizeB <- M.size <$> readTVar (RQ.getConnections b) + pure (qsizeA + qsizeB, csizeA + csizeB) + dummyRQ :: UserId -> SMPServer -> ConnId -> RcvQueue dummyRQ userId server connId = RcvQueue @@ -133,6 +183,7 @@ dummyRQ userId server connId = e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk", e2eDhSecret = Nothing, sndId = "", + sndSecure = True, status = New, dbQueueId = DBQueueId 0, primary = True, diff --git a/tests/CoreTests/UtilTests.hs b/tests/CoreTests/UtilTests.hs index 9e413e838..2254ecafd 100644 --- a/tests/CoreTests/UtilTests.hs +++ b/tests/CoreTests/UtilTests.hs @@ -2,11 +2,11 @@ module CoreTests.UtilTests where +import AgentTests.FunctionalAPITests () import Control.Exception (Exception, SomeException, throwIO) import Control.Monad.Except import Control.Monad.IO.Class import Data.IORef -import Simplex.Messaging.Client.Agent () import Simplex.Messaging.Util import Test.Hspec import qualified UnliftIO.Exception as UE diff --git a/tests/CoreTests/VersionRangeTests.hs b/tests/CoreTests/VersionRangeTests.hs index cef556376..ff53cc6ca 100644 --- a/tests/CoreTests/VersionRangeTests.hs +++ b/tests/CoreTests/VersionRangeTests.hs @@ -6,6 +6,7 @@ module CoreTests.VersionRangeTests where +import Data.Word (Word16) import GHC.Generics (Generic) import Generic.Random (genericArbitraryU) import Simplex.Messaging.Version @@ -38,6 +39,28 @@ versionRangeTests = modifyMaxSuccess (const 1000) $ do (vr 1 3, vr 2 3) `compatible` Just (Version 3) (vr 1 3, vr 2 4) `compatible` Just (Version 3) (vr 1 2, vr 3 4) `compatible` Nothing + it "should choose mutually compatible version range (range intersection)" $ do + (vr 1 1, vr 1 1) `compatibleVR` Just (vr 1 1) + (vr 1 1, vr 1 2) `compatibleVR` Just (vr 1 1) + (vr 1 2, vr 1 2) `compatibleVR` Just (vr 1 2) + (vr 1 2, vr 2 3) `compatibleVR` Just (vr 2 2) + (vr 1 3, vr 2 3) `compatibleVR` Just (vr 2 3) + (vr 1 3, vr 2 4) `compatibleVR` Just (vr 2 3) + (vr 1 2, vr 3 4) `compatibleVR` Nothing + it "should choose compatible version range with changed max version (capped range)" $ do + (vr 1 1, 1) `compatibleVR'` Just (vr 1 1) + (vr 1 1, 2) `compatibleVR'` Nothing + (vr 1 2, 2) `compatibleVR'` Just (vr 1 2) + (vr 1 2, 3) `compatibleVR'` Nothing + (vr 1 3, 2) `compatibleVR'` Just (vr 1 2) + (vr 1 3, 3) `compatibleVR'` Just (vr 1 3) + (vr 1 3, 4) `compatibleVR'` Nothing + (vr 2 3, 1) `compatibleVR'` Nothing + (vr 2 3, 2) `compatibleVR'` Just (vr 2 2) + (vr 2 3, 3) `compatibleVR'` Just (vr 2 3) + (vr 2 4, 1) `compatibleVR'` Nothing + (vr 2 4, 3) `compatibleVR'` Just (vr 2 3) + (vr 2 4, 4) `compatibleVR'` Just (vr 2 4) it "should check if version is compatible" $ do isCompatible @T (Version 1) (vr 1 2) `shouldBe` True isCompatible @T (Version 2) (vr 1 2) `shouldBe` True @@ -63,3 +86,16 @@ versionRangeTests = modifyMaxSuccess (const 1000) $ do case compatibleVersion vr1 vr2 of Just (Compatible v') -> Just v' `shouldBe` v Nothing -> Nothing `shouldBe` v + compatibleVR :: (VersionRange T, VersionRange T) -> Maybe (VersionRange T) -> Expectation + (vr1, vr2) `compatibleVR` vr' = do + (vr1, vr2) `checkCompatibleVR` vr' + (vr2, vr1) `checkCompatibleVR` vr' + (vr1, vr2) `checkCompatibleVR` vr' = + case compatibleVRange vr1 vr2 of + Just (Compatible vr'') -> Just vr'' `shouldBe` vr' + Nothing -> Nothing `shouldBe` vr' + compatibleVR' :: (VersionRange T, Word16) -> Maybe (VersionRange T) -> Expectation + (vr1, v2) `compatibleVR'` vr' = + case compatibleVRange' vr1 (Version v2) of + Just (Compatible vr'') -> Just vr'' `shouldBe` vr' + Nothing -> Nothing `shouldBe` vr' diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 46a199777..9bd124e55 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -28,7 +28,7 @@ import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Server as H import Network.Socket -import SMPClient (serverBracket) +import SMPClient (prevRange, serverBracket) import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C @@ -45,7 +45,7 @@ import Simplex.Messaging.Transport.Client import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams) import Simplex.Messaging.Transport.HTTP2.Server import Simplex.Messaging.Transport.Server -import Simplex.Messaging.Version (mkVersionRange) +import qualified Simplex.Messaging.Transport.Server as Server import Test.Hspec import UnliftIO.Async import UnliftIO.Concurrent @@ -87,7 +87,7 @@ ntfServerCfg = clientQSize = 1, subQSize = 1, pushQSize = 1, - smpAgentCfg = defaultSMPClientAgentConfig, + smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0}, apnsConfig = defaultAPNSPushClientConfig { apnsPort = apnsTestPort, @@ -106,15 +106,19 @@ ntfServerCfg = serverStatsLogFile = "tests/ntf-server-stats.daily.log", serverStatsBackupFile = Nothing, ntfServerVRange = supportedServerNTFVRange, - transportConfig = defaultTransportServerConfig + transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes} } -ntfServerCfgV2 :: NtfServerConfig -ntfServerCfgV2 = +ntfServerCfgVPrev :: NtfServerConfig +ntfServerCfgVPrev = ntfServerCfg - { ntfServerVRange = mkVersionRange initialNTFVersion authBatchCmdsNTFVersion, - smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}} + { ntfServerVRange = prevRange $ ntfServerVRange ntfServerCfg, + smpAgentCfg = smpAgentCfg' {smpCfg = smpCfg' {serverVRange = prevRange serverVRange'}} } + where + smpAgentCfg' = smpAgentCfg ntfServerCfg + smpCfg' = smpCfg smpAgentCfg' + serverVRange' = serverVRange smpCfg' withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t)]} diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 5ff9197cb..e0de57466 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -10,53 +10,21 @@ module SMPAgentClient where -import Control.Monad -import Control.Monad.IO.Unlift -import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import qualified Database.SQLite.Simple as SQL -import Network.Socket (ServiceName) import NtfClient (ntfTestPort) -import SMPClient - ( serverBracket, - testKeyHash, - testPort, - testPort2, - withSmpServer, - withSmpServerOn, - withSmpServerThreadOn, - ) +import SMPClient (proxyVRangeV8, testPort) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval -import Simplex.Messaging.Agent.Server (runSMPAgentBlocking) -import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew)) -import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') -import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig, defaultSMPClientConfig) +import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback, SMPProxyMode, defaultNetworkConfig, defaultSMPClientConfig) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) -import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth) +import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer) import Simplex.Messaging.Transport -import Simplex.Messaging.Transport.Client -import Test.Hspec -import UnliftIO.Concurrent -import UnliftIO.Directory import XFTPClient (testXFTPServer) -agentTestHost :: NonEmpty TransportHost -agentTestHost = "localhost" - -agentTestPort :: ServiceName -agentTestPort = "5010" - -agentTestPort2 :: ServiceName -agentTestPort2 = "5011" - -agentTestPort3 :: ServiceName -agentTestPort3 = "5012" - testDB :: FilePath testDB = "tests/tmp/smp-agent.test.protocol.db" @@ -66,114 +34,6 @@ testDB2 = "tests/tmp/smp-agent2.test.protocol.db" testDB3 :: FilePath testDB3 = "tests/tmp/smp-agent3.test.protocol.db" -smpAgentTest :: forall c. Transport c => TProxy c -> ARawTransmission -> IO ARawTransmission -smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> get h - where - get h = do - t@(_, _, cmdStr) <- tGetRaw h - case parseAll networkCommandP cmdStr of - Right (ACmd SAgent _ CONNECT {}) -> get h - Right (ACmd SAgent _ DISCONNECT {}) -> get h - _ -> pure t - -runSmpAgentTest :: forall c a. Transport c => (c -> IO a) -> IO a -runSmpAgentTest test = withSmpServer t . withSmpAgent t $ testSMPAgentClient test - where - t = transport @c - -runSmpAgentServerTest :: forall c a. Transport c => ((ThreadId, ThreadId) -> c -> IO a) -> IO a -runSmpAgentServerTest test = - withSmpServerThreadOn t testPort $ - \server -> withSmpAgentThreadOn t (agentTestPort, testPort, testDB) $ - \agent -> testSMPAgentClient $ test (server, agent) - where - t = transport @c - -smpAgentServerTest :: Transport c => ((ThreadId, ThreadId) -> c -> IO ()) -> Expectation -smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` () - -runSmpAgentTestN :: forall c a. Transport c => [(ServiceName, ServiceName, FilePath)] -> ([c] -> IO a) -> IO a -runSmpAgentTestN agents test = withSmpServer t $ run agents [] - where - run :: [(ServiceName, ServiceName, FilePath)] -> [c] -> IO a - run [] hs = test hs - run (a@(p, _, _) : as) hs = withSmpAgentOn t a $ testSMPAgentClientOn p $ \h -> run as (h : hs) - t = transport @c - -runSmpAgentTestN_1 :: forall c a. Transport c => Int -> ([c] -> IO a) -> IO a -runSmpAgentTestN_1 nClients test = withSmpServer t . withSmpAgent t $ run nClients [] - where - run :: Int -> [c] -> IO a - run 0 hs = test hs - run n hs = testSMPAgentClient $ \h -> run (n - 1) (h : hs) - t = transport @c - -smpAgentTestN :: Transport c => [(ServiceName, ServiceName, FilePath)] -> ([c] -> IO ()) -> Expectation -smpAgentTestN agents test' = runSmpAgentTestN agents test' `shouldReturn` () - -smpAgentTestN_1 :: Transport c => Int -> ([c] -> IO ()) -> Expectation -smpAgentTestN_1 n test' = runSmpAgentTestN_1 n test' `shouldReturn` () - -smpAgentTest2_2_2 :: forall c. Transport c => (c -> c -> IO ()) -> Expectation -smpAgentTest2_2_2 test' = - withSmpServerOn (transport @c) testPort2 $ - smpAgentTest2_2_2_needs_server test' - -smpAgentTest2_2_2_needs_server :: forall c. Transport c => (c -> c -> IO ()) -> Expectation -smpAgentTest2_2_2_needs_server test' = - smpAgentTestN - [ (agentTestPort, testPort, testDB), - (agentTestPort2, testPort2, testDB2) - ] - _test - where - _test [h1, h2] = test' h1 h2 - _test _ = error "expected 2 handles" - -smpAgentTest2_2_1 :: Transport c => (c -> c -> IO ()) -> Expectation -smpAgentTest2_2_1 test' = - smpAgentTestN - [ (agentTestPort, testPort, testDB), - (agentTestPort2, testPort, testDB2) - ] - _test - where - _test [h1, h2] = test' h1 h2 - _test _ = error "expected 2 handles" - -smpAgentTest2_1_1 :: Transport c => (c -> c -> IO ()) -> Expectation -smpAgentTest2_1_1 test' = smpAgentTestN_1 2 _test - where - _test [h1, h2] = test' h1 h2 - _test _ = error "expected 2 handles" - -smpAgentTest3 :: Transport c => (c -> c -> c -> IO ()) -> Expectation -smpAgentTest3 test' = - smpAgentTestN - [ (agentTestPort, testPort, testDB), - (agentTestPort2, testPort, testDB2), - (agentTestPort3, testPort, testDB3) - ] - _test - where - _test [h1, h2, h3] = test' h1 h2 h3 - _test _ = error "expected 3 handles" - -smpAgentTest3_1_1 :: Transport c => (c -> c -> c -> IO ()) -> Expectation -smpAgentTest3_1_1 test' = smpAgentTestN_1 3 _test - where - _test [h1, h2, h3] = test' h1 h2 h3 - _test _ = error "expected 3 handles" - -smpAgentTest1_1_1 :: forall c. Transport c => (c -> IO ()) -> Expectation -smpAgentTest1_1_1 test' = - smpAgentTestN - [(agentTestPort2, testPort2, testDB2)] - _test - where - _test [h] = test' h - _test _ = error "expected 1 handle" - testSMPServer :: SMPServer testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001" @@ -189,25 +49,29 @@ testNtfServer2 = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6 initAgentServers :: InitialAgentServers initAgentServers = InitialAgentServers - { smp = userServers [noAuthSrv testSMPServer], + { smp = userServers [testSMPServer], ntf = [testNtfServer], - xftp = userServers [noAuthSrv testXFTPServer], + xftp = userServers [testXFTPServer], netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000} } initAgentServers2 :: InitialAgentServers -initAgentServers2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer, noAuthSrv testSMPServer2]} +initAgentServers2 = initAgentServers {smp = userServers [testSMPServer, testSMPServer2]} + +initAgentServersProxy :: SMPProxyMode -> SMPProxyFallback -> InitialAgentServers +initAgentServersProxy smpProxyMode smpProxyFallback = + initAgentServers {netCfg = (netCfg initAgentServers) {smpProxyMode, smpProxyFallback}} agentCfg :: AgentConfig agentCfg = defaultAgentConfig - { tcpPort = Just agentTestPort, + { tcpPort = Nothing, tbqSize = 4, -- database = testDB, smpCfg = defaultSMPClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS), networkConfig}, ntfCfg = defaultNTFClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS), networkConfig}, reconnectInterval = fastRetryInterval, - xftpNotifyErrsOnRetry = False, + persistErrorInterval = 1, ntfWorkerDelay = 100, ntfSMPWorkerDelay = 100, caCertificateFile = "tests/fixtures/ca.crt", @@ -217,45 +81,20 @@ agentCfg = where networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000} +agentProxyCfgV8 :: AgentConfig +agentProxyCfgV8 = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRangeV8}} + fastRetryInterval :: RetryInterval fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000} fastMessageRetryInterval :: RetryInterval2 fastMessageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval} -withSmpAgentThreadOn_ :: ATransport -> (ServiceName, ServiceName, FilePath) -> Int -> IO () -> (ThreadId -> IO a) -> IO a -withSmpAgentThreadOn_ t (port', smpPort', db') initClientId afterProcess = - let cfg' = agentCfg {tcpPort = Just port'} - initServers' = initAgentServers {smp = userServers [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]} - in serverBracket - ( \started -> do - Right st <- liftIO $ createAgentStore db' "" False MCError - when (dbNew st) . liftIO $ withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1)") - runSMPAgentBlocking t cfg' initServers' st initClientId started - ) - afterProcess +userServers :: NonEmpty (ProtocolServer p) -> Map UserId (NonEmpty (ServerCfg p)) +userServers = userServers' . L.map noAuthSrv -userServers :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ProtoServerWithAuth p)) -userServers srvs = M.fromList [(1, srvs)] +userServers' :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ServerCfg p)) +userServers' srvs = M.fromList [(1, L.map (presetServerCfg True) srvs)] -withSmpAgentThreadOn :: ATransport -> (ServiceName, ServiceName, FilePath) -> (ThreadId -> IO a) -> IO a -withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a 0 $ removeFile db' - -withSmpAgentOn :: ATransport -> (ServiceName, ServiceName, FilePath) -> IO a -> IO a -withSmpAgentOn t (port', smpPort', db') = withSmpAgentThreadOn t (port', smpPort', db') . const - -withSmpAgent :: ATransport -> IO a -> IO a -withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB) - -testSMPAgentClientOn :: Transport c => ServiceName -> (c -> IO a) -> IO a -testSMPAgentClientOn port' client = do - Right useHost <- pure $ chooseTransportHost defaultNetworkConfig agentTestHost - runTransportClient defaultTransportClientConfig Nothing useHost port' (Just testKeyHash) $ \h -> do - line <- getLn h - if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion - then client h - else do - error $ "wrong welcome message: " <> B.unpack line - -testSMPAgentClient :: Transport c => (c -> IO a) -> IO a -testSMPAgentClient = testSMPAgentClientOn agentTestPort +noAuthSrvCfg :: ProtocolServer p -> ServerCfg p +noAuthSrvCfg = presetServerCfg True . noAuthSrv diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index cf222c3b4..736016b3b 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -16,7 +16,8 @@ import Control.Monad.Except (runExceptT) import Data.ByteString.Char8 (ByteString) import Data.List.NonEmpty (NonEmpty) import Network.Socket -import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig) +import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig) +import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol @@ -24,8 +25,11 @@ import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client +import qualified Simplex.Messaging.Transport.Client as Client import Simplex.Messaging.Transport.Server -import Simplex.Messaging.Version (mkVersionRange) +import qualified Simplex.Messaging.Transport.Server as Server +import Simplex.Messaging.Version +import Simplex.Messaging.Version.Internal import System.Environment (lookupEnv) import System.Info (os) import Test.Hspec @@ -56,6 +60,9 @@ testStoreLogFile2 = "tests/tmp/smp-server-store.log.2" testStoreMsgsFile :: FilePath testStoreMsgsFile = "tests/tmp/smp-server-messages.log" +testStoreMsgsFile2 :: FilePath +testStoreMsgsFile2 = "tests/tmp/smp-server-messages.log.2" + testServerStatsBackupFile :: FilePath testServerStatsBackupFile = "tests/tmp/smp-server-stats.log" @@ -73,10 +80,19 @@ testSMPClient = testSMPClientVR supportedClientSMPRelayVRange testSMPClientVR :: Transport c => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a testSMPClientVR vr client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost - runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> + testSMPClient_ useHost testPort vr client + +testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a +testSMPClient_ host port vr client = do + let tcConfig = defaultTransportClientConfig {Client.alpn = clientALPN} + runTransportClient tcConfig Nothing host port (Just testKeyHash) $ \h -> runExceptT (smpClientHandshake h Nothing testKeyHash vr) >>= \case Right th -> client th Left e -> error $ show e + where + clientALPN + | authCmdsSMPVersion `isCompatible` vr = Just supportedSMPHandshakes + | otherwise = Nothing cfg :: ServerConfig cfg = @@ -84,7 +100,6 @@ cfg = { transports = [], smpHandshakeTimeout = 60000000, tbqSize = 1, - -- serverTbqSize = 1, msgQueueQuota = 4, queueIdBytes = 24, msgIdBytes = 24, @@ -104,13 +119,41 @@ cfg = privateKeyFile = "tests/fixtures/server.key", certificateFile = "tests/fixtures/server.crt", smpServerVRange = supportedServerSMPRelayVRange, - transportConfig = defaultTransportServerConfig, - controlPort = Nothing + transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedSMPHandshakes}, + controlPort = Nothing, + smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds + allowSMPProxy = False, + serverClientConcurrency = 2, + information = Nothing } cfgV7 :: ServerConfig cfgV7 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} +cfgV8 :: ServerConfig +cfgV8 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} + +cfgVPrev :: ServerConfig +cfgVPrev = cfg {smpServerVRange = prevRange $ smpServerVRange cfg} + +prevRange :: VersionRange v -> VersionRange v +prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)} + +prevVersion :: Version v -> Version v +prevVersion (Version v) = Version (v - 1) + +proxyCfg :: ServerConfig +proxyCfg = + cfg + { allowSMPProxy = True, + smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True}} + } + where + smpAgentCfg' = smpAgentCfg cfg + +proxyVRangeV8 :: VersionRangeSMP +proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion + withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile} @@ -145,8 +188,8 @@ withSmpServerOn t port' = withSmpServerThreadOn t port' . const withSmpServer :: HasCallStack => ATransport -> IO a -> IO a withSmpServer t = withSmpServerOn t testPort -withSmpServerV7 :: HasCallStack => ATransport -> IO a -> IO a -withSmpServerV7 t = withSmpServerConfigOn t cfgV7 testPort . const +withSmpServerProxy :: HasCallStack => ATransport -> IO a -> IO a +withSmpServerProxy t = withSmpServerConfigOn t proxyCfg testPort . const runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a runSmpTest test = withSmpServer (transport @c) $ testSMPClient test diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs new file mode 100644 index 000000000..7505ef977 --- /dev/null +++ b/tests/SMPProxyTests.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module SMPProxyTests where + +import AgentTests.EqInstances () +import AgentTests.FunctionalAPITests +import Control.Concurrent (ThreadId, threadDelay) +import Control.Logger.Simple +import Control.Monad (forM, forM_, forever, replicateM_) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Data.ByteString.Char8 (ByteString) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as L +import SMPAgentClient +import SMPClient +import ServerTests (decryptMsgV3, sendRecv) +import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) +import qualified Simplex.Messaging.Agent as A +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..)) +import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ) +import qualified Simplex.Messaging.Agent.Protocol as A +import Simplex.Messaging.Client +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn) +import qualified Simplex.Messaging.Crypto.Ratchet as CR +import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags) +import qualified Simplex.Messaging.Protocol as SMP +import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) +import Simplex.Messaging.Transport +import Simplex.Messaging.Util (bshow, tshow) +import Simplex.Messaging.Version (mkVersionRange) +import System.FilePath (splitExtensions) +import System.Random (randomRIO) +import Test.Hspec +import UnliftIO +import Util + +smpProxyTests :: Spec +smpProxyTests = do + describe "server configuration" $ do + it "refuses proxy handshake unless enabled" testNoProxy + it "checks basic auth in proxy requests" testProxyAuth + describe "proxy requests" $ do + describe "bad relay URIs" $ do + xit "host not resolved" todo + xit "when SMP port blackholed" todo + xit "no SMP service at host/port" todo + xit "bad SMP fingerprint" todo + xit "batching proxy requests" todo + describe "deliver message via SMP proxy" $ do + let srv1 = SMPServer testHost testPort testKeyHash + srv2 = SMPServer testHost testPort2 testKeyHash + describe "client API" $ do + let maxLen = maxMessageLength sendingProxySMPVersion + describe "one server" $ do + it "deliver via proxy" . oneServer $ do + deliverMessageViaProxy srv1 srv1 C.SEd448 "hello 1" "hello 2" + describe "two servers" $ do + let proxyServ = srv1 + relayServ = srv2 + (msg1, msg2) <- runIO $ do + g <- C.newRandom + atomically $ (,) <$> C.randomBytes maxLen g <*> C.randomBytes maxLen g + it "deliver via proxy" . twoServersFirstProxy $ + deliverMessageViaProxy proxyServ relayServ C.SEd448 "hello 1" "hello 2" + it "max message size, Ed448 keys" . twoServersFirstProxy $ + deliverMessageViaProxy proxyServ relayServ C.SEd448 msg1 msg2 + it "max message size, Ed25519 keys" . twoServersFirstProxy $ + deliverMessageViaProxy proxyServ relayServ C.SEd25519 msg1 msg2 + it "max message size, X25519 keys" . twoServersFirstProxy $ + deliverMessageViaProxy proxyServ relayServ C.SX25519 msg1 msg2 + describe "stress test 1k" $ do + let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n]) + it "1x1000" . twoServersFirstProxy $ deliver 1000 + it "5x200" . twoServersFirstProxy $ 5 `inParrallel` deliver 200 + it "10x100" . twoServersFirstProxy $ 10 `inParrallel` deliver 100 + describe "stress test - no host" $ do + it "1x1000, no delay" . oneServer $ proxyConnectDeadRelay 1000 0 srv1 + xit "1x1000, 100ms" . oneServer $ proxyConnectDeadRelay 1000 100000 srv1 + xit "100x1000, 100ms" . oneServer $ 100 `inParrallel` (randomRIO (0, 1000000) >>= threadDelay >> proxyConnectDeadRelay 1000 100000 srv1) + xdescribe "stress test 10k" $ do + let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n]) + it "1x10000" . twoServersFirstProxy $ deliver 10000 + it "5x2000" . twoServersFirstProxy $ 5 `inParrallel` deliver 2000 + it "10x1000" . twoServersFirstProxy $ 10 `inParrallel` deliver 1000 + it "100x100 N1" . twoServersFirstProxy $ withNumCapabilities 1 $ 100 `inParrallel` deliver 100 + it "100x100 N4 C1" . twoServersNoConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 + it "100x100 N4 C2" . twoServersFirstProxy $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 + it "100x100 N4 C16" . twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 + it "100x100 N" . twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100 + it "500x20" . twoServersFirstProxy $ 500 `inParrallel` deliver 20 + describe "agent API" $ do + describe "one server" $ do + it "always via proxy" . oneServer $ + agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 + it "without proxy" . oneServer $ + agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 + describe "two servers" $ do + it "always via proxy" . twoServers $ + agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 + it "both via proxy" . twoServers $ + agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" 1 + it "first via proxy" . twoServers $ + agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 + it "without proxy" . twoServers $ + agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 + it "first via proxy for unknown" . twoServers $ + agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 1 + it "without proxy with fallback" . twoServers_ proxyCfg cfgV7 $ + agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 3 + it "fails when fallback is prohibited" . twoServers_ proxyCfg cfgV7 $ + agentViaProxyVersionError + it "retries sending when destination or proxy relay is offline" $ + agentViaProxyRetryOffline + it "retries sending when destination relay session disconnects in proxy" $ + agentViaProxyRetryNoSession + describe "stress test 1k" $ do + let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) + it "2 agents, 250 messages" . oneServer $ deliver 2 250 + it "5 agents, 10 pairs, 50 messages, N1" . oneServer . withNumCapabilities 1 $ deliver 5 50 + it "5 agents, 10 pairs, 50 messages. N4" . oneServer . withNumCapabilities 4 $ deliver 5 50 + xdescribe "stress test 10k" $ do + let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) + it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17 + where + oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128} testPort . const + twoServers = twoServers_ proxyCfg proxyCfg + twoServersFirstProxy = twoServers_ proxyCfg cfgV8 {msgQueueQuota = 128} + twoServersMoreConc = twoServers_ proxyCfg {serverClientConcurrency = 128} cfgV8 {msgQueueQuota = 128} + twoServersNoConc = twoServers_ proxyCfg {serverClientConcurrency = 1} cfgV8 {msgQueueQuota = 128} + twoServers_ cfg1 cfg2 runTest = + withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ -> + withSmpServerConfigOn (transport @TLS) cfg2 testPort2 $ const runTest + +deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO () +deliverMessageViaProxy proxyServ relayServ alg msg msg' = deliverMessagesViaProxy proxyServ relayServ alg [msg] [msg'] + +deliverMessagesViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> [ByteString] -> [ByteString] -> IO () +deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do + g <- C.newRandom + -- set up proxy + pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ()) + pc <- either (fail . show) pure pc' + THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc + -- set up relay + msgQ <- newTBQueueIO 1024 + rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) (\_ -> pure ()) + rc <- either (fail . show) pure rc' + -- prepare receiving queue + (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g + (rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe False + let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv + -- get proxy session + sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct") + sess <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct") + sess0 `shouldBe` sess + -- send via proxy to unsecured queue + forM_ unsecuredMsgs $ \msg -> do + runExceptT' (proxySMPMessage pc sess Nothing sndId noMsgFlags msg) `shouldReturn` Right () + runExceptT' (proxySMPMessage pc sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION) + -- receive 1 + (_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody})))]) <- atomically $ readTBQueue msgQ + dec msgId encBody `shouldBe` Right msg + runExceptT' $ ackSMPMessage rc rPriv rcvId msgId + -- secure queue + (sPub, sPriv) <- atomically $ C.generateAuthKeyPair alg g + runExceptT' $ secureSMPQueue rc rPriv rcvId sPub + -- send via proxy to secured queue + waitSendRecv + ( forM_ securedMsgs $ \msg' -> + runExceptT' (proxySMPMessage pc sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right () + ) + ( forM_ securedMsgs $ \msg' -> do + (_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'})))]) <- atomically $ readTBQueue msgQ + dec msgId' encBody' `shouldBe` Right msg' + runExceptT' $ ackSMPMessage rc rPriv rcvId msgId' + ) + +proxyConnectDeadRelay :: Int -> Int -> SMPServer -> IO () +proxyConnectDeadRelay n d proxyServ = do + g <- C.newRandom + -- set up proxy + pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ()) + pc <- either (fail . show) pure pc' + THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc + -- get proxy session + replicateM_ n $ do + sess0 <- runExceptT $ connectSMPProxiedRelay pc (SMPServer testHost "45678" testKeyHash) (Just "correct") + case sess0 of + Right !_noWay -> error "got unexpected client" + Left !_err -> threadDelay d + +agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO () +agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId = + withAgent 1 aCfg (servers aTestCfg) testDB $ \alice -> + withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do + (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe + ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice + liftIO $ pqSup' `shouldBe` PQSupportOn + allowConnection alice bobId confId "alice's connInfo" + let pqEnc = CR.PQEncOn + get alice ##> ("", bobId, A.CON pqEnc) + get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo") + get bob ##> ("", aliceId, A.CON pqEnc) + -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4 + let aProxySrv = if aViaProxy then Just $ L.head aSrvs else Nothing + 1 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1 + get alice ##> ("", bobId, A.SENT (baseId + 1) aProxySrv) + 2 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg2 + get alice ##> ("", bobId, A.SENT (baseId + 2) aProxySrv) + get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False + ackMessage bob aliceId (baseId + 1) Nothing + get bob =##> \case ("", c, Msg' _ pq msg2') -> c == aliceId && pq == pqEnc && msg2 == msg2'; _ -> False + ackMessage bob aliceId (baseId + 2) Nothing + let bProxySrv = if bViaProxy then Just $ L.head bSrvs else Nothing + 3 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg1 + get bob ##> ("", aliceId, A.SENT (baseId + 3) bProxySrv) + 4 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2 + get bob ##> ("", aliceId, A.SENT (baseId + 4) bProxySrv) + get alice =##> \case ("", c, Msg' _ pq msg1') -> c == bobId && pq == pqEnc && msg1 == msg1'; _ -> False + ackMessage alice bobId (baseId + 3) Nothing + get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False + ackMessage alice bobId (baseId + 4) Nothing + where + msgId = subtract baseId . fst + aCfg = agentCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg} + servers (srvs, smpProxyMode, _) = (initAgentServersProxy smpProxyMode SPFAllow) {smp = userServers srvs} + +agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO () +agentDeliverMessagesViaProxyConc agentServers msgs = + withAgents $ \agents -> do + let pairs = combinations 2 agents + logNote $ "Pairing " <> tshow (length agents) <> " agents into " <> tshow (length pairs) <> " connections" + connections <- forM pairs $ \case + [a, b] -> prePair a b + _ -> error "agents must be paired" + logNote "Running..." + mapConcurrently_ run connections + where + withAgents :: ([AgentClient] -> IO ()) -> IO () + withAgents action = go [] (zip [1 :: Int ..] agentServers) + where + go agents = \case + [] -> action agents + (aId, aSrvs) : next -> withAgent aId aCfg (servers aSrvs) (dbPrefix <> show aId <> dbSuffix) $ \a -> (a : agents) `go` next + (dbPrefix, dbSuffix) = splitExtensions testDB + -- agent connections have to be set up in advance + -- otherwise the CONF messages would get mixed with MSG + prePair alice bob = do + (bobId, qInfo) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + aliceId <- runExceptT' $ A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe + confId <- + get alice >>= \case + ("", _, A.CONF confId pqSup' _ "bob's connInfo") -> do + pqSup' `shouldBe` PQSupportOn + pure confId + huh -> fail $ show huh + runExceptT' $ allowConnection alice bobId confId "alice's connInfo" + get alice ##> ("", bobId, A.CON pqEnc) + get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo") + get bob ##> ("", aliceId, A.CON pqEnc) + pure (alice, bobId, bob, aliceId) + -- stream messages in opposite directions, while getting deliveries and sending ACKs + run (alice, bobId, bob, aliceId) = do + aSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage alice bobId pqEnc noMsgFlags + bRecipient <- + async $ + forever $ + get bob >>= \case + ("", _, A.SENT _ _) -> pure () + ("", _, Msg' mId' _ _) -> runExceptT' $ ackMessage alice bobId mId' Nothing + huh -> fail (show huh) + bSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage bob aliceId pqEnc noMsgFlags + aRecipient <- + async $ + forever $ + get alice >>= \case + ("", _, A.SENT _ _) -> pure () + ("", _, Msg' mId' _ _) -> runExceptT' $ ackMessage alice bobId mId' Nothing + huh -> fail (show huh) + logDebug "run waiting..." + a2b <- async $ (waitCatch aSender >>= either throwIO pure) `finally` cancel bRecipient -- stopped sender cancels paired recipient loop + b2a <- async $ (waitCatch bSender >>= either throwIO pure) `finally` cancel aRecipient + waitEitherCatch a2b b2a >>= \case + Right (Right ()) -> wait b2a + Right (Left e) -> cancel bSender >> throwIO e + Left (Right ()) -> wait a2b + Left (Left e) -> cancel aSender >> throwIO e + logDebug "run finished" + pqEnc = CR.PQEncOn + aCfg = agentCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448} + servers srvs = (initAgentServersProxy SPMAlways SPFAllow) {smp = userServers srvs} + +agentViaProxyVersionError :: IO () +agentViaProxyVersionError = + withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do + Left (A.BROKER _ (TRANSPORT TEVersion)) <- + withAgent 2 agentCfg (servers [SMPServer testHost testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do + (_bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe + pure () + where + servers srvs = (initAgentServersProxy SPMUnknown SPFProhibit) {smp = userServers srvs} + +agentViaProxyRetryOffline :: IO () +agentViaProxyRetryOffline = do + let srv1 = SMPServer testHost testPort testKeyHash + srv2 = SMPServer testHost testPort2 testKeyHash + msg1 = "hello 1" + msg2 = "hello 2" + aProxySrv = Just srv1 + bProxySrv = Just srv2 + withAgent 1 aCfg (servers srv1) testDB $ \alice -> + withAgent 2 aCfg (servers srv2) testDB2 $ \bob -> do + let pqEnc = CR.PQEncOn + withServer $ \_ -> do + (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do + (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe + aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe + ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice + liftIO $ pqSup' `shouldBe` PQSupportOn + allowConnection alice bobId confId "alice's connInfo" + get alice ##> ("", bobId, A.CON pqEnc) + get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo") + get bob ##> ("", aliceId, A.CON pqEnc) + 1 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1 + get alice ##> ("", bobId, A.SENT (baseId + 1) aProxySrv) + get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False + ackMessage bob aliceId (baseId + 1) Nothing + 2 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2 + get bob ##> ("", aliceId, A.SENT (baseId + 2) bProxySrv) + get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False + ackMessage alice bobId (baseId + 2) Nothing + pure (aliceId, bobId) + runRight_ $ do + -- destination relay down + 3 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1 + bob `down` aliceId + withServer2 $ \_ -> runRight_ $ do + bob `up` aliceId + get alice ##> ("", bobId, A.SENT (baseId + 3) aProxySrv) + get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False + ackMessage bob aliceId (baseId + 3) Nothing + runRight_ $ do + -- proxy relay down + 4 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2 + bob `down` aliceId + withServer2 $ \_ -> runRight_ $ do + bob `up` aliceId + get bob ##> ("", aliceId, A.SENT (baseId + 4) bProxySrv) + get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False + ackMessage alice bobId (baseId + 4) Nothing + where + withServer :: (ThreadId -> IO a) -> IO a + withServer = withServer_ testStoreLogFile testStoreMsgsFile testPort + withServer2 :: (ThreadId -> IO a) -> IO a + withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testPort2 + withServer_ storeLog storeMsgs port = + withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs} port + a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False + a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False + aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} + baseId = 1 + msgId = subtract baseId . fst + servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]} + +agentViaProxyRetryNoSession :: IO () +agentViaProxyRetryNoSession = do + let srv1 = SMPServer testHost testPort testKeyHash + srv2 = SMPServer testHost testPort2 testKeyHash + withAgent 1 agentCfg (servers srv1) testDB $ \a -> + withAgent 2 agentCfg (servers srv2) testDB2 $ \b -> do + withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> do + (aId, _) <- withServer2 $ \_ -> runRight $ makeConnection a b + nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False + withServer2 $ \_ -> do + nGet b =##> \case ("", "", UP _ [c]) -> c == aId; _ -> False + -- to test retry in case of NO_SESSION error, + -- the client using server 1 as proxy and server 2 as destination + -- should be joining the connection, so the order is swapped here. + _ <- runRight $ makeConnection b a + pure () + where + withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2} testPort2 + servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]} + +testNoProxy :: IO () +testNoProxy = do + withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do + testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do + (_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", SMP.PRXY testSMPServer Nothing) + reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) + +testProxyAuth :: IO () +testProxyAuth = do + withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do + testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do + (_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", SMP.PRXY testSMPServer2 $ Just "wrong") + reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) + where + proxyCfgAuth = proxyCfg {newQueueBasicAuth = Just "correct"} + +todo :: IO () +todo = do + fail "TODO" + +runExceptT' :: Exception e => ExceptT e IO a -> IO a +runExceptT' a = runExceptT a >>= either throwIO pure + +waitSendRecv :: IO () -> IO () -> IO () +waitSendRecv s r = do + s' <- async s + r' <- async r + waitCatch s' >>= either (\e -> cancel r' >> fail (show e)) pure + waitCatch r' >>= either (\e -> cancel s' >> fail (show e)) pure diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index b4c40cd99..10516b9f2 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -73,7 +73,7 @@ pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType B pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command)) pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg -pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh) +pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure) pattern Msg :: MsgId -> MsgBody -> BrokerMsg pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} @@ -134,7 +134,7 @@ testCreateSecure (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -183,12 +183,12 @@ testCreateSecure (ATransport t) = Resp "dabc" _ err5 <- sendRecv s ("", "dabc", sId, _SEND "hello") (err5, ERR AUTH) #== "rejects unsigned SEND" - let maxAllowedMessage = B.replicate maxMessageLength '-' + let maxAllowedMessage = B.replicate (maxMessageLength currentClientSMPRelayVersion) '-' Resp "bcda" _ OK <- signSendRecv s sKey ("bcda", sId, _SEND maxAllowedMessage) Resp "" _ (Msg mId3 msg3) <- tGet1 r (dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size" - let biggerMessage = B.replicate (maxMessageLength + 1) '-' + let biggerMessage = B.replicate (maxMessageLength currentClientSMPRelayVersion + 1) '-' Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage) pure () @@ -199,7 +199,7 @@ testCreateDelete (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -271,7 +271,7 @@ stressTest (ATransport t) = (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g rIds <- forM ([1 .. 50] :: [Int]) . const $ do - Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe False) pure rId let subscribeQueues h = forM_ rIds $ \rId -> do Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB) @@ -289,7 +289,7 @@ testAllowNewQueues t = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) pure () testDuplex :: ATransport -> Spec @@ -299,7 +299,7 @@ testDuplex (ATransport t) = g <- C.newRandom (arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe) + Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe False) let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv -- aSnd ID is passed to Bob out-of-band @@ -315,7 +315,7 @@ testDuplex (ATransport t) = (brPub, brKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe) + Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe False) let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd) -- "reply_id ..." is ad-hoc, not a part of SMP protocol @@ -354,7 +354,7 @@ testSwitchSub (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1") (ok1, OK) #== "sent test message 1" @@ -509,19 +509,21 @@ testWithStoreLog at@(ATransport t) = writeTVar senderId1 sId1 writeTVar notifierId nId Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB) - signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello") >>= \case - Resp "bcda" _ OK -> pure () - r -> unexpected r - Resp "" _ (Msg mId1 msg1) <- tGet1 h + (mId1, msg1) <- + signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello") >>= \case + Resp "" _ (Msg mId1 msg1) -> pure (mId1, msg1) + r -> error $ "unexpected response " <> take 100 (show r) + Resp "bcda" _ OK <- tGet1 h (decryptMsgV3 dhShared mId1 msg1, Right "hello") #== "delivered from queue 1" Resp "" _ (NMSG _ _) <- tGet1 h1 (sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2 atomically $ writeTVar senderId2 sId2 - signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") >>= \case - Resp "cdab" _ OK -> pure () - r -> unexpected r - Resp "" _ (Msg mId2 msg2) <- tGet1 h + (mId2, msg2) <- + signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") >>= \case + Resp "" _ (Msg mId2 msg2) -> pure (mId2, msg2) + r -> error $ "unexpected response " <> take 100 (show r) + Resp "cdab" _ OK <- tGet1 h (decryptMsgV3 dhShared2 mId2 msg2, Right "hello too") #== "delivered from queue 2" Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL) @@ -608,7 +610,7 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 2 logSize testStoreMsgsFile `shouldReturn` 5 - logSize testServerStatsBackupFile `shouldReturn` 20 + logSize testServerStatsBackupFile `shouldReturn` 55 Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats1 [rId] 5 1 @@ -626,7 +628,7 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 -- the last message is not removed because it was not ACK'd logSize testStoreMsgsFile `shouldReturn` 3 - logSize testServerStatsBackupFile `shouldReturn` 20 + logSize testServerStatsBackupFile `shouldReturn` 55 Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats2 [rId] 5 3 @@ -645,7 +647,7 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 logSize testStoreMsgsFile `shouldReturn` 0 - logSize testServerStatsBackupFile `shouldReturn` 20 + logSize testServerStatsBackupFile `shouldReturn` 55 Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats3 [rId] 5 5 @@ -740,7 +742,7 @@ createAndSecureQueue h sPub = do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dhShared = C.dh' srvDh dhPriv Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) (rId', rId) #== "same queue ID" @@ -751,7 +753,7 @@ testTiming (ATransport t) = describe "should have similar time for auth error, whether queue exists or not, for all key types" $ forM_ timingTests $ \tst -> it (testName tst) $ - smpTest2Cfg cfgV7 (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh -> + smpTest2Cfg cfg (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh -> testSameTiming rh sh tst where testName :: (C.AuthAlg, C.AuthAlg, Int) -> String @@ -775,7 +777,7 @@ testTiming (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) @@ -884,7 +886,7 @@ testMsgExpireOnInterval t = testSMPClient @c $ \sh -> do (sId, rId, rKey, _) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should expire)") - threadDelay 2500000 + threadDelay 3000000 testSMPClient @c $ \rh -> do signSendRecv rh rKey ("2", rId, SUB) >>= \case Resp "2" _ OK -> pure () @@ -931,16 +933,14 @@ instance Eq C.ASignature where Just Refl -> s == s' _ -> False -deriving instance Eq (C.Signature a) - syntaxTests :: ATransport -> Spec syntaxTests (ATransport t) = do it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN) describe "NEW" $ do it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX) it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX) - it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey, SMSubscribe)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) - it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey, SMSubscribe)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH) + it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey, '0', SMSubscribe, False)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) + it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey, '0', SMSubscribe, False)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH) describe "KEY" $ do it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH) it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX) diff --git a/tests/Test.hs b/tests/Test.hs index aebceb22d..98d902163 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -11,7 +11,6 @@ import CoreTests.BatchingTests import CoreTests.CryptoFileTests import CoreTests.CryptoTests import CoreTests.EncodingTests -import CoreTests.ProtocolErrorTests import CoreTests.RetryIntervalTests import CoreTests.TRcvQueuesTests import CoreTests.UtilTests @@ -21,6 +20,7 @@ import GHC.IO.Exception (IOException (..)) import qualified GHC.IO.Exception as IOException import NtfServerTests (ntfServerTests) import RemoteControl (remoteControlTests) +import SMPProxyTests (smpProxyTests) import ServerTests import Simplex.Messaging.Transport (TLS, Transport (..)) import Simplex.Messaging.Transport.WebSockets (WS) @@ -48,7 +48,6 @@ main = do describe "Core tests" $ do describe "Batching tests" batchingTests describe "Encoding tests" encodingTests - describe "Protocol error tests" protocolErrorTests describe "Version range" versionRangeTests describe "Encryption tests" cryptoTests describe "Encrypted files tests" cryptoFileTests @@ -59,6 +58,7 @@ main = do describe "SMP server via WebSockets" $ serverTests (transport @WS) describe "Notifications server" $ ntfServerTests (transport @TLS) describe "SMP client agent" $ agentTests (transport @TLS) + describe "SMP proxy" smpProxyTests describe "XFTP" $ do describe "XFTP server" xftpServerTests describe "XFTP file description" fileDescriptionTests diff --git a/tests/Util.hs b/tests/Util.hs index a52fee32c..6ad6d054f 100644 --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,6 +1,28 @@ module Util where +import Control.Monad (replicateM) +import Data.Either (partitionEithers) +import Data.List (tails) +import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities) import Test.Hspec +import UnliftIO skip :: String -> SpecWith a -> SpecWith a skip = before_ . pendingWith + +withNumCapabilities :: Int -> IO a -> IO a +withNumCapabilities new a = getNumCapabilities >>= \old -> bracket_ (setNumCapabilities new) (setNumCapabilities old) a + +withNCPUCapabilities :: IO a -> IO a +withNCPUCapabilities a = getNumProcessors >>= \p -> withNumCapabilities p a + +inParrallel :: Int -> IO () -> IO () +inParrallel n action = do + streams <- replicateM n $ async action + (es, rs) <- partitionEithers <$> mapM waitCatch streams + map show es `shouldBe` [] + length rs `shouldBe` n + +combinations :: Int -> [a] -> [[a]] +combinations 0 _ = [[]] +combinations k xs = [y : ys | y : xs' <- tails xs, ys <- combinations (k - 1) xs'] diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 88786bb40..8de86eff1 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -20,15 +20,17 @@ import Data.Int (Int64) import Data.List (find, isSuffixOf) import Data.Maybe (fromJust) import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2, testDB3) +import SMPClient (xit'') import Simplex.FileTransfer.Client (XFTPClientConfig (..)) import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, kb, mb, qrSizeLimit, pattern ValidFileDescription) import Simplex.FileTransfer.Protocol (FileParty (..)) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH)) +import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg) -import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv) +import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs) import qualified Simplex.Messaging.Crypto.File as CF @@ -46,7 +48,11 @@ import XFTPClient xftpAgentTests :: Spec xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do - it "should send and receive file" testXFTPAgentSendReceive + it "should send and receive file" $ withXFTPServer testXFTPAgentSendReceive + -- uncomment CPP option slow_servers and run hpack to run this test + xit "should send and receive file with slow server responses" $ + withXFTPServerCfg testXFTPServerConfig {responseDelay = 500000} $ + \_ -> testXFTPAgentSendReceive it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted it "should send and receive large file with a redirect" testXFTPAgentSendReceiveRedirect it "should send and receive small file without a redirect" testXFTPAgentSendReceiveNoRedirect @@ -54,7 +60,7 @@ xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do it "should resume receiving file after restart" testXFTPAgentReceiveRestore it "should cleanup rcv tmp path after permanent error" testXFTPAgentReceiveCleanup it "should resume sending file after restart" testXFTPAgentSendRestore - it "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup + xit'' "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup it "should delete sent file on server" testXFTPAgentDelete it "should resume deleting file after restart" testXFTPAgentDeleteRestore -- TODO when server is fixed to correctly send AUTH error, this test has to be modified to expect AUTH error @@ -69,7 +75,7 @@ xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do describe "server with password" $ do let auth = Just "abcd" srv = ProtoServerWithAuth testXFTPServer2 - authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP AUTH) + authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH) it "should pass with correct password" $ testXFTPServerTest auth (srv auth) `shouldReturn` Nothing it "should fail without password" $ testXFTPServerTest auth (srv Nothing) `shouldReturn` authErr it "should fail with incorrect password" $ testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` authErr @@ -100,7 +106,7 @@ checkProgress (prev, expected) (progress, total) loop | otherwise = pure () testXFTPAgentSendReceive :: HasCallStack => IO () -testXFTPAgentSendReceive = withXFTPServer $ do +testXFTPAgentSendReceive = do filePath <- createRandomFile -- send file, delete snd file internally (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do @@ -179,7 +185,7 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do FileDescriptionURI {description} <- either fail pure $ strDecode uri - rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing + rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize) rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize) @@ -223,7 +229,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do FileDescriptionURI {description} <- either fail pure $ strDecode uri let ValidFileDescription FileDescription {redirect} = description redirect `shouldBe` Nothing - rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing + rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True -- NO extra "RFPROG 65k 65k" before switching to real file rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize) rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize) @@ -311,7 +317,7 @@ testReceive' rcp rfd originalFilePath = testReceiveCF' rcp rfd Nothing originalF testReceiveCF' :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> Int64 -> ExceptT AgentErrorType IO RcvFileId testReceiveCF' rcp rfd cfArgs originalFilePath size = do - rfId <- xftpReceiveFile rcp 1 rfd cfArgs + rfId <- xftpReceiveFile rcp 1 rfd cfArgs True rfProgress rcp size ("", rfId', RFDONE path) <- rfGet rcp liftIO $ do @@ -336,7 +342,7 @@ testXFTPAgentReceiveRestore = do -- receive file - should not succeed with server down rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do xftpStartWorkers rcp (Just recipientFiles) - rfId <- xftpReceiveFile rcp 1 rfd Nothing + rfId <- xftpReceiveFile rcp 1 rfd Nothing True liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure rfId @@ -380,7 +386,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do -- receive file - should not succeed with server down rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do xftpStartWorkers rcp (Just recipientFiles) - rfId <- xftpReceiveFile rcp 1 rfd Nothing + rfId <- xftpReceiveFile rcp 1 rfd Nothing True liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure rfId @@ -392,7 +398,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do -- receive file - should fail with AUTH error withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp' + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp' rfId' `shouldBe` rfId -- tmp path should be removed after permanent error @@ -471,7 +477,8 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do -- send file - should fail with AUTH error withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - ("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr' + ("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- + sfGet sndr' sfId' `shouldBe` sfId -- prefix path should be removed after permanent error @@ -505,8 +512,9 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $ -- receive file - should fail with AUTH error withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do xftpStartWorkers rcp2 (Just recipientFiles) - rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2 + rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- + rfGet rcp2 liftIO $ rfId' `shouldBe` rfId testXFTPAgentDeleteRestore :: HasCallStack => IO () @@ -542,8 +550,9 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do -- receive file - should fail with AUTH error withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do xftpStartWorkers rcp2 (Just recipientFiles) - rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2 + rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- + rfGet rcp2 liftIO $ rfId' `shouldBe` rfId testXFTPAgentDeleteOnServer :: HasCallStack => IO () @@ -576,8 +585,9 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $ runRight_ . void $ do -- receive file 1 again - rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing - ("", rfId1', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp + rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True + ("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- + rfGet rcp liftIO $ rfId1 `shouldBe` rfId1' -- receive file 2 @@ -608,8 +618,9 @@ testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do -- receive file 1 again - should fail with AUTH error runRight $ do - rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp + rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- + rfGet rcp liftIO $ rfId' `shouldBe` rfId -- create and send file 2 diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 5f38cc639..72c843f32 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -14,6 +14,7 @@ import Simplex.FileTransfer.Client import Simplex.FileTransfer.Description import Simplex.FileTransfer.Server (runXFTPServerBlocking) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration, supportedXFTPhandshakes) +import Simplex.FileTransfer.Transport (supportedFileServerVRange) import Simplex.Messaging.Protocol (XFTPServer) import Simplex.Messaging.Transport (ALPN) import Simplex.Messaging.Transport.Server @@ -66,10 +67,10 @@ withXFTPServer2 :: HasCallStack => IO a -> IO a withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2} . const xftpTestPort :: ServiceName -xftpTestPort = "7000" +xftpTestPort = "8000" xftpTestPort2 :: ServiceName -xftpTestPort2 = "7001" +xftpTestPort2 = "8001" testXFTPServer :: XFTPServer testXFTPServer = fromString testXFTPServerStr @@ -78,10 +79,10 @@ testXFTPServer2 :: XFTPServer testXFTPServer2 = fromString testXFTPServerStr2 testXFTPServerStr :: String -testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" +testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" testXFTPServerStr2 :: String -testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001" +testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8001" xftpServerFiles :: FilePath xftpServerFiles = "tests/tmp/xftp-server-files" @@ -118,11 +119,13 @@ testXFTPServerConfig_ alpn = caCertificateFile = "tests/fixtures/ca.crt", privateKeyFile = "tests/fixtures/server.key", certificateFile = "tests/fixtures/server.crt", + xftpServerVRange = supportedFileServerVRange, logStatsInterval = Nothing, logStatsStartTime = 0, serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log", serverStatsBackupFile = Nothing, - transportConfig = defaultTransportServerConfig {alpn} + transportConfig = defaultTransportServerConfig {alpn}, + responseDelay = 0 } testXFTPClientConfig :: XFTPClientConfig