Merge remote-tracking branch 'origin/master' into ab/async-subs

* remote ctrl: differentiate RCP error when trying to connect to unknown host identity

* rename

* refactor

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

.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: |

CHANGELOG.md

@@ -1,3 +1,105 @@
+# 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
+
+_Please note_: the earliest SimpleX Chat clients supported by this version of the servers is 5.5.3 (released on February 11, 2024).
+
+SMP server:
+- increase max SMP protocol version to 7 (support for deniable authenticators).
+
+NTF server:
+- increase max NTF protocol version to 2 (support for deniable authenticators).
+
+XFTP server:
+- version handshake using ALPN.
+
+SMP agent:
+- increase timeouts for XFTP files.
+- don't send commands after timeout.
+- PQ encryption support.
+
+# 5.6.2
+
+Version 5.6.2.2.
+
+SMP agent:
+- Lower memory consumption (~20-25%).
+- More stable XFTP file uploads and downloads.
+- API to receive network connectivity changes from the apps.
+- to reduce battery consumption: connection attempts interval growing to every 2 hours when app reports as offline.
+- to reduce retries and traffic: 50% increased timeouts when on mobile network.
+
+XFTP server:
+- expire files on start.
+- version negotiation based on TLS ALPN and handshake.
+
+NTF server:
+- reduced downtime by ~100x faster start time.
+- exclude test tokens from statistics.
+
 # 5.6.1
 
 Version 5.6.1.0.

apps/smp-agent/Main.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -38,7 +39,8 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 -- Warning: this SMP agent server is experimental - it does not work correctly with multiple connected TCP clients in some cases.
 main :: IO ()
 main = do
-  putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
+  let AgentConfig {tcpPort} = cfg
+  putStrLn $ maybe (error "no agent port") (\port -> "SMP agent listening on port " ++ port) tcpPort
   setLogLevel LogInfo -- LogError
   Right st <- createAgentStore agentDbFile agentDbKey False MCConsole
   withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg servers st

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

apps/smp-server/static/contact/index.html

@@ -0,0 +1 @@
+../link.html

apps/smp-server/static/invitation/index.html

@@ -0,0 +1 @@
+../link.html

apps/smp-server/static/media/apple_store.svg

@@ -0,0 +1,26 @@
+<svg width="119" height="40" viewBox="0 0 119 40" fill="none" xmlns="http://www.w3.org/2000/svg">
+<path d="M8.44484 39.125C8.14016 39.125 7.84284 39.1211 7.54055 39.1143C6.91433 39.1061 6.28957 39.0516 5.67141 38.9512C5.095 38.8519 4.53661 38.6673 4.01467 38.4033C3.49751 38.1415 3.02582 37.7983 2.61767 37.3867C2.20361 36.98 1.85888 36.5082 1.59716 35.9902C1.33255 35.4688 1.14942 34.9099 1.05416 34.333C0.951281 33.7131 0.895621 33.0863 0.887656 32.458C0.881316 32.2471 0.873016 31.5449 0.873016 31.5449V8.44434C0.873016 8.44434 0.881856 7.75293 0.887706 7.5498C0.895332 6.92248 0.950669 6.29665 1.05324 5.67773C1.14868 5.09925 1.33194 4.53875 1.5967 4.01563C1.85746 3.49794 2.20027 3.02586 2.61184 2.61768C3.02294 2.20562 3.49614 1.8606 4.01418 1.59521C4.53492 1.33209 5.09225 1.14873 5.6675 1.05127C6.28769 0.949836 6.91462 0.894996 7.54301 0.88721L8.44533 0.875H111.214L112.127 0.8877C112.75 0.895099 113.371 0.94945 113.985 1.05029C114.566 1.14898 115.13 1.33362 115.656 1.59814C116.694 2.13299 117.539 2.97916 118.071 4.01807C118.332 4.53758 118.512 5.09351 118.606 5.66699C118.71 6.29099 118.768 6.92174 118.78 7.5542C118.783 7.8374 118.783 8.1416 118.783 8.44434C118.791 8.81934 118.791 9.17627 118.791 9.53613V30.4648C118.791 30.8281 118.791 31.1826 118.783 31.54C118.783 31.8652 118.783 32.1631 118.779 32.4697C118.768 33.0909 118.71 33.7104 118.608 34.3232C118.515 34.9043 118.333 35.4675 118.068 35.9932C117.805 36.5056 117.462 36.9733 117.053 37.3789C116.644 37.7927 116.172 38.1379 115.653 38.4014C115.128 38.6674 114.566 38.8527 113.985 38.9512C113.367 39.0522 112.742 39.1067 112.116 39.1143C111.823 39.1211 111.517 39.125 111.219 39.125L110.135 39.127L8.44484 39.125Z" fill="black"/>
+<path d="M24.7689 20.3007C24.7796 19.466 25.0013 18.6477 25.4134 17.9217C25.8254 17.1957 26.4144 16.5858 27.1254 16.1486C26.6737 15.5035 26.0778 14.9725 25.3849 14.598C24.6921 14.2234 23.9215 14.0156 23.1343 13.991C21.455 13.8147 19.8271 14.9958 18.9714 14.9958C18.0991 14.9958 16.7816 14.0085 15.3629 14.0376C14.4452 14.0673 13.5509 14.3341 12.767 14.8122C11.9831 15.2903 11.3364 15.9632 10.89 16.7655C8.95597 20.1139 10.3986 25.035 12.2512 27.7416C13.1781 29.0669 14.2613 30.5474 15.6788 30.4949C17.0659 30.4374 17.5839 29.6104 19.2582 29.6104C20.917 29.6104 21.403 30.4949 22.8492 30.4615C24.3376 30.4374 25.2753 29.1303 26.1697 27.7924C26.8357 26.848 27.3481 25.8043 27.6881 24.6999C26.8234 24.3341 26.0855 23.722 25.5664 22.9397C25.0473 22.1574 24.7699 21.2396 24.7689 20.3007V20.3007Z" fill="white"/>
+<path d="M22.0373 12.2109C22.8488 11.2367 23.2486 9.98451 23.1518 8.72028C21.9119 8.8505 20.7667 9.44306 19.9442 10.3799C19.5421 10.8376 19.2341 11.37 19.0378 11.9468C18.8416 12.5235 18.7609 13.1333 18.8005 13.7413C19.4206 13.7477 20.0341 13.6132 20.5948 13.3482C21.1555 13.0831 21.6487 12.6942 22.0373 12.2109Z" fill="white"/>
+<path d="M42.3023 27.1396H37.5689L36.4322 30.4961H34.4273L38.9107 18.0781H40.9937L45.4771 30.4961H43.438L42.3023 27.1396ZM38.0591 25.5908H41.8111L39.9615 20.1435H39.9097L38.0591 25.5908Z" fill="white"/>
+<path d="M55.1597 25.9697C55.1597 28.7832 53.6538 30.5908 51.3814 30.5908C50.8057 30.6209 50.2332 30.4883 49.7294 30.2082C49.2256 29.928 48.8109 29.5117 48.5327 29.0068H48.4897V33.4912H46.6313V21.4424H48.4302V22.9482H48.4644C48.7553 22.4458 49.1771 22.0316 49.6847 21.7497C50.1923 21.4679 50.7669 21.3289 51.3472 21.3476C53.645 21.3477 55.1597 23.1641 55.1597 25.9697ZM53.2495 25.9697C53.2495 24.1367 52.3023 22.9316 50.857 22.9316C49.437 22.9316 48.482 24.1621 48.482 25.9697C48.482 27.7939 49.437 29.0156 50.857 29.0156C52.3023 29.0156 53.2495 27.8193 53.2495 25.9697Z" fill="white"/>
+<path d="M65.1245 25.9697C65.1245 28.7832 63.6187 30.5908 61.3462 30.5908C60.7706 30.6209 60.1981 30.4883 59.6943 30.2082C59.1905 29.928 58.7758 29.5117 58.4976 29.0068H58.4546V33.4912H56.5962V21.4424H58.395V22.9482H58.4292C58.7201 22.4458 59.1419 22.0316 59.6495 21.7497C60.1571 21.4679 60.7317 21.3289 61.312 21.3476C63.6099 21.3476 65.1245 23.164 65.1245 25.9697ZM63.2144 25.9697C63.2144 24.1367 62.2671 22.9316 60.8218 22.9316C59.4019 22.9316 58.4468 24.1621 58.4468 25.9697C58.4468 27.7939 59.4019 29.0156 60.8218 29.0156C62.2671 29.0156 63.2144 27.8193 63.2144 25.9697H63.2144Z" fill="white"/>
+<path d="M71.7105 27.0361C71.8482 28.2676 73.0445 29.0761 74.6792 29.0761C76.2456 29.0761 77.3726 28.2675 77.3726 27.1572C77.3726 26.1933 76.6929 25.6162 75.0835 25.2207L73.4742 24.833C71.1939 24.2822 70.1353 23.2158 70.1353 21.4853C70.1353 19.3427 72.0025 17.871 74.6538 17.871C77.2778 17.871 79.0767 19.3427 79.1372 21.4853H77.2612C77.1489 20.246 76.1245 19.498 74.6274 19.498C73.1304 19.498 72.106 20.2548 72.106 21.3564C72.106 22.2343 72.7603 22.7509 74.3608 23.1464L75.729 23.4823C78.2769 24.0849 79.3355 25.1083 79.3355 26.9247C79.3355 29.248 77.4849 30.703 74.5415 30.703C71.7876 30.703 69.9282 29.2821 69.8081 27.036L71.7105 27.0361Z" fill="white"/>
+<path d="M83.3462 19.2998V21.4424H85.0679V22.9141H83.3462V27.9053C83.3462 28.6807 83.6909 29.042 84.4478 29.042C84.6522 29.0384 84.8562 29.0241 85.0591 28.999V30.4619C84.7188 30.5255 84.373 30.5543 84.0269 30.5478C82.1939 30.5478 81.479 29.8593 81.479 28.1035V22.9141H80.1626V21.4424H81.479V19.2998H83.3462Z" fill="white"/>
+<path d="M86.065 25.9697C86.065 23.1211 87.7427 21.3311 90.3589 21.3311C92.9839 21.3311 94.6539 23.1211 94.6539 25.9697C94.6539 28.8262 92.9927 30.6084 90.3589 30.6084C87.7261 30.6084 86.065 28.8262 86.065 25.9697ZM92.7603 25.9697C92.7603 24.0156 91.8648 22.8623 90.3589 22.8623C88.8531 22.8623 87.9585 24.0244 87.9585 25.9697C87.9585 27.9316 88.8531 29.0762 90.3589 29.0762C91.8648 29.0762 92.7603 27.9316 92.7603 25.9697H92.7603Z" fill="white"/>
+<path d="M96.1861 21.4424H97.9585V22.9834H98.0015C98.1215 22.5021 98.4034 22.0768 98.8 21.7789C99.1966 21.481 99.6836 21.3287 100.179 21.3476C100.393 21.3469 100.607 21.3702 100.816 21.417V23.1553C100.546 23.0726 100.264 23.0347 99.981 23.043C99.711 23.032 99.4419 23.0796 99.192 23.1825C98.9422 23.2854 98.7176 23.4411 98.5336 23.639C98.3496 23.8369 98.2106 24.0723 98.1262 24.3289C98.0418 24.5856 98.0139 24.8575 98.0445 25.126V30.4961H96.1861L96.1861 21.4424Z" fill="white"/>
+<path d="M109.384 27.8369C109.134 29.4805 107.534 30.6084 105.486 30.6084C102.852 30.6084 101.217 28.8437 101.217 26.0127C101.217 23.1729 102.861 21.3311 105.408 21.3311C107.913 21.3311 109.488 23.0518 109.488 25.7969V26.4336H103.093V26.5459C103.064 26.8791 103.105 27.2148 103.216 27.5306C103.326 27.8464 103.502 28.1352 103.732 28.3778C103.963 28.6203 104.242 28.8111 104.552 28.9374C104.861 29.0637 105.195 29.1226 105.529 29.1103C105.968 29.1515 106.409 29.0498 106.785 28.8203C107.162 28.5909 107.455 28.246 107.62 27.8369L109.384 27.8369ZM103.102 25.1348H107.628C107.645 24.8352 107.6 24.5354 107.495 24.2541C107.39 23.9729 107.229 23.7164 107.02 23.5006C106.812 23.2849 106.561 23.1145 106.283 23.0003C106.006 22.8861 105.708 22.8305 105.408 22.8369C105.105 22.8351 104.805 22.8933 104.525 23.008C104.245 23.1227 103.99 23.2918 103.776 23.5054C103.562 23.7191 103.392 23.973 103.276 24.2527C103.16 24.5323 103.101 24.8321 103.102 25.1348V25.1348Z" fill="white"/>
+<path d="M37.8262 8.73101C38.2158 8.70305 38.6068 8.76191 38.9709 8.90335C39.335 9.04478 39.6632 9.26526 39.9318 9.54889C40.2004 9.83251 40.4026 10.1722 40.524 10.5435C40.6455 10.9148 40.6829 11.3083 40.6338 11.6959C40.6338 13.6021 39.6035 14.6979 37.8262 14.6979H35.6709V8.73101H37.8262ZM36.5977 13.854H37.7227C38.0011 13.8707 38.2797 13.825 38.5382 13.7204C38.7968 13.6158 39.0287 13.4548 39.2172 13.2493C39.4057 13.0437 39.546 12.7987 39.6279 12.5321C39.7097 12.2655 39.7311 11.9839 39.6904 11.708C39.7282 11.4332 39.7046 11.1534 39.6215 10.8887C39.5384 10.6241 39.3977 10.3811 39.2097 10.1771C39.0216 9.97322 38.7908 9.81341 38.5337 9.70917C38.2766 9.60494 37.9997 9.55885 37.7227 9.57422H36.5977V13.854Z" fill="white"/>
+<path d="M41.6807 12.4443C41.6524 12.1484 41.6862 11.8499 41.7801 11.5678C41.8739 11.2857 42.0257 11.0264 42.2256 10.8064C42.4255 10.5864 42.6693 10.4107 42.9411 10.2904C43.213 10.1701 43.507 10.108 43.8042 10.108C44.1015 10.108 44.3955 10.1701 44.6673 10.2904C44.9392 10.4107 45.1829 10.5864 45.3828 10.8064C45.5828 11.0264 45.7345 11.2857 45.8284 11.5678C45.9222 11.8499 45.9561 12.1484 45.9278 12.4443C45.9566 12.7406 45.9232 13.0396 45.8296 13.3221C45.736 13.6046 45.5843 13.8644 45.3843 14.0848C45.1843 14.3052 44.9404 14.4814 44.6683 14.6019C44.3962 14.7225 44.1018 14.7847 43.8042 14.7847C43.5066 14.7847 43.2123 14.7225 42.9401 14.6019C42.668 14.4814 42.4241 14.3052 42.2241 14.0848C42.0241 13.8644 41.8725 13.6046 41.7789 13.3221C41.6853 13.0396 41.6518 12.7406 41.6807 12.4443V12.4443ZM45.0137 12.4443C45.0137 11.4683 44.5752 10.8975 43.8057 10.8975C43.0332 10.8975 42.5987 11.4683 42.5987 12.4444C42.5987 13.4282 43.0333 13.9946 43.8057 13.9946C44.5752 13.9946 45.0137 13.4243 45.0137 12.4443H45.0137Z" fill="white"/>
+<path d="M51.5733 14.6978H50.6514L49.7207 11.3813H49.6504L48.7237 14.6978H47.8106L46.5694 10.1948H47.4707L48.2774 13.6308H48.3438L49.2696 10.1948H50.1221L51.0479 13.6308H51.1182L51.9209 10.1948H52.8096L51.5733 14.6978Z" fill="white"/>
+<path d="M53.8536 10.1948H54.709V10.9102H54.7754C54.8881 10.6532 55.0781 10.4379 55.319 10.2941C55.5598 10.1503 55.8396 10.0852 56.1192 10.1079C56.3383 10.0914 56.5583 10.1245 56.7629 10.2046C56.9675 10.2847 57.1514 10.4098 57.3011 10.5706C57.4508 10.7315 57.5624 10.9239 57.6276 11.1337C57.6928 11.3436 57.7099 11.5654 57.6778 11.7827V14.6977H56.7891V12.0059C56.7891 11.2822 56.4746 10.9224 55.8174 10.9224C55.6687 10.9154 55.5202 10.9408 55.3821 10.9966C55.244 11.0524 55.1197 11.1375 55.0176 11.2458C54.9154 11.3542 54.838 11.4834 54.7904 11.6245C54.7429 11.7657 54.7265 11.9154 54.7422 12.0635V14.6978H53.8535L53.8536 10.1948Z" fill="white"/>
+<path d="M59.0938 8.43701H59.9825V14.6978H59.0938V8.43701Z" fill="white"/>
+<path d="M61.2178 12.4443C61.1895 12.1484 61.2234 11.8498 61.3172 11.5677C61.4111 11.2857 61.5629 11.0263 61.7629 10.8063C61.9628 10.5863 62.2065 10.4106 62.4784 10.2903C62.7503 10.17 63.0443 10.1079 63.3416 10.1079C63.6389 10.1079 63.9329 10.17 64.2047 10.2903C64.4766 10.4106 64.7203 10.5863 64.9203 10.8063C65.1203 11.0263 65.272 11.2857 65.3659 11.5677C65.4598 11.8498 65.4936 12.1484 65.4654 12.4443C65.4942 12.7406 65.4607 13.0396 65.3671 13.3221C65.2734 13.6046 65.1218 13.8644 64.9217 14.0848C64.7217 14.3052 64.4778 14.4814 64.2057 14.6019C63.9335 14.7224 63.6392 14.7847 63.3416 14.7847C63.044 14.7847 62.7496 14.7224 62.4775 14.6019C62.2053 14.4814 61.9614 14.3052 61.7614 14.0848C61.5614 13.8644 61.4097 13.6046 61.3161 13.3221C61.2225 13.0396 61.189 12.7406 61.2178 12.4443V12.4443ZM64.5508 12.4443C64.5508 11.4683 64.1123 10.8975 63.3428 10.8975C62.5703 10.8975 62.1358 11.4683 62.1358 12.4444C62.1358 13.4282 62.5704 13.9946 63.3428 13.9946C64.1123 13.9946 64.5508 13.4243 64.5508 12.4443H64.5508Z" fill="white"/>
+<path d="M66.4009 13.4243C66.4009 12.6138 67.0044 12.1465 68.0757 12.0801L69.2954 12.0098V11.6211C69.2954 11.1455 68.981 10.877 68.3736 10.877C67.8775 10.877 67.5337 11.0591 67.4351 11.3775H66.5747C66.6656 10.604 67.3931 10.1079 68.4146 10.1079C69.5435 10.1079 70.1802 10.6699 70.1802 11.6211V14.6978H69.3247V14.065H69.2544C69.1117 14.292 68.9113 14.477 68.6737 14.6012C68.4361 14.7254 68.1697 14.7844 67.9019 14.772C67.7129 14.7916 67.5218 14.7715 67.341 14.7128C67.1603 14.6541 66.9938 14.5581 66.8524 14.4312C66.711 14.3042 66.5977 14.149 66.52 13.9756C66.4422 13.8022 66.4017 13.6144 66.4009 13.4243V13.4243ZM69.2954 13.0396V12.6631L68.1958 12.7334C67.5757 12.7749 67.2945 12.9859 67.2945 13.3828C67.2945 13.7881 67.646 14.0239 68.1295 14.0239C68.2711 14.0383 68.4142 14.024 68.5502 13.9819C68.6862 13.9398 68.8123 13.8708 68.9211 13.7789C69.0299 13.6871 69.1191 13.5743 69.1834 13.4473C69.2477 13.3203 69.2858 13.1816 69.2954 13.0396V13.0396Z" fill="white"/>
+<path d="M71.3482 12.4444C71.3482 11.0215 72.0796 10.1201 73.2173 10.1201C73.4987 10.1072 73.778 10.1746 74.0226 10.3145C74.2671 10.4544 74.4667 10.661 74.5982 10.9101H74.6646V8.43701H75.5533V14.6978H74.7017V13.9863H74.6314C74.4898 14.2338 74.2832 14.4378 74.0339 14.5763C73.7847 14.7148 73.5023 14.7825 73.2173 14.772C72.0718 14.772 71.3482 13.8706 71.3482 12.4444ZM72.2662 12.4444C72.2662 13.3994 72.7164 13.9741 73.4693 13.9741C74.2183 13.9741 74.6812 13.3911 74.6812 12.4483C74.6812 11.5098 74.2134 10.9185 73.4693 10.9185C72.7212 10.9185 72.2661 11.4971 72.2661 12.4444H72.2662Z" fill="white"/>
+<path d="M79.23 12.4443C79.2017 12.1484 79.2356 11.8499 79.3294 11.5678C79.4232 11.2857 79.575 11.0264 79.7749 10.8064C79.9749 10.5864 80.2186 10.4107 80.4904 10.2904C80.7623 10.1701 81.0563 10.108 81.3536 10.108C81.6508 10.108 81.9448 10.1701 82.2167 10.2904C82.4885 10.4107 82.7322 10.5864 82.9322 10.8064C83.1321 11.0264 83.2839 11.2857 83.3777 11.5678C83.4715 11.8499 83.5054 12.1484 83.4771 12.4443C83.5059 12.7406 83.4725 13.0396 83.3789 13.3221C83.2853 13.6046 83.1336 13.8644 82.9336 14.0848C82.7336 14.3052 82.4897 14.4814 82.2176 14.6019C81.9455 14.7225 81.6512 14.7847 81.3536 14.7847C81.0559 14.7847 80.7616 14.7225 80.4895 14.6019C80.2173 14.4814 79.9735 14.3052 79.7735 14.0848C79.5735 13.8644 79.4218 13.6046 79.3282 13.3221C79.2346 13.0396 79.2012 12.7406 79.23 12.4443V12.4443ZM82.563 12.4443C82.563 11.4683 82.1245 10.8975 81.355 10.8975C80.5826 10.8975 80.148 11.4683 80.148 12.4444C80.148 13.4282 80.5826 13.9946 81.355 13.9946C82.1245 13.9946 82.563 13.4243 82.563 12.4443Z" fill="white"/>
+<path d="M84.6695 10.1948H85.5249V10.9102H85.5913C85.704 10.6532 85.894 10.4379 86.1349 10.2941C86.3757 10.1503 86.6555 10.0852 86.9351 10.1079C87.1542 10.0914 87.3742 10.1245 87.5788 10.2046C87.7834 10.2847 87.9673 10.4098 88.117 10.5706C88.2667 10.7315 88.3783 10.9239 88.4435 11.1337C88.5087 11.3436 88.5258 11.5654 88.4937 11.7827V14.6977H87.605V12.0059C87.605 11.2822 87.2906 10.9224 86.6333 10.9224C86.4846 10.9154 86.3361 10.9408 86.198 10.9966C86.06 11.0524 85.9356 11.1375 85.8335 11.2458C85.7314 11.3542 85.6539 11.4834 85.6064 11.6245C85.5588 11.7657 85.5424 11.9154 85.5581 12.0635V14.6978H84.6695V10.1948Z" fill="white"/>
+<path d="M93.5152 9.07373V10.2153H94.4908V10.9639H93.5152V13.2793C93.5152 13.751 93.7095 13.9575 94.1519 13.9575C94.2651 13.9572 94.3783 13.9503 94.4908 13.937V14.6772C94.3312 14.7058 94.1695 14.721 94.0074 14.7226C93.0191 14.7226 92.6255 14.375 92.6255 13.5068V10.9638H91.9107V10.2153H92.6255V9.07373H93.5152Z" fill="white"/>
+<path d="M95.7046 8.43701H96.5855V10.9185H96.6558C96.7739 10.6591 96.9691 10.4425 97.2148 10.2982C97.4605 10.1539 97.7448 10.0888 98.0288 10.1118C98.2467 10.1 98.4646 10.1364 98.6669 10.2184C98.8692 10.3004 99.0509 10.4261 99.199 10.5864C99.3471 10.7468 99.458 10.9378 99.5238 11.146C99.5896 11.3541 99.6086 11.5742 99.5796 11.7905V14.6978H98.69V12.0098C98.69 11.2905 98.355 10.9263 97.7271 10.9263C97.5744 10.9137 97.4207 10.9347 97.277 10.9878C97.1332 11.0408 97.0027 11.1247 96.8948 11.2334C96.7868 11.3421 96.7038 11.4732 96.6518 11.6173C96.5997 11.7614 96.5798 11.9152 96.5933 12.0679V14.6977H95.7047L95.7046 8.43701Z" fill="white"/>
+<path d="M104.761 13.4819C104.641 13.8935 104.379 14.2495 104.022 14.4876C103.666 14.7258 103.236 14.8309 102.81 14.7847C102.513 14.7925 102.219 14.7357 101.946 14.6182C101.674 14.5006 101.43 14.3252 101.232 14.1041C101.034 13.8829 100.887 13.6214 100.8 13.3376C100.713 13.0537 100.689 12.7544 100.73 12.4605C100.691 12.1656 100.715 11.8656 100.801 11.581C100.888 11.2963 101.034 11.0335 101.231 10.8105C101.428 10.5874 101.671 10.4092 101.942 10.288C102.214 10.1668 102.509 10.1054 102.806 10.1079C104.059 10.1079 104.815 10.9639 104.815 12.3779V12.688H101.635V12.7378C101.621 12.9031 101.642 13.0694 101.696 13.2261C101.75 13.3829 101.837 13.5266 101.95 13.6481C102.062 13.7695 102.2 13.866 102.352 13.9314C102.504 13.9968 102.669 14.0297 102.835 14.0278C103.047 14.0533 103.262 14.0151 103.453 13.9178C103.644 13.8206 103.802 13.6689 103.906 13.4819L104.761 13.4819ZM101.635 12.0308H103.91C103.921 11.8796 103.9 11.7278 103.849 11.5851C103.798 11.4424 103.718 11.3119 103.614 11.2021C103.509 11.0922 103.383 11.0054 103.243 10.9472C103.103 10.8891 102.953 10.8608 102.801 10.8643C102.648 10.8623 102.495 10.8912 102.353 10.9491C102.21 11.0071 102.081 11.0929 101.972 11.2017C101.864 11.3104 101.778 11.4397 101.72 11.5821C101.662 11.7245 101.633 11.8771 101.635 12.0308H101.635Z" fill="white"/>
+</svg>

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";
+    }
+  }
+})();

apps/smp-server/static/media/f_droid.svg

@@ -0,0 +1,372 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<svg
+   width="560"
+   height="164"
+   version="1.1"
+   id="svg1048"
+   sodipodi:docname="f_droid.svg"
+   inkscape:version="1.1.2 (0a00cf5339, 2022-02-04, custom)"
+   xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
+   xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
+   xmlns:xlink="http://www.w3.org/1999/xlink"
+   xmlns="http://www.w3.org/2000/svg"
+   xmlns:svg="http://www.w3.org/2000/svg">
+  <sodipodi:namedview
+     id="namedview1050"
+     pagecolor="#505050"
+     bordercolor="#ffffff"
+     borderopacity="1"
+     inkscape:pageshadow="0"
+     inkscape:pageopacity="0"
+     inkscape:pagecheckerboard="1"
+     showgrid="false"
+     inkscape:snap-bbox="true"
+     inkscape:bbox-paths="true"
+     inkscape:bbox-nodes="true"
+     inkscape:snap-bbox-edge-midpoints="true"
+     inkscape:snap-bbox-midpoints="true"
+     inkscape:snap-intersection-paths="true"
+     inkscape:object-paths="true"
+     inkscape:snap-smooth-nodes="true"
+     inkscape:snap-midpoints="true"
+     inkscape:snap-object-midpoints="true"
+     inkscape:snap-center="true"
+     inkscape:snap-text-baseline="true"
+     inkscape:snap-page="true"
+     fit-margin-top="0"
+     fit-margin-left="0"
+     fit-margin-right="0"
+     fit-margin-bottom="0"
+     inkscape:zoom="1.1996734"
+     inkscape:cx="186.71748"
+     inkscape:cy="100.02722"
+     inkscape:window-width="1920"
+     inkscape:window-height="1007"
+     inkscape:window-x="0"
+     inkscape:window-y="0"
+     inkscape:window-maximized="1"
+     inkscape:current-layer="svg1048" />
+  <defs
+     id="defs974">
+    <linearGradient
+       id="a">
+      <stop
+         offset="0"
+         stop-color="#fff"
+         stop-opacity=".098"
+         id="stop968" />
+      <stop
+         offset="1"
+         stop-color="#fff"
+         stop-opacity="0"
+         id="stop970" />
+    </linearGradient>
+    <radialGradient
+       xlink:href="#a"
+       id="b"
+       cx="113"
+       cy="-12.89"
+       fx="113"
+       fy="-12.89"
+       r="59.661999"
+       gradientTransform="matrix(0,1.96105,-1.97781,0,254.507,78.763)"
+       gradientUnits="userSpaceOnUse" />
+  </defs>
+  <g
+     transform="translate(-332,-355.362)"
+     id="g1046">
+    <rect
+       style="stroke:none;marker:none"
+       width="560"
+       height="164"
+       x="332"
+       y="355.362"
+       rx="20"
+       ry="20"
+       color="#000000"
+       overflow="visible"
+       stroke="#a6a6a6"
+       stroke-width="4"
+       id="rect976" />
+    <text
+       y="402.367"
+       x="508.95099"
+       style="line-height:100%;-inkscape-font-specification:'DejaVu Sans';marker:none"
+       color="#000000"
+       font-weight="400"
+       font-size="12.395px"
+       font-family="'DejaVu Sans'"
+       letter-spacing="0"
+       word-spacing="0"
+       overflow="visible"
+       fill="#ffffff"
+       id="text980"><tspan
+         y="402.367"
+         x="508.95099"
+         style="-inkscape-font-specification:'DejaVu Sans'"
+         font-size="34.125px"
+         id="tspan978">GET IT ON</tspan></text>
+    <text
+       style="line-height:100%;-inkscape-font-specification:'Rokkitt Bold';text-align:start;marker:none"
+       x="508.21301"
+       y="489.36099"
+       color="#000000"
+       font-weight="700"
+       font-size="29.709px"
+       font-family="Rokkitt"
+       letter-spacing="0"
+       word-spacing="0"
+       overflow="visible"
+       fill="#ffffff"
+       id="text984"><tspan
+         x="508.21301"
+         y="489.36099"
+         style="line-height:100%;-inkscape-font-specification:'Roboto Slab Bold';text-align:start"
+         font-size="95px"
+         font-family="'Roboto Slab'"
+         id="tspan982">F-Droid</tspan></text>
+    <g
+       fill-rule="evenodd"
+       id="g994">
+      <path
+         d="m 2.589,1006.862 4.25,5.5"
+         fill="#8ab000"
+         stroke="#769616"
+         stroke-width="2.5"
+         stroke-linecap="round"
+         transform="matrix(-2.63159,0,0,2.63157,483.158,-2270.475)"
+         id="path986" />
+      <path
+         style="line-height:normal;text-indent:0;text-align:start;text-decoration-line:none;text-decoration-style:solid;text-decoration-color:#000000;text-transform:none;isolation:auto;mix-blend-mode:normal"
+         d="m 476.286,375.862 c 1.193,0.031 2.004,0.497 2.58,1.18 -5.333,6.34 -6.232,7.347 -13.514,16.372 -2.683,3.472 -5.478,1.678 -2.795,-1.793 l 11.185,-14.474 c 0.602,-0.804 1.54,-1.258 2.544,-1.285 z"
+         color="#000000"
+         font-weight="400"
+         font-family="sans-serif"
+         white-space="normal"
+         overflow="visible"
+         fill="#ffffff"
+         fill-opacity="0.298"
+         id="path988" />
+      <path
+         style="line-height:normal;text-indent:0;text-align:start;text-decoration-line:none;text-decoration-style:solid;text-decoration-color:#000000;text-transform:none;isolation:auto;mix-blend-mode:normal"
+         d="m 478.89,377.075 c 0.325,0.39 1.476,2.118 0.058,4.096 l -11.184,14.473 c -2.683,3.471 -3.026,-1.611 -3.026,-1.611 0,0 9.828,-11.869 14.151,-16.958 z"
+         color="#000000"
+         font-weight="400"
+         font-family="sans-serif"
+         white-space="normal"
+         overflow="visible"
+         fill="#263238"
+         fill-opacity="0.2"
+         id="path990" />
+      <path
+         style="line-height:normal;text-indent:0;text-align:start;text-decoration-line:none;text-decoration-style:solid;text-decoration-color:#000000;text-transform:none;isolation:auto;mix-blend-mode:normal"
+         d="m 477.006,376.48 c 1.153,0 2.525,0.373 2.169,2.102 -0.273,1.32 -12.266,15.985 -12.266,15.985 -2.683,3.47 -6.562,1.78 -3.879,-1.691 l 11.143,-14.402 c 0.685,-0.763 1.602,-1.957 2.833,-1.994 z"
+         color="#000000"
+         font-weight="400"
+         font-family="sans-serif"
+         white-space="normal"
+         overflow="visible"
+         fill="#8ab000"
+         id="path992" />
+    </g>
+    <g
+       fill-rule="evenodd"
+       id="g1004">
+      <path
+         d="m 2.589,1006.862 4.25,5.5"
+         fill="#8ab000"
+         stroke="#769616"
+         stroke-width="2.5"
+         stroke-linecap="round"
+         transform="matrix(2.63159,0,0,2.63157,356.842,-2270.475)"
+         id="path996" />
+      <path
+         d="m 363.714,375.862 c -1.193,0.031 -2.004,0.497 -2.58,1.18 5.333,6.34 6.232,7.347 13.514,16.372 2.683,3.472 5.478,1.678 2.795,-1.793 l -11.185,-14.474 c -0.602,-0.804 -1.54,-1.258 -2.544,-1.285 z"
+         style="line-height:normal;text-indent:0;text-align:start;text-decoration-line:none;text-decoration-style:solid;text-decoration-color:#000000;text-transform:none;isolation:auto;mix-blend-mode:normal"
+         color="#000000"
+         font-weight="400"
+         font-family="sans-serif"
+         white-space="normal"
+         overflow="visible"
+         fill="#ffffff"
+         fill-opacity="0.298"
+         id="path998" />
+      <path
+         d="m 361.11,377.075 c -0.325,0.39 -1.476,2.118 -0.058,4.096 l 11.184,14.473 c 2.683,3.471 3.026,-1.611 3.026,-1.611 0,0 -9.828,-11.869 -14.151,-16.958 z"
+         style="line-height:normal;text-indent:0;text-align:start;text-decoration-line:none;text-decoration-style:solid;text-decoration-color:#000000;text-transform:none;isolation:auto;mix-blend-mode:normal"
+         color="#000000"
+         font-weight="400"
+         font-family="sans-serif"
+         white-space="normal"
+         overflow="visible"
+         fill="#263238"
+         fill-opacity="0.2"
+         id="path1000" />
+      <path
+         d="m 362.995,376.48 c -1.153,0 -2.526,0.373 -2.17,2.102 0.273,1.32 12.266,15.985 12.266,15.985 2.683,3.47 6.562,1.78 3.879,-1.691 l -11.143,-14.402 c -0.685,-0.763 -1.602,-1.957 -2.832,-1.994 z"
+         style="line-height:normal;text-indent:0;text-align:start;text-decoration-line:none;text-decoration-style:solid;text-decoration-color:#000000;text-transform:none;isolation:auto;mix-blend-mode:normal"
+         color="#000000"
+         font-weight="400"
+         font-family="sans-serif"
+         white-space="normal"
+         overflow="visible"
+         fill="#8ab000"
+         id="path1002" />
+    </g>
+    <g
+       transform="matrix(2.63159,0,0,2.63157,467.369,-2270.475)"
+       id="g1014">
+      <rect
+         ry="3"
+         rx="3"
+         y="1010.36"
+         x="-37"
+         height="12.92"
+         width="38"
+         fill="#aeea00"
+         id="rect1006" />
+      <rect
+         width="38"
+         height="10"
+         x="-37"
+         y="1013.279"
+         rx="3"
+         ry="3"
+         fill="#263238"
+         fill-opacity="0.2"
+         id="rect1008" />
+      <rect
+         width="38"
+         height="10"
+         x="-37"
+         y="1010.362"
+         rx="3"
+         ry="3"
+         fill="#ffffff"
+         fill-opacity="0.298"
+         id="rect1010" />
+      <rect
+         width="38"
+         height="10.641"
+         x="-37"
+         y="1011.5"
+         rx="3"
+         ry="2.4560001"
+         fill="#aeea00"
+         id="rect1012" />
+    </g>
+    <g
+       transform="matrix(2.63159,0,0,2.63157,356.842,-2270.745)"
+       id="g1024">
+      <rect
+         ry="3"
+         rx="3"
+         y="1024.522"
+         x="5"
+         height="25.84"
+         width="38"
+         fill="#1976d2"
+         id="rect1016" />
+      <rect
+         width="38"
+         height="13"
+         x="5"
+         y="1037.3621"
+         rx="3"
+         ry="3"
+         fill="#263238"
+         fill-opacity="0.2"
+         id="rect1018" />
+      <rect
+         width="38"
+         height="13"
+         x="5"
+         y="1024.442"
+         rx="3"
+         ry="3"
+         fill="#ffffff"
+         fill-opacity="0.2"
+         id="rect1020" />
+      <rect
+         width="38"
+         height="23.559999"
+         x="5"
+         y="1025.662"
+         rx="3"
+         ry="2.7179999"
+         fill="#1976d2"
+         id="rect1022" />
+    </g>
+    <g
+       transform="matrix(2.63159,0,0,2.63157,356.842,396.264)"
+       id="g1030">
+      <path
+         d="m 24,17.75 c -2.88,0 -5.32,1.985 -6.033,4.65 H 21.18 A 3.215,3.215 0 0 1 24,20.75 3.228,3.228 0 0 1 27.25,24 3.228,3.228 0 0 1 24,27.25 3.219,3.219 0 0 1 21.07,25.4 h -3.154 c 0.642,2.766 3.132,4.85 6.084,4.85 3.434,0 6.25,-2.816 6.25,-6.25 0,-3.434 -2.816,-6.25 -6.25,-6.25 z"
+         style="line-height:normal;text-indent:0;text-align:start;text-decoration-line:none;text-decoration-style:solid;text-decoration-color:#000000;text-transform:none;isolation:auto;mix-blend-mode:normal"
+         color="#000000"
+         font-weight="400"
+         font-family="sans-serif"
+         white-space="normal"
+         overflow="visible"
+         fill="#0d47a1"
+         id="path1026" />
+      <circle
+         r="9.5500002"
+         cy="24"
+         cx="24"
+         fill="none"
+         stroke="#0d47a1"
+         stroke-width="1.9"
+         stroke-linecap="round"
+         id="circle1028" />
+    </g>
+    <g
+       transform="matrix(2.63159,0,0,2.63157,356.842,-2269.159)"
+       id="g1036">
+      <ellipse
+         ry="3.875"
+         rx="3.375"
+         cx="14.375"
+         cy="1016.487"
+         fill="#263238"
+         fill-opacity="0.2"
+         id="ellipse1032" />
+      <circle
+         r="3.375"
+         cy="1016.987"
+         cx="14.375"
+         fill="#ffffff"
+         id="circle1034" />
+    </g>
+    <g
+       transform="matrix(2.63159,0,0,2.63157,408.158,-2269.159)"
+       id="g1042">
+      <ellipse
+         cy="1016.487"
+         cx="14.375"
+         rx="3.375"
+         ry="3.875"
+         fill="#263238"
+         fill-opacity="0.2"
+         id="ellipse1038" />
+      <circle
+         cx="14.375"
+         cy="1016.987"
+         r="3.375"
+         fill="#ffffff"
+         id="circle1040" />
+    </g>
+    <path
+       d="m 282.715,299.835 a 3.29,3.29 0 0 0 -2.662,5.336 l 9.474,12.261 A 7.894,7.894 0 0 0 289,320.257 v 18.21 a 7.877,7.877 0 0 0 7.895,7.895 h 84.21 A 7.877,7.877 0 0 0 389,338.468 v -18.211 c 0,-0.999 -0.19,-1.949 -0.525,-2.826 l 9.472,-12.26 a 3.29,3.29 0 0 0 -2.433,-5.334 3.29,3.29 0 0 0 -2.772,1.31 l -9.013,11.666 a 7.91,7.91 0 0 0 -2.624,-0.45 h -84.21 c -0.922,0 -1.8,0.163 -2.622,0.45 l -9.015,-11.666 a 3.29,3.29 0 0 0 -2.543,-1.312 z m 14.18,49.527 A 7.877,7.877 0 0 0 289,357.257 v 52.21 a 7.877,7.877 0 0 0 7.895,7.895 h 84.21 A 7.877,7.877 0 0 0 389,409.468 v -52.211 a 7.877,7.877 0 0 0 -7.895,-7.895 z"
+       style="line-height:normal;text-indent:0;text-align:start;text-decoration-line:none;text-decoration-style:solid;text-decoration-color:#000000;text-transform:none;isolation:auto;mix-blend-mode:normal;fill:url(#b)"
+       color="#000000"
+       font-weight="400"
+       font-family="sans-serif"
+       white-space="normal"
+       overflow="visible"
+       fill="url(#b)"
+       fill-rule="evenodd"
+       transform="translate(81,76)"
+       id="path1044" />
+  </g>
+</svg>

apps/smp-server/static/media/google_play.svg

@@ -0,0 +1,39 @@
+<svg width="135" height="41" viewBox="0 0 135 41" fill="none" xmlns="http://www.w3.org/2000/svg">
+<path d="M130 40.5H5C2.2 40.5 0 38.3 0 35.5V5.5C0 2.7 2.2 0.5 5 0.5H130C132.8 0.5 135 2.7 135 5.5V35.5C135 38.3 132.8 40.5 130 40.5Z" fill="black"/>
+<path d="M47.4 10.7C47.4 11.5 47.2 12.2 46.7 12.7C46.1 13.3 45.4 13.6 44.5 13.6C43.6 13.6 42.9 13.3 42.3 12.7C41.7 12.1 41.4 11.4 41.4 10.5C41.4 9.60002 41.7 8.90002 42.3 8.30002C42.9 7.70002 43.6 7.40002 44.5 7.40002C44.9 7.40002 45.3 7.50002 45.7 7.70002C46.1 7.90002 46.4 8.10002 46.6 8.40002L46.1 8.90002C45.7 8.40002 45.2 8.20002 44.5 8.20002C43.9 8.20002 43.3 8.40002 42.9 8.90002C42.4 9.30002 42.2 9.90002 42.2 10.6C42.2 11.3 42.4 11.9 42.9 12.3C43.4 12.7 43.9 13 44.5 13C45.2 13 45.7 12.8 46.2 12.3C46.5 12 46.7 11.6 46.7 11.1H44.5V10.3H47.4V10.7V10.7ZM52 8.20002H49.3V10.1H51.8V10.8H49.3V12.7H52V13.5H48.5V7.50002H52V8.20002ZM55.3 13.5H54.5V8.20002H52.8V7.50002H57V8.20002H55.3V13.5ZM59.9 13.5V7.50002H60.7V13.5H59.9ZM64.1 13.5H63.3V8.20002H61.6V7.50002H65.7V8.20002H64V13.5H64.1ZM73.6 12.7C73 13.3 72.3 13.6 71.4 13.6C70.5 13.6 69.8 13.3 69.2 12.7C68.6 12.1 68.3 11.4 68.3 10.5C68.3 9.60002 68.6 8.90002 69.2 8.30002C69.8 7.70002 70.5 7.40002 71.4 7.40002C72.3 7.40002 73 7.70002 73.6 8.30002C74.2 8.90002 74.5 9.60002 74.5 10.5C74.5 11.4 74.2 12.1 73.6 12.7ZM69.8 12.2C70.2 12.6 70.8 12.9 71.4 12.9C72 12.9 72.6 12.7 73 12.2C73.4 11.8 73.7 11.2 73.7 10.5C73.7 9.80002 73.5 9.20002 73 8.80002C72.6 8.40002 72 8.10002 71.4 8.10002C70.8 8.10002 70.2 8.30002 69.8 8.80002C69.4 9.20002 69.1 9.80002 69.1 10.5C69.1 11.2 69.3 11.8 69.8 12.2ZM75.6 13.5V7.50002H76.5L79.4 12.2V7.50002H80.2V13.5H79.4L76.3 8.60002V13.5H75.6V13.5Z" fill="white" stroke="white" stroke-width="0.2" stroke-miterlimit="10"/>
+<path d="M68.1 22.3C65.7 22.3 63.8 24.1 63.8 26.6C63.8 29 65.7 30.9 68.1 30.9C70.5 30.9 72.4 29.1 72.4 26.6C72.4 24 70.5 22.3 68.1 22.3ZM68.1 29.1C66.8 29.1 65.7 28 65.7 26.5C65.7 25 66.8 23.9 68.1 23.9C69.4 23.9 70.5 24.9 70.5 26.5C70.5 28 69.4 29.1 68.1 29.1ZM58.8 22.3C56.4 22.3 54.5 24.1 54.5 26.6C54.5 29 56.4 30.9 58.8 30.9C61.2 30.9 63.1 29.1 63.1 26.6C63.1 24 61.2 22.3 58.8 22.3ZM58.8 29.1C57.5 29.1 56.4 28 56.4 26.5C56.4 25 57.5 23.9 58.8 23.9C60.1 23.9 61.2 24.9 61.2 26.5C61.2 28 60.1 29.1 58.8 29.1ZM47.7 23.6V25.4H52C51.9 26.4 51.5 27.2 51 27.7C50.4 28.3 49.4 29 47.7 29C45 29 43 26.9 43 24.2C43 21.5 45.1 19.4 47.7 19.4C49.1 19.4 50.2 20 51 20.7L52.3 19.4C51.2 18.4 49.8 17.6 47.8 17.6C44.2 17.6 41.1 20.6 41.1 24.2C41.1 27.8 44.2 30.8 47.8 30.8C49.8 30.8 51.2 30.2 52.4 28.9C53.6 27.7 54 26 54 24.7C54 24.3 54 23.9 53.9 23.6H47.7V23.6ZM93.1 25C92.7 24 91.7 22.3 89.5 22.3C87.3 22.3 85.5 24 85.5 26.6C85.5 29 87.3 30.9 89.7 30.9C91.6 30.9 92.8 29.7 93.2 29L91.8 28C91.3 28.7 90.7 29.2 89.7 29.2C88.7 29.2 88.1 28.8 87.6 27.9L93.3 25.5L93.1 25V25ZM87.3 26.4C87.3 24.8 88.6 23.9 89.5 23.9C90.2 23.9 90.9 24.3 91.1 24.8L87.3 26.4ZM82.6 30.5H84.5V18H82.6V30.5ZM79.6 23.2C79.1 22.7 78.3 22.2 77.3 22.2C75.2 22.2 73.2 24.1 73.2 26.5C73.2 28.9 75.1 30.7 77.3 30.7C78.3 30.7 79.1 30.2 79.5 29.7H79.6V30.3C79.6 31.9 78.7 32.8 77.3 32.8C76.2 32.8 75.4 32 75.2 31.3L73.6 32C74.1 33.1 75.3 34.5 77.4 34.5C79.6 34.5 81.4 33.2 81.4 30.1V22.5H79.6V23.2V23.2ZM77.4 29.1C76.1 29.1 75 28 75 26.5C75 25 76.1 23.9 77.4 23.9C78.7 23.9 79.7 25 79.7 26.5C79.7 28 78.7 29.1 77.4 29.1ZM101.8 18H97.3V30.5H99.2V25.8H101.8C103.9 25.8 105.9 24.3 105.9 21.9C105.9 19.5 103.9 18 101.8 18V18ZM101.9 24H99.2V19.7H101.9C103.3 19.7 104.1 20.9 104.1 21.8C104 22.9 103.2 24 101.9 24ZM113.4 22.2C112 22.2 110.6 22.8 110.1 24.1L111.8 24.8C112.2 24.1 112.8 23.9 113.5 23.9C114.5 23.9 115.4 24.5 115.5 25.5V25.6C115.2 25.4 114.4 25.1 113.6 25.1C111.8 25.1 110 26.1 110 27.9C110 29.6 111.5 30.7 113.1 30.7C114.4 30.7 115 30.1 115.5 29.5H115.6V30.5H117.4V25.7C117.2 23.5 115.5 22.2 113.4 22.2V22.2ZM113.2 29.1C112.6 29.1 111.7 28.8 111.7 28C111.7 27 112.8 26.7 113.7 26.7C114.5 26.7 114.9 26.9 115.4 27.1C115.2 28.3 114.2 29.1 113.2 29.1V29.1ZM123.7 22.5L121.6 27.9H121.5L119.3 22.5H117.3L120.6 30.1L118.7 34.3H120.6L125.7 22.5H123.7V22.5ZM106.9 30.5H108.8V18H106.9V30.5Z" fill="white"/>
+<path d="M10.4 8C10.1 8.3 10 8.8 10 9.4V31.5C10 32.1 10.2 32.6 10.5 32.9L10.6 33L23 20.6V20.4L10.4 8Z" fill="url(#paint0_linear_7_408)"/>
+<path d="M27 24.8L22.9 20.7V20.4L27 16.3L27.1 16.4L32 19.2C33.4 20 33.4 21.3 32 22.1L27 24.8V24.8Z" fill="url(#paint1_linear_7_408)"/>
+<path d="M27.1 24.7L22.9 20.5L10.4 33C10.9 33.5 11.6 33.5 12.5 33.1L27.1 24.7" fill="url(#paint2_linear_7_408)"/>
+<path d="M27.1 16.3001L12.5 8.00005C11.6 7.50005 10.9 7.60005 10.4 8.10005L22.9 20.5001L27.1 16.3001V16.3001Z" fill="url(#paint3_linear_7_408)"/>
+<path opacity="0.2" d="M27 24.6L12.5 32.8C11.7 33.3 11 33.2 10.5 32.8L10.4 32.9L10.5 33C11 33.4 11.7 33.5 12.5 33L27 24.6Z" fill="black"/>
+<path opacity="0.12" d="M10.4 32.8C10.1 32.5 10 32 10 31.4V31.5C10 32.1 10.2 32.6 10.5 32.9V32.8H10.4ZM32 21.8L27 24.6L27.1 24.7L32 21.9C32.7 21.5 33 21 33 20.5C33 21 32.6 21.4 32 21.8V21.8Z" fill="black"/>
+<path opacity="0.25" d="M12.5 8.10003L32 19.2C32.6 19.6 33 20 33 20.5C33 20 32.7 19.5 32 19.1L12.5 8.00003C11.1 7.20003 10 7.80003 10 9.40003V9.50003C10 8.00003 11.1 7.30003 12.5 8.10003Z" fill="white"/>
+<defs>
+<linearGradient id="paint0_linear_7_408" x1="21.8" y1="9.21" x2="5.017" y2="25.992" gradientUnits="userSpaceOnUse">
+<stop stop-color="#00A0FF"/>
+<stop offset="0.007" stop-color="#00A1FF"/>
+<stop offset="0.26" stop-color="#00BEFF"/>
+<stop offset="0.512" stop-color="#00D2FF"/>
+<stop offset="0.76" stop-color="#00DFFF"/>
+<stop offset="1" stop-color="#00E3FF"/>
+</linearGradient>
+<linearGradient id="paint1_linear_7_408" x1="33.834" y1="20.501" x2="9.63699" y2="20.501" gradientUnits="userSpaceOnUse">
+<stop stop-color="#FFE000"/>
+<stop offset="0.409" stop-color="#FFBD00"/>
+<stop offset="0.775" stop-color="#FFA500"/>
+<stop offset="1" stop-color="#FF9C00"/>
+</linearGradient>
+<linearGradient id="paint2_linear_7_408" x1="24.827" y1="22.796" x2="2.069" y2="45.554" gradientUnits="userSpaceOnUse">
+<stop stop-color="#FF3A44"/>
+<stop offset="1" stop-color="#C31162"/>
+</linearGradient>
+<linearGradient id="paint3_linear_7_408" x1="7.29699" y1="0.676051" x2="17.46" y2="10.8391" gradientUnits="userSpaceOnUse">
+<stop stop-color="#32A071"/>
+<stop offset="0.069" stop-color="#2DA771"/>
+<stop offset="0.476" stop-color="#15CF74"/>
+<stop offset="0.801" stop-color="#06E775"/>
+<stop offset="1" stop-color="#00F076"/>
+</linearGradient>
+</defs>
+</svg>

apps/smp-server/static/media/logo-symbol-dark.svg

@@ -0,0 +1,10 @@
+<svg width="34" height="35" viewBox="0 0 34 35" fill="none" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M3.02958 8.60922L8.622 14.2013L14.3705 8.45375L17.1669 11.2498L11.4183 16.9972L17.0114 22.5895L14.1373 25.4633L8.54422 19.871L2.79636 25.6187L0 22.8227L5.74794 17.075L0.155484 11.483L3.02958 8.60922Z" fill="white"/>
+<path fill-rule="evenodd" clip-rule="evenodd" d="M14.0923 25.5156L16.944 22.6642L16.9429 22.6634L22.6467 16.9612L17.0513 11.3675L17.0523 11.367L14.2548 8.56979L8.65972 2.97535L11.5114 0.123963L17.1061 5.71849L22.8099 0.015625L25.6074 2.81285L19.9035 8.51562L25.4984 14.1099L31.2025 8.40729L34 11.2045L28.2958 16.907L33.8917 22.5017L31.0399 25.3531L25.4442 19.7584L19.7409 25.4611L25.3365 31.0559L22.4848 33.9073L16.8892 28.3124L11.1864 34.0156L8.38885 31.2184L14.0923 25.5156Z" fill="url(#paint0_linear_656_10815)"/>
+<defs>
+<linearGradient id="paint0_linear_656_10815" x1="12.8381" y1="-0.678252" x2="9.54355" y2="31.4493" gradientUnits="userSpaceOnUse">
+<stop stop-color="#01F1FF"/>
+<stop offset="1" stop-color="#0197FF"/>
+</linearGradient>
+</defs>
+</svg>

apps/smp-server/static/media/logo-symbol-light.svg

@@ -0,0 +1,15 @@
+<svg width="34" height="34" viewBox="0 0 34 34" fill="none" xmlns="http://www.w3.org/2000/svg">
+<g clip-path="url(#clip0_14_10)">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M3.02972 8.59396L8.62219 14.186L14.3703 8.43848L17.1668 11.2346L11.4182 16.982L17.0112 22.5742L14.1371 25.448L8.5441 19.8557L2.79651 25.6035L0 22.8074L5.74813 17.0597L0.155656 11.4678L3.02972 8.59396Z" fill="#023789"/>
+<path fill-rule="evenodd" clip-rule="evenodd" d="M14.0922 25.5L16.9434 22.6486L16.9423 22.6478L22.6464 16.9456L17.0512 11.3519L17.0518 11.3514L14.2542 8.55418L8.65961 2.95973L11.5114 0.108337L17.106 5.70288L22.8095 0L25.607 2.79722L19.903 8.5L25.4981 14.0943L31.2022 8.39169L33.9997 11.1889L28.2957 16.8914L33.8914 22.4861L31.0396 25.3375L25.4439 19.7428L19.7404 25.4454L25.3361 31.0403L22.4843 33.8917L16.8887 28.2968L11.1862 34L8.38867 31.2028L14.0922 25.5Z" fill="url(#paint0_linear_14_10)"/>
+</g>
+<defs>
+<linearGradient id="paint0_linear_14_10" x1="12.8379" y1="-0.693875" x2="9.54344" y2="31.4337" gradientUnits="userSpaceOnUse">
+<stop stop-color="#01F1FF"/>
+<stop offset="1" stop-color="#0197FF"/>
+</linearGradient>
+<clipPath id="clip0_14_10">
+<rect width="34" height="34" fill="white"/>
+</clipPath>
+</defs>
+</svg>

apps/smp-server/static/media/moon.svg

@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" fill="none" xmlns="http://www.w3.org/2000/svg">
+<path d="M2.92814 12.6789C6.17655 15.9347 11.7044 15.6463 14.5425 12.0117C14.6636 11.8566 14.6825 11.6448 14.5907 11.4708C14.4989 11.2967 14.3136 11.1926 14.1172 11.2049C11.5269 11.3673 8.97627 10.4315 7.0743 8.52765C5.17264 6.62414 4.23958 4.06868 4.40169 1.47281C4.41397 1.2762 4.30965 1.09069 4.13526 0.999048C3.96088 0.907402 3.74893 0.926696 3.59396 1.04833C3.36099 1.23117 3.13828 1.42685 2.92823 1.63726C-0.111372 4.68223 -0.111585 9.63533 2.92814 12.6789Z" stroke="black" stroke-miterlimit="10" stroke-linejoin="round"/>
+</svg>

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');
+    }
+})

apps/smp-server/static/media/style.css

@@ -0,0 +1,410 @@
+@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 */
+}
+
+/* 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;
+}

apps/smp-server/static/media/sun.svg

@@ -0,0 +1,11 @@
+<svg width="24" height="24" viewBox="0 0 24 24" fill="none" xmlns="http://www.w3.org/2000/svg">
+<path d="M23.9958 12.2815C23.9363 12.3954 23.8849 12.5146 23.8158 12.6224C23.5945 12.9674 23.2766 13.1624 22.8654 13.1685C22.2182 13.1782 21.5707 13.1764 20.9234 13.17C20.2781 13.1636 19.7772 12.6464 19.7773 11.9999C19.7774 11.3535 20.2754 10.8389 20.9237 10.8303C21.532 10.8221 22.1405 10.8258 22.7488 10.8278C23.3522 10.8298 23.7281 11.0908 23.9462 11.6508C23.956 11.6761 23.9789 11.6964 23.9958 11.719C23.9958 11.9064 23.9958 12.094 23.9958 12.2815Z" fill="white"/>
+<path d="M11.7154 24.0003C11.6217 23.9526 11.5256 23.9088 11.4345 23.8564C11.0545 23.6377 10.836 23.3104 10.8286 22.87C10.8175 22.2149 10.8179 21.5593 10.828 20.9042C10.8378 20.2738 11.3597 19.7812 11.9967 19.7812C12.6336 19.7812 13.155 20.2739 13.1654 20.9042C13.1757 21.5359 13.1717 22.168 13.1682 22.7998C13.1652 23.3392 12.8885 23.7369 12.3906 23.937C12.3509 23.9529 12.3153 23.979 12.2779 24.0003C12.0904 24.0003 11.9029 24.0003 11.7154 24.0003Z" fill="white"/>
+<path d="M17.2592 11.9958C17.2733 14.8825 14.9232 17.2468 12.0032 17.2612C9.11732 17.2754 6.75397 14.9264 6.73836 12.0041C6.72295 9.12027 9.07502 6.75326 11.9946 6.73835C14.8788 6.72363 17.2449 9.07587 17.2592 11.9958Z" stroke="white" stroke-width="1.5"/>
+<path d="M13.1693 2.11324C13.1692 2.43329 13.1744 2.75345 13.1682 3.07341C13.1555 3.7216 12.6425 4.21934 11.995 4.21864C11.3493 4.21789 10.8358 3.71808 10.828 3.06768C10.8204 2.42766 10.8201 1.78736 10.8283 1.14738C10.8365 0.500704 11.3562 -0.000843934 12.0007 1.06615e-06C12.6437 0.000846066 13.1564 0.504314 13.1684 1.15307C13.1743 1.47303 13.1694 1.79318 13.1693 2.11324Z" fill="white"/>
+<path d="M2.10878 13.1714C1.78877 13.1714 1.46872 13.1754 1.14885 13.1705C0.504832 13.1605 -0.000422735 12.6426 2.65407e-07 11.9987C0.000423265 11.3553 0.503376 10.838 1.15138 10.8301C1.79126 10.8223 2.43138 10.8222 3.07126 10.8303C3.72034 10.8385 4.21822 11.3541 4.21794 12.0012C4.21766 12.6477 3.71555 13.1609 3.06872 13.1706C2.7488 13.1753 2.42875 13.1714 2.10878 13.1714Z" fill="white"/>
+<path d="M6.85268 5.524C6.82732 6.152 6.60944 6.52005 6.16969 6.72981C5.73844 6.93552 5.29738 6.90378 4.94534 6.58208C4.41604 6.09838 3.90431 5.59148 3.42451 5.05894C3.02923 4.62023 3.09727 3.9209 3.51626 3.50792C3.9361 3.09409 4.63284 3.03567 5.06893 3.43194C5.59381 3.90888 6.09569 4.41446 6.57188 4.93996C6.73726 5.12252 6.79642 5.4014 6.85268 5.524Z" fill="white"/>
+<path d="M17.1426 18.4446C17.1749 17.8424 17.389 17.4819 17.8198 17.2738C18.2418 17.07 18.6812 17.0888 19.0265 17.3998C19.5706 17.8899 20.0919 18.4099 20.5814 18.9544C20.9675 19.384 20.895 20.0764 20.485 20.4873C20.0824 20.8907 19.3961 20.9756 18.9718 20.5988C18.4129 20.1026 17.89 19.5625 17.3864 19.0096C17.2323 18.8405 17.1926 18.5671 17.1426 18.4446Z" fill="white"/>
+<path d="M18.2026 6.84235C17.8449 6.82333 17.4821 6.61377 17.2723 6.18256C17.0626 5.7515 17.0878 5.30837 17.4061 4.95629C17.8919 4.41887 18.4055 3.90234 18.945 3.41897C19.3826 3.02693 20.0905 3.1037 20.4947 3.52429C20.9057 3.95198 20.9561 4.64003 20.5568 5.07805C20.0843 5.59645 19.576 6.08306 19.071 6.5708C18.8688 6.76619 18.6057 6.84832 18.2026 6.84235Z" fill="white"/>
+<path d="M5.54205 17.1445C6.14812 17.1747 6.51058 17.385 6.72137 17.8153C6.9323 18.2459 6.90765 18.6892 6.58942 19.0415C6.1037 19.5791 5.58933 20.0948 5.05088 20.5795C4.62165 20.9659 3.93035 20.8989 3.51681 20.4933C3.09875 20.0833 3.02864 19.3789 3.4227 18.942C3.908 18.404 4.42706 17.8934 4.96382 17.4066C5.13982 17.247 5.41663 17.1985 5.54205 17.1445Z" fill="white"/>
+</svg>

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 @<x-label>...</x-label>@ 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 = "<x-" <> label <> ">"
+    endMarker = "</x-" <> 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 <> "}"

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/")

cabal.project

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

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

package.yaml

@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.6.1.0
+version: 5.8.0.10
 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.*
@@ -31,7 +33,7 @@ dependencies:
   - async == 2.2.*
   - attoparsec == 0.14.*
   - base >= 4.14 && < 5
-  - base64 == 1.0.*
+  - base64-bytestring >= 1.0 && < 1.3
   - case-insensitive == 1.2.*
   - composition == 1.0.*
   - constraints >= 0.12 && < 0.14
@@ -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
@@ -169,13 +171,41 @@ tests:
       - silently == 1.2.*
       - main-tester == 0.2.*
       - timeit == 2.0.*
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-A64M
+      - -with-rtsopts=-N1
 
 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
+
+default-extensions:
+  - StrictData

rfcs/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 = <padded(transmission), 16384>
+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

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
   }

rfcs/2024-03-28-xftp-version.md

@@ -0,0 +1,120 @@
+# XFTP version agreement
+
+## Problem
+
+XFTP is using HTTP2 protocol for encoding requests and responses.
+Unlike SMP which has a connection handshake initiated by a server and signals available versions XFTP/HTTP2 is almost entirely client-driven.
+So, a client can only try to guess which protocol versions are supported by a server by sending a probe/hello request first.
+Determining the endpoint for such a request is an implicit version agreement by itself.
+Sending such a request to an old server would error out and requiring it from old clients would break them.
+
+## Solution
+
+The TLS layer used by the XFTP server has an optional [ALPN](https://datatracker.ietf.org/doc/html/rfc7301) extension which allows the client and server to negotiate protocols and store the decision in TLS session context.
+Unless a client and a server run ALPN-aware versions, they would default to the old "unversioned" protocol.
+
+TLS extension content is a 65kb chunk, but ALPN standard breaks it into 254b-sized chunks making it unusable for things like key exchange.
+The exchange is still client-driven: the client proposes a list, and then a server callback picks one.
+In effect, this makes it usable only to signal that some application-level handshake is desired and supported.
+
+## Implementation
+
+ALPN can be used to negotiate for any TLS-based protocol, but the description will focus on XFTP.
+
+TransportClientConfig gets a new `alpn :: Maybe [ALPN]` field so a TLS transport can use it during TLS client creation.
+XFTP client sets it to `Just ["xftp/1"]`.
+The exact value is not important as long it is in agreement with the server side, but ALPN RFC insists on it being an IANA-registered identifier.
+
+XFTP server sets `onALPNClientSuggest` TLS hook to pick the protocol when it is provided.
+The `tls` library treats SHOULD from the RFC as MUST and does a client-side check that the server responded with one of the client-proposed protocols.
+
+Upon connection, transport implementation invokes `getNegotiatedProtocol` and stores it in `tlsALPN :: Maybe ALPN` field of transport context.
+HTTP2 transport implementation using `withHTTP2` passes negotiated "protocol" to client and server setup callbacks where they store it in their respective wrappers along with TLS session ID.
+A server request handler then knows by looking at the `sessionALPN` if it should require a "handshake" request first.
+A client code that got HTTP2Client with `sessionALPN` set knows if it has to proceed with handshake request.
+A handshake request still has to be initiated by a client, so it should be kept minimal, just enough data to pass the initiative to a server.
+A reply to that initial request should contain a server version range for the client to pick.
+A client then commits to a version, sending its part of a handshake.
+
+In the future ALPN negotiation can be dropped in favor of mandatory handshakes or used to signal further handshake schemes.
+
+The XFTP handshake data types and validation code are cloned from SMP.
+Currently they carry version information and session authentication parameters.
+Authentication parameters made mandatory as this exchange is guarded by the handshake version.
+
+### Server side
+
+`runHTTP2Server` callback used by `xftpServer` should get access to the session state to track handshakes.
+A local `TMap SessionId Handshake` is enough to switch request handlers.
+The HTTP2 server framework is extended with a way to signal client disconnection to remove sessions from this map.
+
+The `Handshake` type mimics implicit state in stream based handshakes of SMP and NTF.
+
+```haskell
+data Handshake
+  = HandshakeSent C.PrivateKeyX25519 -- server private key that will be merged with client public in `THandleAuth`
+  | HandshakeAccepted THandleAuth VersionXFTP -- session steady state after handshakes
+```
+
+An HTTP2 request without ALPN is treated as legacy and requires no session entry.
+Its `Request`s are marked with `THandleParams {thVersion = VersionXFTP 1, ..}`.
+
+An HTTP2 request with ALPN requires a session lookup.
+- A lack of entry indicates that a client must send an empty request, to which the server replies with its "server handshake" block and stores its private state in `HandshakeSent`.
+- If the session entry contains `HandshakeSent`, then the only valid request content is the "client handshake" block.
+  The server validates client handshake (in the same way as SMP) and stores authentication and version in `HandshakeAccepted`
+- If the session entry contains `HandshakeAccepted`, then the server just passes it to `THandleParams`.
+
+### Client side
+
+`getXFTPClient` tweaks its transport config to include the ALPN marker and then checks if the client got its `sessionALPN` value.
+If there's a value set, it then sends an initial block and checks out the server handshake in response.
+After validation, it sends "client handshake" request to finish version negotiation.
+
+```haskell
+let tcConfig = (transportClientConfig xftpNetworkConfig) {alpn = Just ["xftp/1"]}
+-- ...
+http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client -- ...
+thVersion <- case sessionALPN http2Client of
+  Nothing -> pure $ VersionXFTP 1
+  Just proto -> negotiate http2Client proto
+```
+
+The resulting `XFTPClient` then contains a negotiated version and can be used to send transmissions with a more recent encoding.
+
+## Block encoding
+
+### Client Hello (request)
+
+A request with an empty body and no padding.
+
+### Server handshake (response)
+
+SMP-encoded and padded to `xftpBlockSize` (~16kb).
+
+```haskell
+data XFTPServerHandshake = XFTPServerHandshake
+  { xftpVersionRange :: VersionRangeXFTP,
+    sessionId :: SessionId, -- validated by client against TLS unique
+    authPubKey ::
+      ( X.CertificateChain, -- fingerprint validated by client against pre-shared hash
+        X.SignedExact X.PubKey -- signature validated by client against server key from TLS
+      )
+  }
+```
+
+### Client handshake (request)
+
+SMP-encoded and padded to `xftpBlockSize` (~16kb).
+
+```haskell
+data XFTPClientHandshake = XFTPClientHandshake
+  { xftpVersion :: VersionXFTP,
+    keyHash :: C.KeyHash, -- validated by server against its own cert fingerprint
+    authPubKey :: C.PublicKeyX25519
+  }
+```
+
+### Server confirmation (response)
+
+A response with an empty body and no padding.

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).

simplexmq.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           simplexmq
-version:        5.6.1.0
+version:        5.8.0.10
 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,6 @@ library
       Simplex.Messaging.Agent.Protocol
       Simplex.Messaging.Agent.QueryString
       Simplex.Messaging.Agent.RetryInterval
-      Simplex.Messaging.Agent.Server
       Simplex.Messaging.Agent.Store
       Simplex.Messaging.Agent.Store.SQLite
       Simplex.Messaging.Agent.Store.SQLite.Common
@@ -105,6 +131,7 @@ 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.TRcvQueues
       Simplex.Messaging.Client
       Simplex.Messaging.Client.Agent
@@ -119,8 +146,6 @@ library
       Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI
       Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG
       Simplex.Messaging.Encoding
-      Simplex.Messaging.Encoding.Base64
-      Simplex.Messaging.Encoding.Base64.URL
       Simplex.Messaging.Encoding.String
       Simplex.Messaging.Notifications.Client
       Simplex.Messaging.Notifications.Protocol
@@ -141,14 +166,17 @@ 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
       Simplex.Messaging.ServiceScheme
+      Simplex.Messaging.Session
       Simplex.Messaging.TMap
       Simplex.Messaging.Transport
       Simplex.Messaging.Transport.Buffer
@@ -173,7 +201,9 @@ library
       Paths_simplexmq
   hs-source-dirs:
       src
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns
+  default-extensions:
+      StrictData
+  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:
@@ -189,7 +219,7 @@ library
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -252,7 +282,9 @@ executable ntf-server
       Paths_simplexmq
   hs-source-dirs:
       apps/ntf-server
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded -rtsopts
+  default-extensions:
+      StrictData
+  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
@@ -261,80 +293,7 @@ executable ntf-server
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64 ==1.0.*
-    , 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
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -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 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -395,10 +354,15 @@ executable smp-agent
 executable smp-server
   main-is: Main.hs
   other-modules:
+      Static
+      Static.Embedded
       Paths_simplexmq
   hs-source-dirs:
       apps/smp-server
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded -rtsopts
+      apps/smp-server/web
+  default-extensions:
+      StrictData
+  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
@@ -407,7 +371,7 @@ executable smp-server
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -420,6 +384,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.*
@@ -448,6 +413,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.*
@@ -471,7 +439,9 @@ executable xftp
       Paths_simplexmq
   hs-source-dirs:
       apps/xftp
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded -rtsopts
+  default-extensions:
+      StrictData
+  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
@@ -480,7 +450,7 @@ executable xftp
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -544,7 +514,9 @@ executable xftp-server
       Paths_simplexmq
   hs-source-dirs:
       apps/xftp-server
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded -rtsopts
+  default-extensions:
+      StrictData
+  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
@@ -553,7 +525,7 @@ executable xftp-server
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -629,7 +601,6 @@ test-suite simplexmq-test
       CoreTests.CryptoFileTests
       CoreTests.CryptoTests
       CoreTests.EncodingTests
-      CoreTests.ProtocolErrorTests
       CoreTests.RetryIntervalTests
       CoreTests.TRcvQueuesTests
       CoreTests.UtilTests
@@ -641,6 +612,7 @@ test-suite simplexmq-test
       ServerTests
       SMPAgentClient
       SMPClient
+      SMPProxyTests
       Util
       XFTPAgent
       XFTPCLI
@@ -649,7 +621,9 @@ test-suite simplexmq-test
       Paths_simplexmq
   hs-source-dirs:
       tests
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns
+  default-extensions:
+      StrictData
+  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.*
@@ -660,7 +634,7 @@ test-suite simplexmq-test
     , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
     , case-insensitive ==1.2.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14

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
@@ -56,6 +57,7 @@ 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
@@ -69,13 +71,15 @@ 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
 import UnliftIO.Directory
+import qualified UnliftIO.Exception as E
 
-startXFTPWorkers :: AgentMonad m => AgentClient -> Maybe FilePath -> m ()
+startXFTPWorkers :: AgentClient -> Maybe FilePath -> AM ()
 startXFTPWorkers c workDir = do
   wd <- asks $ xftpWorkDir . xftpAgent
   atomically $ writeTVar wd workDir
@@ -84,23 +88,26 @@ startXFTPWorkers c workDir = do
   startSndFiles cfg
   startDelFiles cfg
   where
+    startRcvFiles :: AgentConfig -> AM ()
     startRcvFiles AgentConfig {rcvFilesTTL} = do
       pendingRcvServers <- withStore' c (`getPendingRcvFilesServers` rcvFilesTTL)
-      forM_ pendingRcvServers $ \s -> resumeXFTPRcvWork c (Just s)
+      lift . forM_ pendingRcvServers $ \s -> resumeXFTPRcvWork c (Just s)
       -- start local worker for files pending decryption,
       -- no need to make an extra query for the check
       -- as the worker will check the store anyway
-      resumeXFTPRcvWork c Nothing
+      lift $ resumeXFTPRcvWork c Nothing
+    startSndFiles :: AgentConfig -> AM ()
     startSndFiles AgentConfig {sndFilesTTL} = do
       -- start worker for files pending encryption/creation
-      resumeXFTPSndWork c Nothing
+      lift $ resumeXFTPSndWork c Nothing
       pendingSndServers <- withStore' c (`getPendingSndFilesServers` sndFilesTTL)
-      forM_ pendingSndServers $ \s -> resumeXFTPSndWork c (Just s)
+      lift . forM_ pendingSndServers $ \s -> resumeXFTPSndWork c (Just s)
+    startDelFiles :: AgentConfig -> AM ()
     startDelFiles AgentConfig {rcvFilesTTL} = do
       pendingDelServers <- withStore' c (`getPendingDelFilesServers` rcvFilesTTL)
-      forM_ pendingDelServers $ resumeXFTPDelWork c
+      lift . forM_ pendingDelServers $ resumeXFTPDelWork c
 
-closeXFTPAgent :: MonadUnliftIO m => XFTPAgent -> m ()
+closeXFTPAgent :: XFTPAgent -> IO ()
 closeXFTPAgent a = do
   stopWorkers $ xftpRcvWorkers a
   stopWorkers $ xftpSndWorkers a
@@ -108,88 +115,90 @@ closeXFTPAgent a = do
   where
     stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
 
-xftpReceiveFile' :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> m RcvFileId
-xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, 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 <- getPrefixPath "rcv.xftp"
+  prefixPath <- lift $ getPrefixPath "rcv.xftp"
   createDirectory prefixPath
   let relPrefixPath = takeFileName prefixPath
       relTmpPath = relPrefixPath </> "xftp.encrypted"
       relSavePath = relPrefixPath </> "xftp.decrypted"
-  createDirectory =<< toFSFilePath relTmpPath
-  createEmptyFile =<< toFSFilePath relSavePath
+  lift $ createDirectory =<< toFSFilePath relTmpPath
+  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"
           relSavePathRedirect = relPrefixPath </> "xftp.redirect-decrypted"
-      createDirectory =<< toFSFilePath relTmpPathRedirect
-      createEmptyFile =<< toFSFilePath relSavePathRedirect
+      lift $ createDirectory =<< toFSFilePath relTmpPathRedirect
+      lift $ createEmptyFile =<< toFSFilePath relSavePathRedirect
       cfArgsRedirect <- atomically $ CF.randomArgs g
       let saveFileRedirect = CryptoFile relSavePathRedirect $ Just cfArgsRedirect
       -- create download tasks
-      withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile
+      withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile approvedRelays
   forM_ chunks (downloadChunk c)
   pure fId
 
-downloadChunk :: AgentMonad m => AgentClient -> FileChunk -> m ()
+downloadChunk :: AgentClient -> FileChunk -> AM ()
 downloadChunk c FileChunk {replicas = (FileChunkReplica {server} : _)} = do
-  void $ getXFTPRcvWorker True c (Just server)
-downloadChunk _ _ = throwError $ INTERNAL "no replicas"
+  lift . void $ getXFTPRcvWorker True c (Just server)
+downloadChunk _ _ = throwE $ INTERNAL "no replicas"
 
-getPrefixPath :: AgentMonad m => String -> m FilePath
+getPrefixPath :: String -> AM' FilePath
 getPrefixPath suffix = do
   workPath <- getXFTPWorkPath
   ts <- liftIO getCurrentTime
   let isoTime = formatTime defaultTimeLocale "%Y%m%d_%H%M%S_%6q" ts
   uniqueCombine workPath (isoTime <> "_" <> suffix)
 
-toFSFilePath :: AgentMonad m => FilePath -> m FilePath
+toFSFilePath :: FilePath -> AM' FilePath
 toFSFilePath f = (</> f) <$> getXFTPWorkPath
 
-createEmptyFile :: AgentMonad m => FilePath -> m ()
+createEmptyFile :: FilePath -> AM' ()
 createEmptyFile fPath = liftIO $ B.writeFile fPath ""
 
-resumeXFTPRcvWork :: AgentMonad' m => AgentClient -> Maybe XFTPServer -> m ()
+resumeXFTPRcvWork :: AgentClient -> Maybe XFTPServer -> AM' ()
 resumeXFTPRcvWork = void .: getXFTPRcvWorker False
 
-getXFTPRcvWorker :: AgentMonad' m => Bool -> AgentClient -> Maybe XFTPServer -> m Worker
+getXFTPRcvWorker :: Bool -> AgentClient -> Maybe XFTPServer -> AM' Worker
 getXFTPRcvWorker hasWork c server = do
   ws <- asks $ xftpRcvWorkers . xftpAgent
   getAgentWorker "xftp_rcv" hasWork c server ws $
     maybe (runXFTPRcvLocalWorker c) (runXFTPRcvWorker c) server
 
-runXFTPRcvWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> Worker -> m ()
+runXFTPRcvWorker :: AgentClient -> XFTPServer -> Worker -> AM ()
 runXFTPRcvWorker c srv Worker {doWork} = do
   cfg <- asks config
   forever $ do
-    waitForWork doWork
+    lift $ waitForWork doWork
     atomically $ assertAgentForeground c
     runXFTPOperation cfg
   where
-    runXFTPOperation :: AgentConfig -> m ()
-    runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} =
+    runXFTPOperation :: AgentConfig -> AM ()
+    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 ->
-            downloadFileChunk fc replica
+          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
+            liftIO $ waitForUserNetwork c
+            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
-                closeXFTPServerClient c userId server digest
+                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 -> m ()
-    downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica = do
-      fsFileTmpPath <- toFSFilePath fileTmpPath
+            retryDone = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath)
+    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)
           relChunkPath = fileTmpPath </> takeFileName chunkPath
@@ -206,9 +215,13 @@ runXFTPRcvWorker c srv Worker {doWork} = do
         liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived
         pure (entityId, complete, RFPROG rcvd total)
       notify c entityId progress
-      when complete . void $
+      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}
@@ -222,82 +235,83 @@ withRetryIntervalLimit maxN ri action =
   withRetryIntervalCount ri $ \n delay loop ->
     when (n < maxN) $ action delay loop
 
-retryOnError :: AgentMonad m => Text -> m a -> m a -> AgentErrorType -> m a
+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 :: AgentMonad m => AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> String -> m ()
-rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do
-  forM_ tmpPath (removePath <=< toFSFilePath)
-  withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr
-  notify c rcvFileEntityId $ RFERR $ INTERNAL internalErrStr
+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 (show err)
+  notify c rcvFileEntityId $ RFERR err
 
-runXFTPRcvLocalWorker :: forall m. AgentMonad m => AgentClient -> Worker -> m ()
+runXFTPRcvLocalWorker :: AgentClient -> Worker -> AM ()
 runXFTPRcvLocalWorker c Worker {doWork} = do
   cfg <- asks config
   forever $ do
-    waitForWork doWork
+    lift $ waitForWork doWork
     atomically $ assertAgentForeground c
     runXFTPOperation cfg
   where
-    runXFTPOperation :: AgentConfig -> m ()
+    runXFTPOperation :: AgentConfig -> AM ()
     runXFTPOperation AgentConfig {rcvFilesTTL} =
       withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $
         \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
-          decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
-    decryptFile :: RcvFile -> m ()
+          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
-      fsSavePath <- toFSFilePath savePath
-      when (status == RFSDecrypting) $
+      fsSavePath <- lift $ toFSFilePath savePath
+      lift . when (status == RFSDecrypting) $
         whenM (doesFileExist fsSavePath) (removeFile fsSavePath >> createEmptyFile fsSavePath)
       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
-          forM_ tmpPath (removePath <=< toFSFilePath)
+          lift $ forM_ tmpPath (removePath <=< toFSFilePath)
           atomically $ waitUntilForeground c
           withStore' c (`updateRcvFileComplete` rcvFileId)
         Just RcvFileRedirect {redirectFileInfo, redirectDbId} -> do
           let RedirectFileInfo {size = redirectSize, digest = redirectDigest} = redirectFileInfo
-          forM_ tmpPath (removePath <=< toFSFilePath)
+          lift $ forM_ tmpPath (removePath <=< toFSFilePath)
           atomically $ waitUntilForeground c
           withStore' c (`updateRcvFileComplete` rcvFileId)
           -- proceed with redirect
-          yaml <- liftError (INTERNAL . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `finally` (toFSFilePath fsSavePath >>= removePath)
+          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
           forM_ nextChunks (downloadChunk c)
       where
-        getChunkPaths :: [RcvFileChunk] -> m [FilePath]
+        getChunkPaths :: [RcvFileChunk] -> AM [FilePath]
         getChunkPaths [] = pure []
         getChunkPaths (RcvFileChunk {chunkTmpPath = Just path} : cs) = do
           ps <- getChunkPaths cs
-          fsPath <- toFSFilePath path
+          fsPath <- lift $ toFSFilePath path
           pure $ fsPath : ps
         getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) =
-          throwError $ INTERNAL "no chunk path"
+          throwE $ INTERNAL "no chunk path"
 
-xftpDeleteRcvFile' :: AgentMonad m => AgentClient -> RcvFileId -> m ()
+xftpDeleteRcvFile' :: AgentClient -> RcvFileId -> AM' ()
 xftpDeleteRcvFile' c rcvFileEntityId = xftpDeleteRcvFiles' c [rcvFileEntityId]
 
-xftpDeleteRcvFiles' :: forall m. AgentMonad m => AgentClient -> [RcvFileId] -> m ()
+xftpDeleteRcvFiles' :: AgentClient -> [RcvFileId] -> AM' ()
 xftpDeleteRcvFiles' c rcvFileEntityIds = do
   rcvFiles <- rights <$> withStoreBatch c (\db -> map (fmap (first storeError) . getRcvFileByEntityId db) rcvFileEntityIds)
   redirects <- rights <$> batchFiles getRcvFileRedirects rcvFiles
@@ -309,71 +323,71 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do
     (removePath . (workPath </>)) prefixPath `catchAll_` pure ()
   where
     fileComplete RcvFile {status} = status == RFSComplete || status == RFSError
-    batchFiles :: (DB.Connection -> DBRcvFileId -> IO a) -> [RcvFile] -> m [Either AgentErrorType a]
+    batchFiles :: (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. (MonadUnliftIO 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' :: AgentMonad m => AgentClient -> UserId -> CryptoFile -> Int -> m SndFileId
+xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId
 xftpSendFile' c userId file numRecipients = do
   g <- asks random
-  prefixPath <- getPrefixPath "snd.xftp"
+  prefixPath <- lift $ getPrefixPath "snd.xftp"
   createDirectory prefixPath
   let relPrefixPath = takeFileName prefixPath
   key <- atomically $ C.randomSbKey g
   nonce <- atomically $ C.randomCbNonce g
   -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window
   fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing
-  void $ getXFTPSndWorker True c Nothing
+  lift . void $ getXFTPSndWorker True c Nothing
   pure fId
 
-xftpSendDescription' :: forall m. AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> m SndFileId
+xftpSendDescription' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> AM SndFileId
 xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {size, digest}) numRecipients = do
   g <- asks random
-  prefixPath <- getPrefixPath "snd.xftp"
+  prefixPath <- lift $ getPrefixPath "snd.xftp"
   createDirectory prefixPath
   let relPrefixPath = takeFileName prefixPath
   let directYaml = prefixPath </> "direct.yaml"
   cfArgs <- atomically $ CF.randomArgs g
   let file = CryptoFile directYaml (Just cfArgs)
-  liftError (INTERNAL . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect)
+  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}
-  void $ getXFTPSndWorker True c Nothing
+  lift . void $ getXFTPSndWorker True c Nothing
   pure fId
 
-resumeXFTPSndWork :: AgentMonad' m => AgentClient -> Maybe XFTPServer -> m ()
+resumeXFTPSndWork :: AgentClient -> Maybe XFTPServer -> AM' ()
 resumeXFTPSndWork = void .: getXFTPSndWorker False
 
-getXFTPSndWorker :: AgentMonad' m => Bool -> AgentClient -> Maybe XFTPServer -> m Worker
+getXFTPSndWorker :: Bool -> AgentClient -> Maybe XFTPServer -> AM' Worker
 getXFTPSndWorker hasWork c server = do
   ws <- asks $ xftpSndWorkers . xftpAgent
   getAgentWorker "xftp_snd" hasWork c server ws $
     maybe (runXFTPSndPrepareWorker c) (runXFTPSndWorker c) server
 
-runXFTPSndPrepareWorker :: forall m. AgentMonad m => AgentClient -> Worker -> m ()
+runXFTPSndPrepareWorker :: AgentClient -> Worker -> AM ()
 runXFTPSndPrepareWorker c Worker {doWork} = do
   cfg <- asks config
   forever $ do
-    waitForWork doWork
+    lift $ waitForWork doWork
     atomically $ assertAgentForeground c
     runXFTPOperation cfg
   where
-    runXFTPOperation :: AgentConfig -> m ()
+    runXFTPOperation :: AgentConfig -> AM ()
     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 :: AgentConfig -> SndFile -> m ()
+          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
-            fsEncPath <- toFSFilePath $ sndFileEncPath ppath
+            fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath
             when (status == SFSEncrypting) . whenM (doesFileExist fsEncPath) $
               removeFile fsEncPath
             withStore' c $ \db -> updateSndFileStatus db sndFileId SFSEncrypting
@@ -383,93 +397,109 @@ 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 (not . chunkCreated) 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
-        encryptFileForUpload :: SndFile -> FilePath -> m (FileDigest, [(XFTPChunkSpec, FileDigest)])
+        encryptFileForUpload :: SndFile -> FilePath -> AM (FileDigest, [(XFTPChunkSpec, FileDigest)])
         encryptFileForUpload SndFile {key, nonce, srcFile, redirect} fsEncPath = 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)
-        chunkCreated :: SndFileChunk -> Bool
-        chunkCreated SndFileChunk {replicas} =
-          any (\SndFileChunkReplica {replicaStatus} -> replicaStatus == SFRSCreated) replicas
-        createChunk :: Int -> SndFileChunk -> m ()
+        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
-          void $ getXFTPSndWorker True c (Just srv)
+          pure srv
           where
             tryCreate = do
               usedSrvs <- newTVarIO ([] :: [XFTPServer])
-              withRetryInterval (riFast ri) $ \_ loop ->
+              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 :: AgentMonad m => AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> String -> m ()
-sndWorkerInternalError c sndFileId sndFileEntityId prefixPath internalErrStr = do
-  forM_ prefixPath $ removePath <=< toFSFilePath
-  withStore' c $ \db -> updateSndFileError db sndFileId internalErrStr
-  notify c sndFileEntityId $ SFERR $ INTERNAL internalErrStr
+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 (show err)
+  notify c sndFileEntityId $ SFERR err
 
-runXFTPSndWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> Worker -> m ()
+runXFTPSndWorker :: AgentClient -> XFTPServer -> Worker -> AM ()
 runXFTPSndWorker c srv Worker {doWork} = do
   cfg <- asks config
   forever $ do
-    waitForWork doWork
+    lift $ waitForWork doWork
     atomically $ assertAgentForeground c
     runXFTPOperation cfg
   where
-    runXFTPOperation :: AgentConfig -> m ()
-    runXFTPOperation cfg@AgentConfig {sndFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} = do
+    runXFTPOperation :: AgentConfig -> AM ()
+    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 ->
+          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
+            liftIO $ waitForUserNetwork c
             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
-                closeXFTPServerClient c userId server digest
+                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)
-    uploadFileChunk :: AgentConfig -> SndFileChunk -> SndFileChunkReplica -> m ()
+            retryDone = sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath)
+    uploadFileChunk :: AgentConfig -> SndFileChunk -> SndFileChunkReplica -> AM ()
     uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath}, digest = chunkDigest} replica = do
       replica'@SndFileChunkReplica {sndChunkReplicaId} <- addRecipients sndFileChunk replica
-      fsFilePath <- toFSFilePath filePath
-      unlessM (doesFileExist fsFilePath) $ throwError $ INTERNAL "encrypted file doesn't exist on upload"
+      fsFilePath <- lift $ toFSFilePath filePath
+      unlessM (doesFileExist fsFilePath) $ throwE $ FILE NO_FILE
       let chunkSpec' = chunkSpec {filePath = fsFilePath} :: XFTPChunkSpec
       atomically $ assertAgentForeground c
       agentXFTPUploadChunk c userId chunkDigest replica' chunkSpec'
@@ -484,35 +514,35 @@ runXFTPSndWorker c srv Worker {doWork} = do
       when complete $ do
         (sndDescr, rcvDescrs) <- sndFileToDescrs sf
         notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs
-        forM_ prefixPath $ removePath <=< toFSFilePath
+        lift . forM_ prefixPath $ removePath <=< toFSFilePath
         withStore' c $ \db -> updateSndFileComplete db sndFileId
       where
-        addRecipients :: SndFileChunk -> SndFileChunkReplica -> m SndFileChunkReplica
+        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
               rcvIdsKeys' <- agentXFTPAddRecipients c userId chunkDigest cr numRecipients'
               cr' <- withStore' c $ \db -> addSndChunkReplicaRecipients db cr $ L.toList rcvIdsKeys'
               addRecipients ch cr'
-        sndFileToDescrs :: SndFile -> m (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient])
-        sndFileToDescrs SndFile {digest = Nothing} = throwError $ INTERNAL "snd file has no digest"
-        sndFileToDescrs SndFile {chunks = []} = throwError $ INTERNAL "snd file has no chunks"
+        sndFileToDescrs :: SndFile -> AM (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient])
+        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 -> m FileChunk
-        toSndDescrChunk SndFileChunk {replicas = []} = throwError $ INTERNAL "snd file chunk has no replicas"
+        toSndDescrChunk :: SndFileChunk -> AM FileChunk
+        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}]
@@ -562,10 +592,10 @@ runXFTPSndWorker c srv Worker {doWork} = do
         chunkUploaded SndFileChunk {replicas} =
           any (\SndFileChunkReplica {replicaStatus} -> replicaStatus == SFRSUploaded) replicas
 
-deleteSndFileInternal :: AgentMonad m => AgentClient -> SndFileId -> m ()
+deleteSndFileInternal :: AgentClient -> SndFileId -> AM' ()
 deleteSndFileInternal c sndFileEntityId = deleteSndFilesInternal c [sndFileEntityId]
 
-deleteSndFilesInternal :: forall m. AgentMonad m => AgentClient -> [SndFileId] -> m ()
+deleteSndFilesInternal :: AgentClient -> [SndFileId] -> AM' ()
 deleteSndFilesInternal c sndFileEntityIds = do
   sndFiles <- rights <$> withStoreBatch c (\db -> map (fmap (first storeError) . getSndFileByEntityId db) sndFileEntityIds)
   let (toDelete, toMarkDeleted) = partition fileComplete sndFiles
@@ -576,15 +606,15 @@ deleteSndFilesInternal c sndFileEntityIds = do
   batchFiles_ updateSndFileDeleted toMarkDeleted
   where
     fileComplete SndFile {status} = status == SFSComplete || status == SFSError
-    batchFiles_ :: (DB.Connection -> DBSndFileId -> IO a) -> [SndFile] -> m ()
+    batchFiles_ :: (DB.Connection -> DBSndFileId -> IO a) -> [SndFile] -> AM' ()
     batchFiles_ f sndFiles = void $ withStoreBatch' c $ \db -> map (\SndFile {sndFileId} -> f db sndFileId) sndFiles
 
-deleteSndFileRemote :: forall m. AgentMonad m => AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> m ()
+deleteSndFileRemote :: AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> AM' ()
 deleteSndFileRemote c userId sndFileEntityId sfd = deleteSndFilesRemote c userId [(sndFileEntityId, sfd)]
 
-deleteSndFilesRemote :: forall m. AgentMonad m => AgentClient -> UserId -> [(SndFileId, ValidFileDescription 'FSender)] -> m ()
+deleteSndFilesRemote :: AgentClient -> UserId -> [(SndFileId, ValidFileDescription 'FSender)] -> AM' ()
 deleteSndFilesRemote c userId sndFileIdsDescrs = do
-  deleteSndFilesInternal c (map fst sndFileIdsDescrs) `catchAgentError` (notify c "" . SFERR)
+  deleteSndFilesInternal c (map fst sndFileIdsDescrs) `E.catchAny` (notify c "" . SFERR . INTERNAL . show)
   let rs = concatMap (mapMaybe chunkReplica . fdChunks . snd) sndFileIdsDescrs
   void $ withStoreBatch' c (\db -> map (uncurry $ createDeletedSndChunkReplica db userId) rs)
   let servers = S.fromList $ map (\(FileChunkReplica {server}, _) -> server) rs
@@ -596,37 +626,38 @@ deleteSndFilesRemote c userId sndFileIdsDescrs = do
       FileChunk {digest, replicas = replica : _} -> Just (replica, digest)
       _ -> Nothing
 
-resumeXFTPDelWork :: AgentMonad' m => AgentClient -> XFTPServer -> m ()
+resumeXFTPDelWork :: AgentClient -> XFTPServer -> AM' ()
 resumeXFTPDelWork = void .: getXFTPDelWorker False
 
-getXFTPDelWorker :: AgentMonad' m => Bool -> AgentClient -> XFTPServer -> m Worker
+getXFTPDelWorker :: Bool -> AgentClient -> XFTPServer -> AM' Worker
 getXFTPDelWorker hasWork c server = do
   ws <- asks $ xftpDelWorkers . xftpAgent
   getAgentWorker "xftp_del" hasWork c server ws $ runXFTPDelWorker c server
 
-runXFTPDelWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> Worker -> m ()
+runXFTPDelWorker :: AgentClient -> XFTPServer -> Worker -> AM ()
 runXFTPDelWorker c srv Worker {doWork} = do
   cfg <- asks config
   forever $ do
-    waitForWork doWork
+    lift $ waitForWork doWork
     atomically $ assertAgentForeground c
     runXFTPOperation cfg
   where
-    runXFTPOperation :: AgentConfig -> m ()
-    runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} = do
+    runXFTPOperation :: AgentConfig -> AM ()
+    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 ->
+          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
+            liftIO $ waitForUserNetwork c
             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
-                closeXFTPServerClient c userId server chunkDigest
+                when (serverHostError e) $ notify c "" $ SFWARN e
+                liftIO $ closeXFTPServerClient c userId server chunkDigest
                 withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay
               atomically $ assertAgentForeground c
               loop
@@ -635,7 +666,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
               agentXFTPDeleteChunk c userId replica
               withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
 
-delWorkerInternalError :: AgentMonad m => AgentClient -> Int64 -> AgentErrorType -> m ()
+delWorkerInternalError :: AgentClient -> Int64 -> AgentErrorType -> AM ()
 delWorkerInternalError c deletedSndChunkReplicaId e = do
   withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
   notify c "" $ SFERR e

src/Simplex/FileTransfer/Client.hs

@@ -4,13 +4,17 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
 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)
@@ -20,10 +24,12 @@ 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
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Client as H
-import Simplex.FileTransfer.Description (mb)
 import Simplex.FileTransfer.Protocol
+import Simplex.FileTransfer.Server.Env (supportedXFTPhandshakes)
 import Simplex.FileTransfer.Transport
 import Simplex.Messaging.Client
   ( NetworkConfig (..),
@@ -33,10 +39,11 @@ 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)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
   ( BasicAuth,
@@ -45,25 +52,27 @@ import Simplex.Messaging.Protocol
     RecipientId,
     SenderId,
   )
-import Simplex.Messaging.Transport (THandleParams (..), supportedParameters)
-import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost)
+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, liftEitherError, whenM)
+import Simplex.Messaging.Util (liftEitherWith, liftError', tshow, whenM)
+import Simplex.Messaging.Version
 import UnliftIO
 import UnliftIO.Directory
 
 data XFTPClient = XFTPClient
   { http2Client :: HTTP2Client,
     transportSession :: TransportSession FileResponse,
-    thParams :: THandleParams XFTPVersion,
+    thParams :: THandleParams XFTPVersion 'TClient,
     config :: XFTPClientConfig
   }
 
 data XFTPClientConfig = XFTPClientConfig
   { xftpNetworkConfig :: NetworkConfig,
-    uploadTimeoutPerMb :: Int64
+    serverVRange :: VersionRangeXFTP,
+    clientALPN :: Maybe [ALPN]
   }
 
 data XFTPChunkBody = XFTPChunkBody
@@ -85,26 +94,69 @@ defaultXFTPClientConfig :: XFTPClientConfig
 defaultXFTPClientConfig =
   XFTPClientConfig
     { xftpNetworkConfig = defaultNetworkConfig,
-      uploadTimeoutPerMb = 10000000 -- 10 seconds
+      serverVRange = supportedFileServerVRange,
+      clientALPN = Just supportedXFTPhandshakes
     }
 
 getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
-getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkConfig} disconnected = runExceptT $ do
-  let tcConfig = transportClientConfig xftpNetworkConfig
-      http2Config = xftpHTTP2Config tcConfig config
-      username = proxyUsername transportSession
+getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do
+  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 <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
-  let HTTP2Client {sessionId} = http2Client
-      thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True}
-      c = XFTPClient {http2Client, thParams, transportSession, config}
+  http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
+  let HTTP2Client {sessionId, sessionALPN} = http2Client
+      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
+    _ -> pure thParams0
+  logDebug $ "Client negotiated protocol: " <> tshow thVersion
+  let c = XFTPClient {http2Client, thParams, transportSession, config}
   atomically $ writeTVar clientVar $ Just c
   pure c
 
+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
+  (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, thServerVRange = vr}
+  where
+    getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake
+    getServerHandshake = do
+      let helloReq = H.requestNoBody "POST" "/" []
+      HTTP2Response {respBody = HTTP2Body {bodyHead = shsBody}} <-
+        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) $ 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 ()
+              _ -> throwError "bad certificate"
+            pubKey <- maybe (throwError "bad server key type") (`C.verifyX509` exact) serverKey
+            C.x509ToPublic (pubKey, []) >>= C.pubKey
+    sendClientHandshake :: XFTPClientHandshake -> ExceptT XFTPClientError IO ()
+    sendClientHandshake chs = do
+      chs' <- liftTransportErr TELargeMsg $ C.pad (smpEncode chs) xftpBlockSize
+      let chsReq = H.requestBuilder "POST" "/" [] $ byteString chs'
+      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
 
@@ -136,24 +188,26 @@ 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)
 sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = do
   let req = H.requestStreaming N.methodPost "/" [] streamBody
-      reqTimeout = (\XFTPChunkSpec {chunkSize} -> chunkTimeout config chunkSize) <$> chunkSpec_
-  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2Client req reqTimeout
-  when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
+      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) $ 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
@@ -161,7 +215,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 ::
@@ -174,13 +228,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 =
@@ -196,17 +250,27 @@ 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
-        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 =
-            withExceptT PCEResponseError $
+            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_ =
+  maybe tcpTimeout (chunkTimeout cfg) chunkSize_
 
 chunkTimeout :: XFTPClientConfig -> Word32 -> Int
-chunkTimeout config chunkSize = fromIntegral $ (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1
+chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz =
+  tcpTimeout + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
 
 deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
 deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse
@@ -222,17 +286,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

src/Simplex/FileTransfer/Client/Agent.hs

@@ -10,6 +10,8 @@ module Simplex.FileTransfer.Client.Agent where
 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)
@@ -17,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)
@@ -86,7 +87,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
     waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
     waitForXFTPClient clientVar = do
       let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
-      client_ <- tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
+      client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
       liftEither $ case client_ of
         Just (Right c) -> Right c
         Just (Left e) -> Left e
@@ -108,9 +109,9 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
                 else atomically $ do
                   putTMVar clientVar r
                   TM.delete srv xftpClients
-              throwError e
+              throwE e
         tryConnectAsync :: ME ()
-        tryConnectAsync = void . async $ do
+        tryConnectAsync = void . lift . async . runExceptT $ do
           withRetryInterval (reconnectInterval config) $ \_ loop -> void $ tryConnectClient loop
 
 showServer :: XFTPServer -> Text

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)
@@ -37,6 +38,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char (toLower)
+import Data.Either (partitionEithers)
 import Data.Int (Int64)
 import Data.List (foldl', sortOn)
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
@@ -291,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
@@ -321,7 +323,9 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
       -- the reason we don't do pooled downloads here within one server is that http2 library doesn't handle cleint concurrency, even though
       -- upload doesn't allow other requests within the same client until complete (but download does allow).
       logInfo $ "uploading " <> tshow (length chunks) <> " chunks..."
-      map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 chunks' (mapM $ uploadFileChunk a)
+      (errs, rs) <- partitionEithers . concat <$> liftIO (pooledForConcurrentlyN 16 chunks' . mapM $ runExceptT . uploadFileChunk a)
+      mapM_ throwE errs
+      pure $ map snd (sortOn fst rs)
       where
         uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk)
         uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do
@@ -329,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
@@ -341,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
@@ -433,11 +437,13 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
             FileChunkReplica {server} : _ -> server
           srvChunks = groupAllOn srv chunks
       g <- liftIO C.newRandom
-      chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk g a encPath size downloadedChunks)
+      (errs, rs) <- partitionEithers . concat <$> liftIO (pooledForConcurrentlyN 16 srvChunks $ mapM $ runExceptT . downloadFileChunk g a encPath size downloadedChunks)
+      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
@@ -459,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) <> "%"
@@ -498,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
@@ -528,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' =
@@ -558,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
@@ -569,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

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
@@ -29,7 +30,7 @@ import UnliftIO.Directory (removeFile)
 encryptFile :: CryptoFile -> ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT FTCryptoError IO ()
 encryptFile srcFile fileHdr key nonce fileSize' encSize encFile = do
   sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
-  CF.withFile srcFile ReadMode $ \r -> withFile encFile WriteMode $ \w -> do
+  CF.withFile srcFile ReadMode $ \r -> ExceptT . withFile encFile WriteMode $ \w -> runExceptT $ do
     let lenStr = smpEncode fileSize'
         (hdr, !sb') = LC.sbEncryptChunk sb $ lenStr <> fileHdr
         padLen = encSize - authTagSize - fileSize' - 8
@@ -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

src/Simplex/FileTransfer/Protocol.hs

@@ -25,7 +25,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (isNothing)
 import Data.Type.Equality
 import Data.Word (Word32)
-import Simplex.FileTransfer.Transport (VersionXFTP, XFTPErrorType (..), XFTPVersion, pattern VersionXFTP, xftpClientHandshake)
+import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, xftpClientHandshakeStub)
 import Simplex.Messaging.Client (authTransmission)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -39,8 +39,8 @@ import Simplex.Messaging.Protocol
     ProtocolErrorType (..),
     ProtocolMsgTag (..),
     ProtocolType (..),
-    RcvPublicDhKey,
     RcvPublicAuthKey,
+    RcvPublicDhKey,
     RecipientId,
     SenderId,
     SentRawTransmission,
@@ -48,19 +48,17 @@ import Simplex.Messaging.Protocol
     SndPublicAuthKey,
     Transmission,
     TransmissionForAuth (..),
-    encodeTransmissionForAuth,
+    CorrId (..),
     encodeTransmission,
+    encodeTransmissionForAuth,
     messageTagP,
     tDecodeParseValidate,
     tEncodeBatch1,
     tParse,
   )
-import Simplex.Messaging.Transport (THandleParams (..), TransportError (..))
+import Simplex.Messaging.Transport (THandleParams (..), TransportError (..), TransportPeer (..))
 import Simplex.Messaging.Util ((<$?>))
 
-currentXFTPVersion :: VersionXFTP
-currentXFTPVersion = VersionXFTP 1
-
 xftpBlockSize :: Int
 xftpBlockSize = 16384
 
@@ -144,7 +142,7 @@ instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where
 instance Protocol XFTPVersion XFTPErrorType FileResponse where
   type ProtoCommand FileResponse = FileCmd
   type ProtoType FileResponse = 'PXFTP
-  protocolClientHandshake = xftpClientHandshake
+  protocolClientHandshake = xftpClientHandshakeStub
   protocolPing = FileCmd SFRecipient PING
   protocolError = \case
     FRErr e -> Just e
@@ -328,12 +326,12 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
   Just Refl -> Just c
   _ -> Nothing
 
-xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
-xftpEncodeAuthTransmission thParams pKey (corrId, fId, msg) = do
+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 Nothing (Just pKey) corrId tForAuth
+  xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth (Just pKey) (C.cbNonce $ bs corrId) tForAuth
 
-xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> Transmission c -> Either TransportError ByteString
+xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString
 xftpEncodeTransmission thParams (corrId, fId, msg) = do
   let t = encodeTransmission thParams (corrId, fId, msg)
   xftpEncodeBatch1 (Nothing, t)
@@ -342,7 +340,7 @@ xftpEncodeTransmission thParams (corrId, fId, msg) = do
 xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString
 xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 t) xftpBlockSize
 
-xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
+xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
 xftpDecodeTransmission thParams t = do
   t' <- first (const BLOCK) $ C.unPad t
   case tParse thParams t' of

src/Simplex/FileTransfer/Server.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -10,6 +10,7 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.FileTransfer.Server where
 
@@ -17,8 +18,10 @@ 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 Data.ByteString.Builder (byteString)
+import qualified Data.ByteString.Base64.URL as B64
+import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
@@ -32,6 +35,7 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
+import qualified Data.X509 as X
 import GHC.IO.Handle (hSetNewlineMode)
 import GHC.Stats (getRTSStats)
 import qualified Network.HTTP.Types as N
@@ -46,22 +50,28 @@ import Simplex.FileTransfer.Server.StoreLog
 import Simplex.FileTransfer.Transport
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
+import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (CorrId, RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth)
+import Simplex.Messaging.Protocol (CorrId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Stats
-import Simplex.Messaging.Transport (THandleParams (..))
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Transport (SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..))
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
 import Simplex.Messaging.Transport.HTTP2.Server
-import Simplex.Messaging.Transport.Server (runTCPServer)
+import Simplex.Messaging.Transport.Server (runTCPServer, tlsServerCredentials)
 import Simplex.Messaging.Util
+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)
@@ -70,7 +80,7 @@ import qualified UnliftIO.Exception as E
 type M a = ReaderT XFTPEnv IO a
 
 data XFTPTransportRequest = XFTPTransportRequest
-  { thParams :: THandleParams XFTPVersion,
+  { thParams :: THandleParamsXFTP 'TServer,
     reqBody :: HTTP2Body,
     request :: H.Request,
     sendResponse :: H.Response -> IO ()
@@ -84,20 +94,86 @@ runXFTPServer cfg = do
 runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
 runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
 
+data Handshake
+  = HandshakeSent C.PrivateKeyX25519
+  | HandshakeAccepted (THandleParams XFTPVersion 'TServer)
+
 xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
-xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration} 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
   where
     runServer :: M ()
     runServer = do
       serverParams <- asks tlsServerParams
+      let (chain, pk) = tlsServerCredentials serverParams
+      signKey <- liftIO $ case C.x509ToPrivate (pk, []) >>= C.privKey of
+        Right pk' -> pure pk'
+        Left e -> putStrLn ("servers has no valid key: " <> show e) >> exitFailure
       env <- ask
-      liftIO $
-        runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration $ \sessionId r sendResponse -> do
-          reqBody <- getHTTP2Body r xftpBlockSize
-          let thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True}
-          processRequest XFTPTransportRequest {thParams, request = r, reqBody, sendResponse} `runReaderT` env
+      sessions <- atomically TM.empty
+      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 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
+          Just "xftp/1" ->
+            xftpServerHandshakeV1 chain signKey sessions req0 >>= \case
+              Nothing -> pure () -- handshake response sent
+              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 = 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 thParams) -> pure $ Just thParams
+      either sendError pure r
+      where
+        processHello = do
+          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 = 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) $ throwE HANDSHAKE
+          body <- liftHS $ C.unPad bodyHead
+          XFTPClientHandshake {xftpVersion = v, keyHash} <- liftHS $ smpDecode body
+          kh <- asks serverIdentity
+          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
+            Right bs -> liftIO . sendResponse $ H.responseBuilder N.ok200 [] bs
+            Left _ -> logError $ "Error encoding handshake error: " <> tshow err
+          pure Nothing
+        encodeXftp :: Encoding a => a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
+        encodeXftp a = byteString <$> liftHS (C.pad (smpEncode a) xftpBlockSize)
+        liftHS = liftEitherWith (const HANDSHAKE)
 
     stopServer :: M ()
     stopServer = do
@@ -110,28 +186,10 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
 
     expireFiles :: ExpirationConfig -> M ()
     expireFiles expCfg = do
-      st <- asks store
       let interval = checkInterval expCfg * 1000000
       forever $ do
         liftIO $ threadDelay' interval
-        old <- liftIO $ expireBeforeEpoch expCfg
-        sIds <- M.keysSet <$> readTVarIO (files st)
-        forM_ sIds $ \sId -> do
-          threadDelay 100000
-          atomically (expiredFilePath st sId old)
-            >>= mapM_ (maybeRemove $ delete st sId)
-      where
-        maybeRemove del = maybe del (remove del)
-        remove del filePath =
-          ifM
-            (doesFileExist filePath)
-            ((removeFile filePath >> del) `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
-            del
-        delete st sId = do
-          withFileLog (`logDeleteFile` sId)
-          void $ atomically $ deleteFile st sId
-          FileServerStats {filesExpired} <- asks serverStats
-          atomically $ modifyTVar' filesExpired (+ 1)
+        expireServerFiles (Just 100000) expCfg
 
     serverStatsThread_ :: XFTPServerConfig -> [M ()]
     serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
@@ -201,7 +259,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           role <- newTVarIO CPRNone
           cpLoop h role
           where
-            cpLoop h role  = do
+            cpLoop h role = do
               s <- trimCR <$> B.hGetLine h
               case strDecode s of
                 Right CPQuit -> hClose h
@@ -235,12 +293,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
               CPQuit -> pure ()
               CPSkip -> pure ()
               where
-                withUserRole action = readTVarIO role >>= \case
-                  CPRAdmin -> action
-                  CPRUser -> action
-                  _ -> do
-                    logError "Unauthorized control port command"
-                    hPutStrLn h "AUTH"
+                withUserRole action =
+                  readTVarIO role >>= \case
+                    CPRAdmin -> action
+                    CPRUser -> action
+                    _ -> do
+                      logError "Unauthorized control port command"
+                      hPutStrLn h "AUTH"
 
 data ServerFile = ServerFile
   { filePath :: FilePath,
@@ -253,10 +312,11 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
   | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing
   | otherwise = do
       case xftpDecodeTransmission thParams bodyHead of
-        Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do
+        Right (sig_, signed, (corrId, fId, cmdOrErr)) ->
           case cmdOrErr of
             Right cmd -> do
-              verifyXFTPTransmission sig_ signed fId cmd >>= \case
+              let THandleParams {thAuth} = thParams
+              verifyXFTPTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) sig_ signed fId cmd >>= \case
                 VRVerified req -> uncurry send =<< processXFTPRequest body req
                 VRFailed -> send (FRErr AUTH) Nothing
             Left e -> send (FRErr e) Nothing
@@ -264,9 +324,11 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
             send resp = sendXFTPResponse (corrId, fId, resp)
         Left e -> sendXFTPResponse ("", "", FRErr e) Nothing
   where
-    sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M ()
     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
@@ -278,13 +340,22 @@ 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 TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
-verifyXFTPTransmission tAuth authorized fId cmd =
+verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
+verifyXFTPTransmission auth_ tAuth authorized fId cmd =
   case cmd of
     FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
     FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
@@ -299,7 +370,7 @@ verifyXFTPTransmission tAuth authorized fId cmd =
           Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k
           _ -> maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed
     -- TODO verify with DH authorization
-    req `verifyWith` k = if verifyCmdAuthorization Nothing tAuth authorized k then VRVerified req else VRFailed
+    req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed
 
 processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
 processXFTPRequest HTTP2Body {bodyPart} = \case
@@ -325,12 +396,12 @@ 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
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
-        withFileLog $ \sl -> do
+        lift $ withFileLog $ \sl -> do
           logAddFile sl sId file ts
           logAddRecipients sl sId rcps
         stats <- asks serverStats
@@ -362,7 +433,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       st <- asks store
       r <- runExceptT $ do
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
-        withFileLog $ \sl -> logAddRecipients sl sId rcps
+        lift $ withFileLog $ \sl -> logAddRecipients sl sId rcps
         stats <- asks serverStats
         atomically $ modifyTVar' (fileRecipients stats) (+ length rks)
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
@@ -392,7 +463,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
               \used -> let used' = used + fromIntegral size in if used' <= quota then (True, used') else (False, used)
           receive = do
             path <- asks $ filesPath . config
-            let fPath = path </> B.unpack (U.encode senderId)
+            let fPath = path </> B.unpack (B64.encode senderId)
             receiveChunk (XFTPRcvChunkSpec fPath size digest) >>= \case
               Right () -> do
                 stats <- asks serverStats
@@ -409,22 +480,24 @@ 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
-        Just path -> do
-          g <- asks random
-          (sDhKey, spDhKey) <- atomically $ C.generateKeyPair g
-          let dhSecret = C.dh' rDhKey spDhKey
-          cbNonce <- atomically $ C.randomCbNonce g
-          case LC.cbInit dhSecret cbNonce of
-            Right sbState -> do
-              stats <- asks serverStats
-              atomically $ modifyTVar' (fileDownloads stats) (+ 1)
-              atomically $ updatePeriodStats (filesDownloaded stats) senderId
-              pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
-            _ -> pure (FRErr INTERNAL, Nothing)
+        Just path -> ifM (doesFileExist path) sendFile (pure (FRErr AUTH, Nothing))
+          where
+            sendFile = do
+              g <- asks random
+              (sDhKey, spDhKey) <- atomically $ C.generateKeyPair g
+              let dhSecret = C.dh' rDhKey spDhKey
+              cbNonce <- atomically $ C.randomCbNonce g
+              case LC.cbInit dhSecret cbNonce of
+                Right sbState -> do
+                  stats <- asks serverStats
+                  atomically $ modifyTVar' (fileDownloads stats) (+ 1)
+                  atomically $ updatePeriodStats (filesDownloaded stats) senderId
+                  pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
+                _ -> pure (FRErr INTERNAL, Nothing)
         _ -> pure (FRErr NO_FILE, Nothing)
 
     deleteServerFile :: FileRec -> M FileResponse
@@ -457,7 +530,34 @@ deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do
       atomically $ modifyTVar' (filesCount stats) (subtract 1)
       atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
 
-randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString
+expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
+expireServerFiles itemDelay expCfg = do
+  st <- asks store
+  usedStart <- readTVarIO $ usedStorage st
+  old <- liftIO $ expireBeforeEpoch expCfg
+  files' <- readTVarIO (files st)
+  logInfo $ "Expiration check: " <> tshow (M.size files') <> " files"
+  forM_ (M.keys files') $ \sId -> do
+    mapM_ threadDelay itemDelay
+    atomically (expiredFilePath st sId old)
+      >>= mapM_ (maybeRemove $ delete st sId)
+  usedEnd <- readTVarIO $ usedStorage st
+  logInfo $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
+  where
+    mbs bs = tshow (bs `div` 1048576) <> "mb"
+    maybeRemove del = maybe del (remove del)
+    remove del filePath =
+      ifM
+        (doesFileExist filePath)
+        ((removeFile filePath >> del) `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
+        del
+    delete st sId = do
+      withFileLog (`logDeleteFile` sId)
+      void . atomically $ deleteFile st sId -- will not update usedStorage if sId isn't in store
+      FileServerStats {filesExpired} <- asks serverStats
+      atomically $ modifyTVar' filesExpired (+ 1)
+
+randomId :: Int -> M ByteString
 randomId n = atomically . C.randomBytes n =<< asks random
 
 getFileId :: M XFTPFileId
@@ -465,7 +565,7 @@ getFileId = do
   size <- asks (fileIdSize . config)
   atomically . C.randomBytes size =<< asks random
 
-withFileLog :: (MonadIO m, MonadReader XFTPEnv m) => (StoreLog 'WriteMode -> IO a) -> m ()
+withFileLog :: (StoreLog 'WriteMode -> IO a) -> M ()
 withFileLog action = liftIO . mapM_ action =<< asks storeLog
 
 incFileStat :: (FileServerStats -> TVar Int) -> M ()

src/Simplex/FileTransfer/Server/Control.hs

@@ -5,7 +5,6 @@ module Simplex.FileTransfer.Server.Control where
 
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString (ByteString)
-import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BasicAuth)
 

src/Simplex/FileTransfer/Server/Env.hs

@@ -2,13 +2,14 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StrictData #-}
 
 module Simplex.FileTransfer.Server.Env where
 
-import Control.Logger.Simple (logInfo)
+import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.IO.Unlift
 import Crypto.Random
@@ -24,10 +25,12 @@ 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
-import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
+import Simplex.Messaging.Transport (ALPN)
+import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadFingerprint, loadTLSServerParams)
 import Simplex.Messaging.Util (tshow)
 import System.IO (IOMode (..))
 import UnliftIO.STM
@@ -59,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
@@ -94,8 +100,11 @@ defaultFileExpiration =
       checkInterval = 2 * 3600 -- seconds, 2 hours
     }
 
-newXFTPServerEnv :: (MonadUnliftIO m, MonadRandom m) => XFTPServerConfig -> m XFTPEnv
-newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do
+supportedXFTPhandshakes :: [ALPN]
+supportedXFTPhandshakes = ["xftp/1"]
+
+newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
+newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
   random <- liftIO C.newRandom
   store <- atomically newFileStore
   storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile
@@ -104,7 +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
+  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}

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)
+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 "<hostnames>" 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,14 +176,17 @@ 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",
               serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
               transportConfig =
                 defaultTransportServerConfig
-                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
-                  }
+                  { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
+                    alpn = Just supportedXFTPhandshakes
+                  },
+              responseDelay = 0
             }
 
 data CliCommand

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -22,6 +22,7 @@ import Control.Concurrent.STM
 import Control.Monad.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Composition ((.:), (.:.))
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
@@ -88,7 +89,7 @@ readWriteFileStore f st = do
   pure s
 
 readFileStore :: FilePath -> FileStore -> IO ()
-readFileStore f st = mapM_ addFileLogRecord . B.lines =<< B.readFile f
+readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f
   where
     addFileLogRecord s = case strDecode s of
       Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s

src/Simplex/FileTransfer/Transport.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
@@ -9,9 +10,17 @@
 
 module Simplex.FileTransfer.Transport
   ( supportedFileServerVRange,
-    xftpClientHandshake, -- stub
-    XFTPVersion,
+    authCmdsXFTPVersion,
+    xftpClientHandshakeStub,
+    XFTPClientHandshake (..),
+    -- xftpClientHandshake,
+    XFTPServerHandshake (..),
+    -- xftpServerHandshake,
+    THandleXFTP,
+    THandleParamsXFTP,
     VersionXFTP,
+    VersionRangeXFTP,
+    XFTPVersion,
     pattern VersionXFTP,
     XFTPErrorType (..),
     XFTPRcvChunkSpec (..),
@@ -25,27 +34,32 @@ 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 (first)
+import Data.Bifunctor (bimap, first)
 import qualified Data.ByteArray as BA
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.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 (..), THandle, TransportError (..))
+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)
@@ -68,15 +82,58 @@ type VersionRangeXFTP = VersionRange XFTPVersion
 pattern VersionXFTP :: Word16 -> VersionXFTP
 pattern VersionXFTP v = Version v
 
+type THandleXFTP c p = THandle XFTPVersion c p
+type THandleParamsXFTP p = THandleParams XFTPVersion p
+
 initialXFTPVersion :: VersionXFTP
 initialXFTPVersion = VersionXFTP 1
 
-supportedFileServerVRange :: VersionRangeXFTP
-supportedFileServerVRange = mkVersionRange initialXFTPVersion initialXFTPVersion
+authCmdsXFTPVersion :: VersionXFTP
+authCmdsXFTPVersion = VersionXFTP 2
 
--- XFTP protocol does not support handshake
-xftpClientHandshake :: c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c)
-xftpClientHandshake _c _ks _keyHash _xftpVRange = throwError $ TEHandshake VERSION
+currentXFTPVersion :: VersionXFTP
+currentXFTPVersion = VersionXFTP 2
+
+supportedFileServerVRange :: VersionRangeXFTP
+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 = throwE TEVersion
+
+data XFTPServerHandshake = XFTPServerHandshake
+  { xftpVersionRange :: VersionRangeXFTP,
+    sessionId :: SessionId,
+    -- | pub key to agree shared secrets for command authorization and entity ID encryption.
+    authPubKey :: (X.CertificateChain, X.SignedExact X.PubKey)
+  }
+
+data XFTPClientHandshake = XFTPClientHandshake
+  { -- | agreed XFTP server protocol version
+    xftpVersion :: VersionXFTP,
+    -- | server identity - CA certificate fingerprint
+    keyHash :: C.KeyHash
+  }
+
+instance Encoding XFTPClientHandshake where
+  smpEncode XFTPClientHandshake {xftpVersion, keyHash} =
+    smpEncode (xftpVersion, keyHash)
+  smpP = do
+    (xftpVersion, keyHash) <- smpP
+    Tail _compat <- smpP
+    pure XFTPClientHandshake {xftpVersion, keyHash}
+
+instance Encoding XFTPServerHandshake where
+  smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey} =
+    smpEncode (xftpVersionRange, sessionId, auth)
+    where
+      auth = bimap C.encodeCertChain C.SignedObject authPubKey
+  smpP = do
+    (xftpVersionRange, sessionId) <- smpP
+    cert <- C.certChainP
+    C.SignedObject key <- smpP
+    Tail _compat <- smpP
+    pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey = (cert, key)}
 
 sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
 sendEncFile h send = go
@@ -91,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
@@ -132,13 +194,15 @@ 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
     BLOCK
   | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929)
     SESSION
+  | -- | incorrect handshake command
+    HANDSHAKE
   | -- | SMP command is unknown or has invalid syntax
     CMD {cmdErr :: CommandError}
   | -- | command authorization error - bad signature or non-existing SMP queue
@@ -157,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)
@@ -170,17 +232,16 @@ 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
   smpEncode = \case
     BLOCK -> "BLOCK"
     SESSION -> "SESSION"
+    HANDSHAKE -> "HANDSHAKE"
     CMD err -> "CMD " <> smpEncode err
     AUTH -> "AUTH"
     SIZE -> "SIZE"
@@ -191,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_"
 
@@ -199,6 +259,7 @@ instance Encoding XFTPErrorType where
     A.takeTill (== ' ') >>= \case
       "BLOCK" -> pure BLOCK
       "SESSION" -> pure SESSION
+      "HANDSHAKE" -> pure HANDSHAKE
       "CMD" -> CMD <$> _smpP
       "AUTH" -> pure AUTH
       "SIZE" -> pure SIZE
@@ -209,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"

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)

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

@@ -11,8 +11,8 @@
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 module Simplex.Messaging.Agent.Env.SQLite
-  ( AgentMonad,
-    AgentMonad',
+  ( AM',
+    AM,
     AgentConfig (..),
     InitialAgentServers (..),
     NetworkConfig (..),
@@ -21,6 +21,7 @@ module Simplex.Messaging.Agent.Env.SQLite
     tryAgentError,
     tryAgentError',
     catchAgentError,
+    catchAgentError',
     agentFinally,
     Env (..),
     newSMPAgentEnv,
@@ -34,7 +35,6 @@ module Simplex.Messaging.Agent.Env.SQLite
   )
 where
 
-import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
@@ -54,9 +54,8 @@ 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 (PQSupport, VersionRangeE2E, supportedE2EEncryptVRange)
+import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
 import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
 import Simplex.Messaging.Notifications.Transport (NTFVersion)
 import Simplex.Messaging.Notifications.Types
@@ -65,14 +64,14 @@ import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (SMPVersion, TLS, Transport (..))
 import Simplex.Messaging.Transport.Client (defaultSMPPort)
-import Simplex.Messaging.Util (allFinally, catchAllErrors, tryAllErrors)
+import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors')
 import System.Random (StdGen, newStdGen)
 import UnliftIO (Async, SomeException)
 import UnliftIO.STM
 
-type AgentMonad' m = (MonadUnliftIO m, MonadReader Env m)
+type AM' a = ReaderT Env IO a
 
-type AgentMonad m = (AgentMonad' m, MonadError AgentErrorType m)
+type AM a = ExceptT AgentErrorType (ReaderT Env IO) a
 
 data InitialAgentServers = InitialAgentServers
   { smp :: Map UserId (NonEmpty SMPServerWithAuth),
@@ -82,7 +81,7 @@ data InitialAgentServers = InitialAgentServers
   }
 
 data AgentConfig = AgentConfig
-  { tcpPort :: ServiceName,
+  { tcpPort :: Maybe ServiceName,
     rcvAuthAlg :: C.AuthAlg,
     sndAuthAlg :: C.AuthAlg,
     connIdBytes :: Int,
@@ -92,19 +91,20 @@ data AgentConfig = AgentConfig
     xftpCfg :: XFTPClientConfig,
     reconnectInterval :: RetryInterval,
     messageRetryInterval :: RetryInterval2,
+    userNetworkInterval :: Int,
+    userOfflineDelay :: NominalDiffTime,
     messageTimeout :: NominalDiffTime,
     connDeleteDeliveryTimeout :: NominalDiffTime,
     helloTimeout :: NominalDiffTime,
     quotaExceededTimeout :: NominalDiffTime,
+    persistErrorInterval :: NominalDiffTime,
     initialCleanupDelay :: Int64,
     cleanupInterval :: Int64,
     cleanupStepInterval :: Int,
     maxWorkerRestartsPerMin :: Int,
-    maxSubscriptionTimeouts :: Int,
     storedMsgDataTTL :: NominalDiffTime,
     rcvFilesTTL :: NominalDiffTime,
     sndFilesTTL :: NominalDiffTime,
-    xftpNotifyErrsOnRetry :: Bool,
     xftpConsecutiveRetries :: Int,
     xftpMaxRecipientsPerRequest :: Int,
     deleteErrorCount :: Int,
@@ -116,8 +116,8 @@ data AgentConfig = AgentConfig
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,
     certificateFile :: FilePath,
-    e2eEncryptVRange :: PQSupport -> VersionRangeE2E,
-    smpAgentVRange :: PQSupport -> VersionRangeSMPA,
+    e2eEncryptVRange :: VersionRangeE2E,
+    smpAgentVRange :: VersionRangeSMPA,
     smpClientVRange :: VersionRangeSMPC
   }
 
@@ -126,7 +126,7 @@ defaultReconnectInterval =
   RetryInterval
     { initialInterval = 2_000000,
       increaseAfter = 10_000000,
-      maxInterval = 180_000000
+      maxInterval = 60_000000
     }
 
 defaultMessageRetryInterval :: RetryInterval2
@@ -134,22 +134,22 @@ defaultMessageRetryInterval =
   RetryInterval2
     { riFast =
         RetryInterval
-          { initialInterval = 1_000000,
+          { initialInterval = 2_000000,
             increaseAfter = 10_000000,
             maxInterval = 60_000000
           },
       riSlow =
         RetryInterval
-          { initialInterval = 180_000000, -- 3 minutes
+          { initialInterval = 300_000000, -- 5 minutes
             increaseAfter = 60_000000,
-            maxInterval = 3 * 3600_000000 -- 3 hours
+            maxInterval = 6 * 3600_000000 -- 6 hours
           }
     }
 
 defaultAgentConfig :: AgentConfig
 defaultAgentConfig =
   AgentConfig
-    { tcpPort = "5224",
+    { tcpPort = Just "5224",
       -- while the current client version supports X25519, it can only be enabled once support for SMP v6 is dropped,
       -- and all servers are required to support v7 to be compatible.
       rcvAuthAlg = C.AuthAlg C.SEd25519, -- this will stay as Ed25519
@@ -161,21 +161,20 @@ defaultAgentConfig =
       xftpCfg = defaultXFTPClientConfig,
       reconnectInterval = defaultReconnectInterval,
       messageRetryInterval = defaultMessageRetryInterval,
+      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
       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,
@@ -250,20 +249,24 @@ newXFTPAgent = do
   xftpDelWorkers <- TM.empty
   pure XFTPAgent {xftpWorkDir, xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}
 
-tryAgentError :: AgentMonad m => m a -> m (Either AgentErrorType a)
+tryAgentError :: AM a -> AM (Either AgentErrorType a)
 tryAgentError = tryAllErrors mkInternal
 {-# INLINE tryAgentError #-}
 
 -- unlike runExceptT, this ensures we catch IO exceptions as well
-tryAgentError' :: AgentMonad' m => ExceptT AgentErrorType m a -> m (Either AgentErrorType a)
-tryAgentError' = fmap join . runExceptT . tryAgentError
+tryAgentError' :: AM a -> AM' (Either AgentErrorType a)
+tryAgentError' = tryAllErrors' mkInternal
 {-# INLINE tryAgentError' #-}
 
-catchAgentError :: AgentMonad m => m a -> (AgentErrorType -> m a) -> m a
+catchAgentError :: AM a -> (AgentErrorType -> AM a) -> AM a
 catchAgentError = catchAllErrors mkInternal
 {-# INLINE catchAgentError #-}
 
-agentFinally :: AgentMonad m => m a -> m b -> m a
+catchAgentError' :: AM a -> (AgentErrorType -> AM' a) -> AM' a
+catchAgentError' = catchAllErrors' mkInternal
+{-# INLINE catchAgentError' #-}
+
+agentFinally :: AM a -> AM b -> AM a
 agentFinally = allFinally mkInternal
 {-# INLINE agentFinally #-}
 

src/Simplex/Messaging/Agent/Lock.hs

@@ -1,17 +1,19 @@
-{-# LANGUAGE NamedFieldPuns #-}
-
 module Simplex.Messaging.Agent.Lock
   ( Lock,
     createLock,
     withLock,
+    withLock',
     withGetLock,
     withGetLocks,
   )
 where
 
 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
@@ -22,8 +24,12 @@ createLock :: STM Lock
 createLock = newEmptyTMVar
 {-# INLINE createLock #-}
 
-withLock :: MonadUnliftIO m => Lock -> String -> m a -> m a
-withLock lock name =
+withLock :: MonadUnliftIO m => Lock -> String -> ExceptT e m a -> ExceptT e m a
+withLock lock name = ExceptT . withLock' lock name . runExceptT
+{-# INLINE withLock #-}
+
+withLock' :: MonadUnliftIO m => Lock -> String -> m a -> m a
+withLock' lock name =
   E.bracket_
     (atomically $ putTMVar lock name)
     (void . atomically $ takeTMVar lock)
@@ -35,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.

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
@@ -44,7 +43,7 @@ import UnliftIO
 import UnliftIO.Concurrent (forkIO, threadDelay)
 import qualified UnliftIO.Exception as E
 
-runNtfSupervisor :: forall m. AgentMonad' m => AgentClient -> m ()
+runNtfSupervisor :: AgentClient -> AM' ()
 runNtfSupervisor c = do
   ns <- asks ntfSupervisor
   forever $ do
@@ -54,13 +53,13 @@ runNtfSupervisor c = do
         Left e -> notifyErr connId e
         Right _ -> return ()
   where
-    handleErr :: ConnId -> m () -> m ()
+    handleErr :: ConnId -> AM' () -> AM' ()
     handleErr connId = E.handle $ \(e :: E.SomeException) -> do
       logError $ "runNtfSupervisor error " <> tshow e
       notifyErr connId e
     notifyErr connId e = notifyInternalError c connId $ "runNtfSupervisor error " <> show e
 
-processNtfSub :: forall m. AgentMonad m => AgentClient -> (ConnId, NtfSupervisorCommand) -> m ()
+processNtfSub :: AgentClient -> (ConnId, NtfSupervisorCommand) -> AM ()
 processNtfSub c (connId, cmd) = do
   logInfo $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
   case cmd of
@@ -77,11 +76,11 @@ processNtfSub c (connId, cmd) = do
               Just ClientNtfCreds {notifierId} -> do
                 let newSub = newNtfSubscription connId smpServer (Just notifierId) ntfServer NASKey
                 withStore c $ \db -> createNtfSubscription db newSub $ NtfSubNTFAction NSACreate
-                void $ getNtfNTFWorker True c ntfServer
+                lift . void $ getNtfNTFWorker True c ntfServer
               Nothing -> do
                 let newSub = newNtfSubscription connId smpServer Nothing ntfServer NASNew
                 withStore c $ \db -> createNtfSubscription db newSub $ NtfSubSMPAction NSASmpKey
-                void $ getNtfSMPWorker True c smpServer
+                lift . void $ getNtfSMPWorker True c smpServer
         (Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
           case (clientNtfCreds, ntfQueueId) of
             (Just ClientNtfCreds {notifierId}, Just ntfQueueId')
@@ -90,7 +89,7 @@ processNtfSub c (connId, cmd) = do
             (Nothing, Nothing) -> create
             _ -> rotate
           where
-            create :: m ()
+            create :: AM ()
             create = case action_ of
               -- action was set to NULL after worker internal error
               Nothing -> resetSubscription
@@ -101,75 +100,76 @@ processNtfSub c (connId, cmd) = do
                       then resetSubscription
                       else withTokenServer $ \ntfServer -> do
                         withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NtfSubNTFAction NSACreate)
-                        void $ getNtfNTFWorker True c ntfServer
+                        lift . void $ getNtfNTFWorker True c ntfServer
                 | otherwise -> case action of
-                    NtfSubNTFAction _ -> void $ getNtfNTFWorker True c subNtfServer
-                    NtfSubSMPAction _ -> void $ getNtfSMPWorker True c smpServer
-            rotate :: m ()
+                    NtfSubNTFAction _ -> lift . void $ getNtfNTFWorker True c subNtfServer
+                    NtfSubSMPAction _ -> lift . void $ getNtfSMPWorker True c smpServer
+            rotate :: AM ()
             rotate = do
               withStore' c $ \db -> supervisorUpdateNtfSub db sub (NtfSubNTFAction NSARotate)
-              void $ getNtfNTFWorker True c subNtfServer
-            resetSubscription :: m ()
+              lift . void $ getNtfNTFWorker True c subNtfServer
+            resetSubscription :: AM ()
             resetSubscription =
               withTokenServer $ \ntfServer -> do
                 let sub' = sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
                 withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NtfSubSMPAction NSASmpKey)
-                void $ getNtfSMPWorker True c smpServer
+                lift . void $ getNtfSMPWorker True c smpServer
     NSCDelete -> do
       sub_ <- withStore' c $ \db -> do
         supervisorUpdateNtfAction db connId (NtfSubNTFAction NSADelete)
         getNtfSubscription db connId
       logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
       case sub_ of
-        (Just (NtfSubscription {ntfServer}, _)) -> void $ getNtfNTFWorker True c ntfServer
+        (Just (NtfSubscription {ntfServer}, _)) -> lift . void $ getNtfNTFWorker True c ntfServer
         _ -> pure () -- err "NSCDelete - no subscription"
     NSCSmpDelete -> do
       withStore' c (`getPrimaryRcvQueue` connId) >>= \case
         Right rq@RcvQueue {server = smpServer} -> do
           logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
           withStore' c $ \db -> supervisorUpdateNtfAction db connId (NtfSubSMPAction NSASmpDelete)
-          void $ getNtfSMPWorker True c smpServer
+          lift . void $ getNtfSMPWorker True c smpServer
         _ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
-    NSCNtfWorker ntfServer -> void $ getNtfNTFWorker True c ntfServer
-    NSCNtfSMPWorker smpServer -> void $ getNtfSMPWorker True c smpServer
+    NSCNtfWorker ntfServer -> lift . void $ getNtfNTFWorker True c ntfServer
+    NSCNtfSMPWorker smpServer -> lift . void $ getNtfSMPWorker True c smpServer
 
-getNtfNTFWorker :: AgentMonad' m => Bool -> AgentClient -> NtfServer -> m Worker
+getNtfNTFWorker :: Bool -> AgentClient -> NtfServer -> AM' Worker
 getNtfNTFWorker hasWork c server = do
   ws <- asks $ ntfWorkers . ntfSupervisor
   getAgentWorker "ntf_ntf" hasWork c server ws $ runNtfWorker c server
 
-getNtfSMPWorker :: AgentMonad' m => Bool -> AgentClient -> SMPServer -> m Worker
+getNtfSMPWorker :: Bool -> AgentClient -> SMPServer -> AM' Worker
 getNtfSMPWorker hasWork c server = do
   ws <- asks $ ntfSMPWorkers . ntfSupervisor
   getAgentWorker "ntf_smp" hasWork c server ws $ runNtfSMPWorker c server
 
-withTokenServer :: AgentMonad' m => (NtfServer -> m ()) -> m ()
-withTokenServer action = getNtfToken >>= mapM_ (\NtfToken {ntfServer} -> action ntfServer)
+withTokenServer :: (NtfServer -> AM ()) -> AM ()
+withTokenServer action = lift getNtfToken >>= mapM_ (\NtfToken {ntfServer} -> action ntfServer)
 
-runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> Worker -> m ()
+runNtfWorker :: AgentClient -> NtfServer -> Worker -> AM ()
 runNtfWorker c srv Worker {doWork} = do
   delay <- asks $ ntfWorkerDelay . config
   forever $ do
     waitForWork doWork
-    agentOperationBracket c AONtfNetwork throwWhenInactive runNtfOperation
+    ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfOperation
     threadDelay delay
   where
-    runNtfOperation :: m ()
+    runNtfOperation :: AM ()
     runNtfOperation =
       withWork c doWork (`getNextNtfSubNTFAction` srv) $
         \nextSub@(NtfSubscription {connId}, _, _) -> do
           logInfo $ "runNtfWorker, nextSub " <> tshow nextSub
           ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \_ loop ->
+          withRetryInterval ri $ \_ loop -> do
+            liftIO $ waitForUserNetwork c
             processSub nextSub
               `catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
-    processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> m ()
+    processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> AM ()
     processSub (sub@NtfSubscription {connId, smpServer, ntfSubId}, action, actionTs) = do
       ts <- liftIO getCurrentTime
-      unlessM (rescheduleAction doWork ts actionTs) $
+      unlessM (lift $ rescheduleAction doWork ts actionTs) $
         case action of
           NSACreate ->
-            getNtfToken >>= \case
+            lift getNtfToken >>= \case
               Just tkn@NtfToken {ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
                 RcvQueue {clientNtfCreds} <- withStore c (`getPrimaryRcvQueue` connId)
                 case clientNtfCreds of
@@ -182,13 +182,13 @@ runNtfWorker c srv Worker {doWork} = do
                   _ -> workerInternalError c connId "NSACreate - no notifier queue credentials"
               _ -> workerInternalError c connId "NSACreate - no active token"
           NSACheck ->
-            getNtfToken >>= \case
+            lift getNtfToken >>= \case
               Just tkn ->
                 case ntfSubId of
                   Just nSubId ->
                     agentNtfCheckSubscription c nSubId tkn >>= \case
                       NSAuth -> do
-                        getNtfServer c >>= \case
+                        lift (getNtfServer c) >>= \case
                           Just ntfServer -> do
                             withStore' c $ \db ->
                               updateNtfSubscription db sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew} (NtfSubSMPAction NSASmpKey) ts
@@ -200,7 +200,7 @@ runNtfWorker c srv Worker {doWork} = do
               _ -> workerInternalError c connId "NSACheck - no active token"
           NSADelete -> case ntfSubId of
             Just nSubId ->
-              (getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
+              (lift getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
                 `agentFinally` continueDeletion
             _ -> continueDeletion
             where
@@ -211,7 +211,7 @@ runNtfWorker c srv Worker {doWork} = do
                 atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
           NSARotate -> case ntfSubId of
             Just nSubId ->
-              (getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
+              (lift getNtfToken >>= mapM_ (agentNtfDeleteSubscription c nSubId))
                 `agentFinally` deleteCreate
             _ -> deleteCreate
             where
@@ -228,12 +228,14 @@ runNtfWorker c srv Worker {doWork} = do
           withStore' c $ \db ->
             updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
 
-runNtfSMPWorker :: forall m. AgentMonad m => AgentClient -> SMPServer -> Worker -> m ()
+runNtfSMPWorker :: AgentClient -> SMPServer -> Worker -> AM ()
 runNtfSMPWorker c srv Worker {doWork} = do
+  env <- ask
   delay <- asks $ ntfSMPWorkerDelay . config
   forever $ do
     waitForWork doWork
-    agentOperationBracket c AONtfNetwork throwWhenInactive runNtfSMPOperation
+    ExceptT . liftIO . agentOperationBracket c AONtfNetwork throwWhenInactive $
+      runReaderT (runExceptT runNtfSMPOperation) env
     threadDelay delay
   where
     runNtfSMPOperation =
@@ -241,16 +243,17 @@ runNtfSMPWorker c srv Worker {doWork} = do
         \nextSub@(NtfSubscription {connId}, _, _) -> do
           logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub
           ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \_ loop ->
+          withRetryInterval ri $ \_ loop -> do
+            liftIO $ waitForUserNetwork c
             processSub nextSub
               `catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
-    processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> m ()
+    processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> AM ()
     processSub (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
       ts <- liftIO getCurrentTime
-      unlessM (rescheduleAction doWork ts actionTs) $
+      unlessM (lift $ rescheduleAction doWork ts actionTs) $
         case smpAction of
           NSASmpKey ->
-            getNtfToken >>= \case
+            lift getNtfToken >>= \case
               Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
                 rq <- withStore c (`getPrimaryRcvQueue` connId)
                 C.AuthAlg a <- asks (rcvAuthAlg . config)
@@ -272,7 +275,7 @@ runNtfSMPWorker c srv Worker {doWork} = do
             mapM_ (disableQueueNotifications c) rq_
             withStore' c $ \db -> deleteNtfSubscription db connId
 
-rescheduleAction :: AgentMonad' m => TMVar () -> UTCTime -> UTCTime -> m Bool
+rescheduleAction :: TMVar () -> UTCTime -> UTCTime -> AM' Bool
 rescheduleAction doWork ts actionTs
   | actionTs <= ts = pure False
   | otherwise = do
@@ -282,7 +285,7 @@ rescheduleAction doWork ts actionTs
         atomically $ hasWorkToDo' doWork
       pure True
 
-retryOnError :: AgentMonad' m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
+retryOnError :: AgentClient -> Text -> AM () -> (AgentErrorType -> AM ()) -> AgentErrorType -> AM ()
 retryOnError c name loop done e = do
   logError $ name <> " error: " <> tshow e
   case e of
@@ -296,16 +299,17 @@ retryOnError c name loop done e = do
       atomically $ beginAgentOperation c AONtfNetwork
       loop
 
-workerInternalError :: AgentMonad m => AgentClient -> ConnId -> String -> m ()
+workerInternalError :: AgentClient -> ConnId -> String -> AM ()
 workerInternalError c connId internalErrStr = do
   withStore' c $ \db -> setNullNtfSubscriptionAction db connId
   notifyInternalError c connId internalErrStr
 
 -- TODO change error
-notifyInternalError :: MonadUnliftIO m => AgentClient -> ConnId -> String -> m ()
-notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, APC SAEConn $ ERR $ INTERNAL internalErrStr)
+notifyInternalError :: MonadIO m => AgentClient -> ConnId -> String -> m ()
+notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AEvt SAEConn $ ERR $ INTERNAL internalErrStr)
+{-# INLINE notifyInternalError #-}
 
-getNtfToken :: AgentMonad' m => m (Maybe NtfToken)
+getNtfToken :: AM' (Maybe NtfToken)
 getNtfToken = do
   tkn <- asks $ ntfTkn . ntfSupervisor
   readTVarIO tkn
@@ -326,14 +330,14 @@ instantNotifications = \case
   Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
   _ -> False
 
-closeNtfSupervisor :: MonadUnliftIO m => NtfSupervisor -> m ()
+closeNtfSupervisor :: NtfSupervisor -> IO ()
 closeNtfSupervisor ns = do
   stopWorkers $ ntfWorkers ns
   stopWorkers $ ntfSMPWorkers ns
   where
     stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
 
-getNtfServer :: AgentMonad' m => AgentClient -> m (Maybe NtfServer)
+getNtfServer :: AgentClient -> AM' (Maybe NtfServer)
 getNtfServer c = do
   ntfServers <- readTVarIO $ ntfServers c
   case ntfServers of

src/Simplex/Messaging/Agent/RetryInterval.hs

@@ -11,6 +11,7 @@ module Simplex.Messaging.Agent.RetryInterval
     withRetryIntervalCount,
     withRetryLock2,
     updateRetryInterval2,
+    nextRetryDelay,
   )
 where
 
@@ -60,7 +61,7 @@ withRetryIntervalCount ri action = callAction 0 0 $ initialInterval ri
         loop = do
           liftIO $ threadDelay' delay
           let elapsed' = elapsed + delay
-          callAction (n + 1) elapsed' $ nextDelay elapsed' delay ri
+          callAction (n + 1) elapsed' $ nextRetryDelay elapsed' delay ri
 
 -- This function allows action to toggle between slow and fast retry intervals.
 withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> (RI2State -> (RetryIntervalMode -> m ()) -> m ()) -> m ()
@@ -76,7 +77,7 @@ withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
         run (elapsed, delay) ri call = do
           wait delay
           let elapsed' = elapsed + delay
-              delay' = nextDelay elapsed' delay ri
+              delay' = nextRetryDelay elapsed' delay ri
           call (elapsed', delay')
         wait delay = do
           waiting <- newTVarIO True
@@ -87,8 +88,8 @@ withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
             takeTMVar lock
             writeTVar waiting False
 
-nextDelay :: Int64 -> Int64 -> RetryInterval -> Int64
-nextDelay elapsed delay RetryInterval {increaseAfter, maxInterval} =
+nextRetryDelay :: Int64 -> Int64 -> RetryInterval -> Int64
+nextRetryDelay elapsed delay RetryInterval {increaseAfter, maxInterval} =
   if elapsed < increaseAfter || delay == maxInterval
     then delay
     else min (delay * 3 `div` 2) maxInterval

src/Simplex/Messaging/Agent/Server.hs

@@ -1,83 +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.IO.Unlift (MonadUnliftIO)
-import Control.Monad.Reader
-import Crypto.Random (MonadRandom)
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Text.Encoding (decodeUtf8)
-import Simplex.Messaging.Agent
-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 :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> m ()
-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 :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> Int -> TMVar Bool -> m ()
-runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers store initClientId started = do
-  liftIO (newSMPAgentEnv cfg store) >>= runReaderT (smpAgent t)
-  where
-    smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()
-    smpAgent _ = do
-      -- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
-      tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
-      clientId <- newTVarIO initClientId
-      runTransportServer started tcpPort tlsServerParams defaultTransportServerConfig $ \(h :: c) -> do
-        liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
-        cId <- atomically $ stateTVar clientId $ \i -> (i + 1, i + 1)
-        c <- getAgentClient cId initServers
-        logConnection c True
-        race_ (connectClient h c) (runAgentClient c)
-          `E.finally` disconnectAgentClient c
-
-connectClient :: Transport c => MonadUnliftIO m => c -> AgentClient -> m ()
-connectClient h c = race_ (send h c) (receive h c)
-
-receive :: forall c m. (Transport c, MonadUnliftIO m) => c -> AgentClient -> m ()
-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 -> m ()
-    write q t = do
-      logClient c "-->" t
-      atomically $ writeTBQueue q t
-
-send :: (Transport c, MonadUnliftIO m) => c -> AgentClient -> m ()
-send h c@AgentClient {subQ} = forever $ do
-  t <- atomically $ readTBQueue subQ
-  tPut h t
-  logClient c "<--" t
-
-logClient :: MonadUnliftIO m => AgentClient -> ByteString -> ATransmission a -> m ()
-logClient AgentClient {clientId} dir (corrId, connId, APC _ cmd) = do
-  logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, connId, B.takeWhile (/= ' ') $ serializeCommand cmd]

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,
@@ -47,7 +47,6 @@ import Simplex.Messaging.Protocol
     VersionSMPC,
   )
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Util ((<$?>))
 
 -- * Queue types
 
@@ -344,20 +343,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)
 
@@ -436,7 +435,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 +592,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

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

@@ -221,9 +221,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
@@ -231,6 +233,7 @@ import Data.Bifunctor (first, second)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as U
 import qualified Data.ByteString.Char8 as B
 import Data.Char (toLower)
 import Data.Functor (($>))
@@ -267,10 +270,9 @@ 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 qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
 import Simplex.Messaging.Notifications.Types
@@ -278,7 +280,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 +288,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 +384,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 +423,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} =
@@ -1043,7 +1046,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,
@@ -1214,7 +1217,7 @@ setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem =
     db
     [sql|
       UPDATE ratchets
-      SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ? 
+      SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ?
       WHERE conn_id = ?
     |]
     (x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, pqPrivKem, connId)
@@ -1272,12 +1275,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 _) ->
@@ -2269,20 +2276,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 +2309,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 +2318,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 +2469,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 +2493,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 +2501,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 +2511,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 =

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

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

@@ -71,6 +71,7 @@ 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.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -110,7 +111,8 @@ 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)
   ]
 
 -- | The list of migrations in ascending order by date

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;
+|]

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

@@ -287,6 +287,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(

src/Simplex/Messaging/Client/Agent.hs

@@ -1,18 +1,20 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# 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
@@ -31,29 +33,29 @@ import qualified Data.Map.Strict as M
 import Data.Maybe (listToMaybe)
 import Data.Set (Set)
 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 = TMVar (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))
 
@@ -67,9 +69,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
@@ -82,107 +86,128 @@ defaultSMPClientAgentConfig =
             increaseAfter = 10 * second,
             maxInterval = 10 * second
           },
+      persistErrorInterval = 30, -- seconds
       msgQSize = 256,
       agentQSize = 256,
-      agentSubsBatchSize = 900
+      agentSubsBatchSize = 900,
+      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 (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where
-  withRunInIO :: ((forall a. ExceptT e m a -> IO a) -> IO b) -> ExceptT e m b
-  withRunInIO exceptToIO =
-    withExceptT unInternalException . ExceptT . E.try $
-      withRunInIO $ \run ->
-        exceptToIO $ run . (either (E.throwIO . InternalException) return <=< 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 []
-  pure SMPClientAgent {agentCfg, msgQ, agentQ, randomDrg, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients}
+  smpSubWorkers <- TM.empty
+  workerSeq <- newTVar 0
+  pure
+    SMPClientAgent
+      { agentCfg,
+        active,
+        msgQ,
+        agentQ,
+        randomDrg,
+        smpClients,
+        smpSessions,
+        srvSubs,
+        pendingSrvSubs,
+        smpSubWorkers,
+        workerSeq
+      }
 
+-- | Get or create SMP client for SMPServer
 getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient
-getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ, randomDrg} 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 = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv smpClients
+    getClientVar :: UTCTime -> STM (Either SMPClientVar SMPClientVar)
+    getClientVar = getSessVar workerSeq srv smpClients
 
-    newClientVar :: STM SMPClientVar
-    newClientVar = do
-      smpVar <- newEmptyTMVar
-      TM.insert srv smpVar smpClients
-      pure smpVar
-
-    waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO SMPClient
-    waitForSMPClient smpVar = do
+    waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO (OwnServer, SMPClient)
+    waitForSMPClient v = do
       let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
-      smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar smpVar)
-      liftEither $ case smpClient_ of
-        Just (Right smpClient) -> Right smpClient
-        Just (Left e) -> Left e
-        Nothing -> Left PCEResponseTimeout
+      smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
+      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 smpVar = tryConnectClient pure tryConnectAsync
-      where
-        tryConnectClient :: (SMPClient -> ExceptT SMPClientError IO a) -> ExceptT SMPClientError IO () -> ExceptT SMPClientError IO a
-        tryConnectClient successAction retryAction =
-          tryE connectClient >>= \r -> case r of
-            Right smp -> do
-              logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
-              atomically $ putTMVar smpVar r
-              successAction smp
-            Left e -> do
-              if e == PCENetworkError || e == PCEResponseTimeout
-                then retryAction
-                else atomically $ do
-                  putTMVar smpVar (Left e)
-                  TM.delete srv smpClients
-              throwE e
-        tryConnectAsync :: ExceptT SMPClientError IO ()
-        tryConnectAsync = do
-          a <- async 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 c = (isOwnServer ca srv, 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 :: ExceptT SMPClientError IO SMPClient
-    connectClient = ExceptT $ getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected
+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)
 
+-- | 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 _ = do
-      removeClientAndSubs >>= (`forM_` serverDown)
+    clientDisconnected smp = do
+      removeClientAndSubs smp >>= (`forM_` serverDown)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
-    removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateAuthKey))
-    removeClientAndSubs = atomically $ do
-      TM.delete srv smpClients
+    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
@@ -193,72 +218,109 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ, randomDrg} sr
         addPendingSubs sVar ss = do
           let ps = pendingSrvSubs ca
           TM.lookup srv ps >>= \case
-            Just v -> TM.union ss v
+            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
-      void $ runExceptT reconnectServer
+      notify ca . CADisconnected srv $ M.keysSet ss
+      reconnectClient ca srv
 
-    reconnectServer :: ExceptT SMPClientError IO ()
-    reconnectServer = do
-      a <- async 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
+        forM_ pending $ \cs -> whenM (readTVarIO active) $ do
+          void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv cs)
+          loop
+    ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
+    getPending = mapM 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 -> 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
+  where
+    isNotifier = \case
+      SPNotifier -> True
+      SPRecipient -> False
+    subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateAuthKey)] -> ExceptT SMPClientError IO ()
+    subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg)
       where
-        isNotifier = \case
-          SPNotifier -> True
-          SPRecipient -> False
+        subscribeBatch subs' = do
+          let subs'' :: (NonEmpty (QueueId, C.APrivateAuthKey)) = L.map (first snd) subs'
+          rs <- liftIO $ smpSubscribeQueues party ca smp srv subs''
+          let rs' :: (NonEmpty ((SMPSub, C.APrivateAuthKey), Either SMPClientError ())) =
+                L.zipWith (first . const) subs' rs
+              rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateAuthKey)] =
+                map (\(sub, r) -> bimap (fst sub,) (const sub) r) $ L.toList rs'
+              (errs, oks) = partitionEithers rs''
+              (tempErrs, finalErrs) = partition (temporaryClientError . snd) errs
+          mapM_ (atomically . addSubscription ca srv) oks
+          mapM_ (notify ca . CAResubscribed srv) $ L.nonEmpty $ map fst oks
+          mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs
+          mapM_ (notify ca . CASubError srv) $ L.nonEmpty finalErrs
+          mapM_ (throwE . snd) $ listToMaybe tempErrs
 
-        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
 
-closeSMPClientAgent :: MonadUnliftIO m => SMPClientAgent -> m ()
-closeSMPClientAgent c = liftIO $ do
+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 = readTVarIO (smpClients c) >>= mapM_ (forkIO . closeClient)
+closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient)
   where
-    closeClient smpVar =
-      atomically (readTMVar smpVar) >>= \case
-        Right smp -> closeProtocolClient smp `catchAll_` pure ()
+    closeClient v =
+      atomically (readTMVar $ sessionVar v) >>= \case
+        Right (_, smp) -> closeProtocolClient smp `catchAll_` pure ()
         _ -> pure ()
 
 cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()

src/Simplex/Messaging/Compression.hs

@@ -4,20 +4,9 @@
 module Simplex.Messaging.Compression where
 
 import qualified Codec.Compression.Zstd as Z1
-import qualified Codec.Compression.Zstd.FFI as Z
-import Control.Monad (forM)
-import Control.Monad.Except
-import Control.Monad.IO.Class
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
-import qualified Data.ByteString.Unsafe as B
-import Data.Either (fromRight)
-import Data.List.NonEmpty (NonEmpty)
-import Foreign
-import Foreign.C.Types
-import GHC.IO (unsafePerformIO)
 import Simplex.Messaging.Encoding
-import UnliftIO.Exception (bracket)
 
 data Compressed
   = -- | Short messages are left intact to skip copying and FFI festivities.
@@ -42,49 +31,15 @@ instance Encoding Compressed where
       '1' -> Compressed <$> smpP
       x -> fail $ "unknown Compressed tag: " <> show x
 
--- | Compress as single chunk using stack-allocated context.
 compress1 :: ByteString -> Compressed
 compress1 bs
   | B.length bs <= maxLengthPassthrough = Passthrough bs
   | otherwise = Compressed . Large $ Z1.compress compressionLevel bs
 
-type CompressCtx = (Ptr Z.CCtx, Ptr CChar, CSize)
-
-withCompressCtx :: CSize -> (CompressCtx -> IO a) -> IO a
-withCompressCtx scratchSize action =
-  bracket Z.createCCtx Z.freeCCtx $ \cctx ->
-    allocaBytes (fromIntegral scratchSize) $ \scratchPtr ->
-      action (cctx, scratchPtr, scratchSize)
-
--- | Compress bytes, falling back to Passthrough in case of some internal error.
-compress :: CompressCtx -> ByteString -> IO Compressed
-compress ctx bs = fromRight (Passthrough bs) <$> compress_ ctx bs
-
-compress_ :: CompressCtx -> ByteString -> IO (Either String Compressed)
-compress_ (cctx, scratchPtr, scratchSize) bs
-  | B.length bs <= maxLengthPassthrough = pure . Right $ Passthrough bs
-  | otherwise =
-      B.unsafeUseAsCStringLen bs $ \(sourcePtr, sourceSize) -> runExceptT $ do
-        -- should not fail, unless input buffer is too short
-        dstSize <- ExceptT $ Z.checkError $ Z.compressCCtx cctx scratchPtr scratchSize sourcePtr (fromIntegral sourceSize) compressionLevel
-        liftIO $ Compressed . Large <$> B.packCStringLen (scratchPtr, fromIntegral dstSize)
-
-type DecompressCtx = (Ptr Z.DCtx, Ptr CChar, CSize)
-
-withDecompressCtx :: Int -> (DecompressCtx -> IO a) -> IO a
-withDecompressCtx maxUnpackedSize action =
-  bracket Z.createDCtx Z.freeDCtx $ \dctx ->
-    allocaBytes maxUnpackedSize $ \scratchPtr ->
-      action (dctx, scratchPtr, fromIntegral maxUnpackedSize)
-
-decompress :: DecompressCtx -> Compressed -> IO (Either String ByteString)
-decompress (dctx, scratchPtr, scratchSize) = \case
-  Passthrough bs -> pure $ Right bs
-  Compressed (Large bs) ->
-    B.unsafeUseAsCStringLen bs $ \(sourcePtr, sourceSize) -> do
-      res <- Z.checkError $ Z.decompressDCtx dctx scratchPtr scratchSize sourcePtr (fromIntegral sourceSize)
-      forM res $ \dstSize -> B.packCStringLen (scratchPtr, fromIntegral dstSize)
-
-decompressBatch :: Int -> NonEmpty Compressed -> NonEmpty (Either String ByteString)
-decompressBatch maxUnpackedSize items = unsafePerformIO $ withDecompressCtx maxUnpackedSize $ forM items . decompress
-{-# NOINLINE decompressBatch #-} -- prevent double-evaluation under unsafePerformIO
+decompress1 :: Compressed -> Either String ByteString
+decompress1 = \case
+  Passthrough bs -> Right bs
+  Compressed (Large bs) -> case Z1.decompress bs of
+    Z1.Error e -> Left e
+    Z1.Skip -> Right mempty
+    Z1.Decompress bs' -> Right bs'

src/Simplex/Messaging/Crypto.hs

@@ -141,6 +141,7 @@ module Simplex.Messaging.Crypto
     sbEncrypt_,
     cbNonce,
     randomCbNonce,
+    reverseNonce,
 
     -- * NaCl crypto_secretbox
     SbKey (unSbKey),
@@ -211,6 +212,8 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (bimap, first)
 import Data.ByteArray (ByteArrayAccess)
 import qualified Data.ByteArray as BA
+import Data.ByteString.Base64 (decode, encode)
+import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.ByteString.Lazy (fromStrict, toStrict)
@@ -228,8 +231,6 @@ import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
 import Network.Transport.Internal (decodeWord16, encodeWord16)
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Encoding.Base64 (decode, encode)
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString)
 import Simplex.Messaging.Util ((<$?>))
@@ -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

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
 
@@ -76,7 +76,7 @@ withFile :: CryptoFile -> IOMode -> (CryptoFileHandle -> ExceptT FTCryptoError I
 withFile (CryptoFile path cfArgs) mode action = do
   sb <- forM cfArgs $ \(CFArgs key nonce) ->
     liftEitherWith FTCECryptoError (LC.sbInit key nonce) >>= newTVarIO
-  IO.withFile path mode $ \h -> action $ CFHandle h sb
+  ExceptT . IO.withFile path mode $ \h -> runExceptT $ action $ CFHandle h sb
 
 hPut :: CryptoFileHandle -> LazyByteString -> IO ()
 hPut (CFHandle h sb_) s = LB.hPut h =<< maybe (pure s) encrypt sb_
@@ -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

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
@@ -143,16 +143,11 @@ kdfX3DHE2EEncryptVersion = VersionE2E 2
 pqRatchetE2EEncryptVersion :: VersionE2E
 pqRatchetE2EEncryptVersion = VersionE2E 3
 
--- TODO v5.7 increase to 3
 currentE2EEncryptVersion :: VersionE2E
-currentE2EEncryptVersion = VersionE2E 2
+currentE2EEncryptVersion = VersionE2E 3
 
--- TODO v5.7 remove dependency of version range on whether PQ encryption is used
-supportedE2EEncryptVRange :: PQSupport -> VersionRangeE2E
-supportedE2EEncryptVRange pq =
-  mkVersionRange kdfX3DHE2EEncryptVersion $ case pq of 
-    PQSupportOn -> pqRatchetE2EEncryptVersion
-    PQSupportOff -> currentE2EEncryptVersion
+supportedE2EEncryptVRange :: VersionRangeE2E
+supportedE2EEncryptVRange = mkVersionRange kdfX3DHE2EEncryptVersion currentE2EEncryptVersion
 
 data RatchetKEMState
   = RKSProposed -- only KEM encapsulation key
@@ -171,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
@@ -271,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
 
@@ -382,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
@@ -449,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
@@ -461,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
 
@@ -703,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
@@ -713,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
 
@@ -734,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

src/Simplex/Messaging/Encoding/Base64.hs

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

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

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

src/Simplex/Messaging/Encoding/String.hs

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

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

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -11,12 +11,14 @@
 
 module Simplex.Messaging.Notifications.Protocol where
 
+import Control.Applicative ((<|>))
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Functor (($>))
 import Data.Kind
 import Data.Maybe (isNothing)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@@ -150,7 +152,7 @@ instance Encoding ANewNtfEntity where
 instance Protocol NTFVersion ErrorType NtfResponse where
   type ProtoCommand NtfResponse = NtfCmd
   type ProtoType NtfResponse = 'PNTF
-  protocolClientHandshake = ntfClientHandshake
+  protocolClientHandshake c _ks = ntfClientHandshake c
   protocolPing = NtfCmd SSubscription PING
   protocolError = \case
     NRErr e -> Just e
@@ -406,10 +408,12 @@ instance Encoding DeviceToken where
 
 instance StrEncoding DeviceToken where
   strEncode (DeviceToken p t) = strEncode p <> " " <> t
-  strP = DeviceToken <$> strP <* A.space <*> hexStringP
+  strP = nullToken <|> hexToken
     where
+      nullToken = "apns_null test_ntf_token" $> DeviceToken PPApnsNull "test_ntf_token"
+      hexToken = DeviceToken <$> strP <* A.space <*> hexStringP
       hexStringP =
-        A.takeWhile (\c -> A.isDigit c || (c >= 'a' && c <= 'f')) >>= \s ->
+        A.takeWhile (`B.elem` "0123456789abcdef") >>= \s ->
           if even (B.length s) then pure s else fail "odd number of hex characters"
 
 instance ToJSON DeviceToken where

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
@@ -47,7 +47,7 @@ import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
 import Simplex.Messaging.Server.Stats
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..))
+import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..))
 import Simplex.Messaging.Transport.Server (runTransportServer, tlsServerCredentials)
 import Simplex.Messaging.Util
 import System.Exit (exitFailure)
@@ -81,7 +81,8 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
     runServer (tcpPort, ATransport t) = do
       serverParams <- asks tlsServerParams
       serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams
-      runTransportServer started tcpPort serverParams tCfg (runClient serverSignKey t)
+      env <- ask
+      liftIO $ runTransportServer started tcpPort serverParams tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
     fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
 
     runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
@@ -97,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} =
@@ -107,7 +110,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
     logServerStats :: Int64 -> Int64 -> FilePath -> M ()
     logServerStats startAt logInterval statsFilePath = do
       initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
+      logInfo $ "server stats log enabled: " <> T.pack statsFilePath
       liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
       NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
       let interval = 1000000 * logInterval
@@ -217,33 +220,38 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
 
     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
@@ -338,7 +346,7 @@ updateTknStatus NtfTknData {ntfTknId, tknStatus} status = do
   old <- atomically $ stateTVar tknStatus (,status)
   when (old /= status) $ withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
 
-runNtfClientTransport :: Transport c => THandleNTF c -> M ()
+runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M ()
 runNtfClientTransport th@THandle {params} = do
   qSize <- asks $ clientQSize . config
   ts <- liftIO getSystemTime
@@ -355,7 +363,7 @@ runNtfClientTransport th@THandle {params} = do
 clientDisconnected :: NtfServerClient -> IO ()
 clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
 
-receive :: Transport c => THandleNTF c -> NtfServerClient -> M ()
+receive :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> M ()
 receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
   ts <- liftIO $ tGet th
   forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
@@ -370,7 +378,7 @@ receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ
   where
     write q t = atomically $ writeTBQueue q t
 
-send :: Transport c => THandleNTF c -> NtfServerClient -> IO ()
+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)]
@@ -381,7 +389,7 @@ send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
 
 data VerificationResult = VRVerified NtfRequest | VRFailed
 
-verifyNtfTransmission :: Maybe (THandleAuth, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
+verifyNtfTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
 verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do
   st <- asks store
   case cmd of
@@ -441,7 +449,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
   where
     processCommand :: NtfRequest -> M (Transmission NtfResponse)
     processCommand = \case
-      NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
+      NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> do
         logDebug "TNEW - new token"
         st <- asks store
         ks@(srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random
@@ -452,9 +460,9 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
         atomically $ addNtfToken st tknId tkn
         atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
         withNtfLog (`logCreateToken` tkn)
-        incNtfStat tknCreated
+        incNtfStatT token tknCreated
         pure (corrId, "", NRTknId tknId srvDhPubKey)
-      NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
+      NtfReqCmd SToken (NtfTkn tkn@NtfTknData {token, ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
         status <- readTVarIO tknStatus
         (corrId,tknId,) <$> case cmd of
           TNEW (NewNtfTkn _ _ dhPubKey) -> do
@@ -473,7 +481,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
                 updateTknStatus tkn NTActive
                 tIds <- atomically $ removeInactiveTokenRegistrations st tkn
                 forM_ tIds cancelInvervalNotifications
-                incNtfStat tknVerified
+                incNtfStatT token tknVerified
                 pure NROk
             | otherwise -> do
                 logDebug "TVFY - incorrect code or token status"
@@ -492,8 +500,8 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               addNtfToken st tknId tkn'
               writeTBQueue pushQ (tkn', PNVerification regCode)
             withNtfLog $ \s -> logUpdateToken s tknId token' regCode
-            incNtfStat tknDeleted
-            incNtfStat tknCreated
+            incNtfStatT token tknDeleted
+            incNtfStatT token tknCreated
             pure NROk
           TDEL -> do
             logDebug "TDEL"
@@ -503,7 +511,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
               atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
             cancelInvervalNotifications tknId
             withNtfLog (`logDeleteToken` tknId)
-            incNtfStat tknDeleted
+            incNtfStatT token tknDeleted
             pure NROk
           TCRN 0 -> do
             logDebug "TCRN 0"
@@ -582,6 +590,10 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
 withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M ()
 withNtfLog action = liftIO . mapM_ action =<< asks storeLog
 
+incNtfStatT :: DeviceToken -> (NtfServerStats -> TVar Int) -> M ()
+incNtfStatT (DeviceToken PPApnsNull _) _ = pure ()
+incNtfStatT _ statSel = incNtfStat statSel
+
 incNtfStat :: (NtfServerStats -> TVar Int) -> M ()
 incNtfStat statSel = do
   stats <- asks serverStats

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

@@ -24,17 +24,17 @@ import Numeric.Natural
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
-import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
 import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Notifications.Server.StoreLog
+import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
 import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (ATransport, THandleParams)
-import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
+import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..))
+import Simplex.Messaging.Transport.Server (TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams)
 import System.IO (IOMode (..))
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
@@ -83,8 +83,8 @@ data NtfEnv = NtfEnv
     serverStats :: NtfServerStats
   }
 
-newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
-newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do
+newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
+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}
@@ -161,13 +161,13 @@ data NtfRequest
 data NtfServerClient = NtfServerClient
   { rcvQ :: TBQueue NtfRequest,
     sndQ :: TBQueue (Transmission NtfResponse),
-    ntfThParams :: THandleParams NTFVersion,
+    ntfThParams :: THandleParams NTFVersion 'TServer,
     connected :: TVar Bool,
     rcvActiveAt :: TVar SystemTime,
     sndActiveAt :: TVar SystemTime
   }
 
-newNtfServerClient :: Natural -> THandleParams NTFVersion -> SystemTime -> STM NtfServerClient
+newNtfServerClient :: Natural -> THandleParams NTFVersion 'TServer -> SystemTime -> STM NtfServerClient
 newNtfServerClient qSize ntfThParams ts = do
   rcvQ <- newTBQueue qSize
   sndQ <- newTBQueue qSize

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

@@ -11,29 +11,27 @@ 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 (ProtocolClientConfig (..))
 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)
 import Text.Read (readMaybe)
 
-defaultSMPBatchDelay :: Int
-defaultSMPBatchDelay = 10000
-
 ntfServerCLI :: FilePath -> FilePath -> IO ()
 ntfServerCLI cfgPath logPath =
   getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
@@ -69,7 +67,7 @@ ntfServerCLI cfgPath logPath =
       fp <- createServerX509 cfgPath x509cfg
       let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" 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
@@ -85,17 +83,15 @@ 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")
-            <> "log_tls_errors: off\n\
-               \# delay between command batches sent to SMP relays (microseconds), 0 to disable\n"
-            <> ("smp_batch_delay: " <> show defaultSMPBatchDelay <> "\n")
+            <> ("host: " <> T.pack host <> "\n")
+            <> ("port: " <> T.pack defaultServerPort <> "\n")
+            <> "log_tls_errors: off\n"
             <> "websockets: off\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
@@ -111,8 +107,6 @@ ntfServerCLI cfgPath logPath =
         enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
         c = combine cfgPath . ($ defaultX509Config)
-        smpBatchDelay = readIniDefault defaultSMPBatchDelay "TRANSPORT" "smp_batch_delay" ini
-        batchDelay = if smpBatchDelay <= 0 then Nothing else Just smpBatchDelay
         serverConfig =
           NtfServerConfig
             { transports = iniTransports ini,
@@ -121,7 +115,7 @@ ntfServerCLI cfgPath logPath =
               clientQSize = 64,
               subQSize = 512,
               pushQSize = 1048,
-              smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {batchDelay}},
+              smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
               apnsConfig = defaultAPNSPushClientConfig,
               subsBatchSize = 900,
               inactiveClientExpiration =
@@ -141,7 +135,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
                   }
             }
 

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
@@ -27,9 +28,8 @@ import Data.Aeson (ToJSON, (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.TH as JQ
-import Data.Base64.Types (extractBase64)
 import Data.Bifunctor (first)
-import qualified Data.ByteString.Base64.URL as UP
+import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -47,7 +47,6 @@ import Network.HTTP2.Client (Request)
 import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
@@ -56,7 +55,7 @@ import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.Protocol (EncNMsgMeta)
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
 import Simplex.Messaging.Transport.HTTP2.Client
-import Simplex.Messaging.Util (safeDecodeUtf8)
+import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Environment (getEnv)
 import UnliftIO.STM
 
@@ -93,8 +92,8 @@ signedJWTToken pk (JWTToken hdr claims) = do
   pure $ hc <> "." <> serialize sig
   where
     jwtEncode :: ToJSON a => a -> ByteString
-    jwtEncode = extractBase64 . UP.encodeBase64Unpadded' . LB.toStrict . J.encode
-    serialize sig = extractBase64 . UP.encodeBase64Unpadded' $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
+    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
+    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
 
 readECPrivateKey :: FilePath -> IO EC.PrivateKey
 readECPrivateKey f = do
@@ -260,11 +259,11 @@ mkApnsJWTToken appTeamId jwtHeader privateKey = do
 connectHTTPS2 :: HostName -> APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
 connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg, caStoreFile} https2Client = do
   caStore_ <- XS.readCertificateStore caStoreFile
-  when (isNothing caStore_) $ putStrLn $ "Error loading CertificateStore from " <> caStoreFile
+  when (isNothing caStore_) $ logError $ "Error loading CertificateStore from " <> T.pack caStoreFile
   r <- getHTTP2Client apnsHost apnsPort caStore_ http2cfg disconnected
   case r of
     Right client -> atomically . writeTVar https2Client $ Just client
-    Left e -> putStrLn $ "Error connecting to APNS: " <> show e
+    Left e -> logError $ "Error connecting to APNS: " <> tshow e
   pure r
   where
     disconnected = atomically $ writeTVar https2Client Nothing
@@ -355,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

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

@@ -24,9 +24,12 @@ module Simplex.Messaging.Notifications.Server.StoreLog
 where
 
 import Control.Concurrent.STM
+import Control.Logger.Simple
 import Control.Monad
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Data.Text as T
 import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -34,7 +37,7 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Protocol (NtfPrivateAuthKey)
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Util (whenM)
+import Simplex.Messaging.Util (safeDecodeUtf8, whenM)
 import System.Directory (doesFileExist, renameFile)
 import System.IO
 
@@ -189,10 +192,10 @@ readWriteNtfStore f st = do
   pure s
 
 readNtfStore :: FilePath -> NtfStore -> IO ()
-readNtfStore f st = mapM_ addNtfLogRecord . B.lines =<< B.readFile f
+readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f
   where
     addNtfLogRecord s = case strDecode s of
-      Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s
+      Left e -> logError $ "Log parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s)
       Right lr -> atomically $ case lr of
         CreateToken r@NtfTknRec {ntfTknId} -> do
           tkn <- mkTknData r

src/Simplex/Messaging/Notifications/Transport.hs

@@ -5,11 +5,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 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
@@ -18,9 +20,9 @@ import qualified Data.X509 as X
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Transport
+import Simplex.Messaging.Util (liftEitherWith)
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
-import Simplex.Messaging.Util (liftEitherWith)
 
 ntfBlockSize :: Int
 ntfBlockSize = 512
@@ -43,18 +45,24 @@ authBatchCmdsNTFVersion :: VersionNTF
 authBatchCmdsNTFVersion = VersionNTF 2
 
 currentClientNTFVersion :: VersionNTF
-currentClientNTFVersion = VersionNTF 1
+currentClientNTFVersion = VersionNTF 2
 
 currentServerNTFVersion :: VersionNTF
-currentServerNTFVersion = VersionNTF 1
+currentServerNTFVersion = VersionNTF 2
 
 supportedClientNTFVRange :: VersionRangeNTF
 supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion
 
+legacyServerNTFVRange :: VersionRangeNTF
+legacyServerNTFVRange = mkVersionRange initialNTFVersion initialNTFVersion
+
 supportedServerNTFVRange :: VersionRangeNTF
 supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion
 
-type THandleNTF c = THandle NTFVersion c
+supportedNTFHandshakes :: [ALPN]
+supportedNTFHandshakes = ["ntf/1"]
+
+type THandleNTF c p = THandle NTFVersion c p
 
 data NtfServerHandshake = NtfServerHandshake
   { ntfVersionRange :: VersionRangeNTF,
@@ -67,9 +75,7 @@ data NtfClientHandshake = NtfClientHandshake
   { -- | agreed SMP notifications server protocol version
     ntfVersion :: VersionNTF,
     -- | server identity - CA certificate fingerprint
-    keyHash :: C.KeyHash,
-    -- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
-    authPubKey :: Maybe C.PublicKeyX25519
+    keyHash :: C.KeyHash
   }
 
 instance Encoding NtfServerHandshake where
@@ -94,62 +100,74 @@ authEncryptCmdsP :: VersionNTF -> Parser a -> Parser (Maybe a)
 authEncryptCmdsP v p = if v >= authBatchCmdsNTFVersion then Just <$> p else pure Nothing
 
 instance Encoding NtfClientHandshake where
-  smpEncode NtfClientHandshake {ntfVersion, keyHash, authPubKey} =
-    smpEncode (ntfVersion, keyHash) <> encodeNtfAuthPubKey ntfVersion authPubKey
+  smpEncode NtfClientHandshake {ntfVersion, keyHash} =
+    smpEncode (ntfVersion, keyHash)
   smpP = do
     (ntfVersion, keyHash) <- smpP
-    -- TODO drop SMP v6: remove special parser and make key non-optional
-    authPubKey <- ntfAuthPubKeyP ntfVersion
-    pure NtfClientHandshake {ntfVersion, keyHash, authPubKey}
-
-ntfAuthPubKeyP :: VersionNTF -> Parser (Maybe C.PublicKeyX25519)
-ntfAuthPubKeyP v = if v >= authBatchCmdsNTFVersion then Just <$> smpP else pure Nothing
-
-encodeNtfAuthPubKey :: VersionNTF -> Maybe C.PublicKeyX25519 -> ByteString
-encodeNtfAuthPubKey v k
-  | v >= authBatchCmdsNTFVersion = maybe "" smpEncode k
-  | otherwise = ""
+    pure NtfClientHandshake {ntfVersion, keyHash}
 
 -- | Notifcations server transport handshake.
-ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c)
+ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
 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, authPubKey = k'}
+    NtfClientHandshake {ntfVersion = v, keyHash}
       | keyHash /= kh ->
-          throwError $ TEHandshake IDENTITY
-      | v `isCompatible` ntfVRange ->
-          pure $ ntfThHandle th v pk k'
-      | 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.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c)
-ntfClientHandshake c (k, pk) keyHash ntfVRange = do
+ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TClient)
+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
-        sk_ <- forM sk' $ \exact -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ 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 exact
-          C.x509ToPublic (pubKey, []) >>= C.pubKey
-        sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = Just k}
-        pure $ ntfThHandle th v pk sk_
-      Nothing -> throwError $ TEHandshake VERSION
+          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 vr ck_
+      Nothing -> throwE TEVersion
 
-ntfThHandle :: forall c. THandleNTF c -> VersionNTF -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleNTF c
-ntfThHandle th@THandle {params} v privKey k_ =
+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 vr (Just thAuth)
+
+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 vr 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 thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
-      v3 = v >= authBatchCmdsNTFVersion
-      params' = params {thVersion = v, thAuth, implySessId = v3, batch = v3}
-   in (th :: THandleNTF c) {params = params'}
+  let v3 = v >= authBatchCmdsNTFVersion
+      params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v3, batch = v3}
+   in (th :: THandleNTF c p) {params = params'}
 
-ntfTHandle :: Transport c => c -> THandleNTF c
+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
+        }

src/Simplex/Messaging/Parsers.hs

@@ -10,9 +10,10 @@ import qualified Data.Aeson as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
+import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (toLower)
+import Data.Char (isAlphaNum, toLower)
 import Data.String
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -23,8 +24,23 @@ 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 (safeDecodeUtf8, (<$?>))
 import Text.Read (readMaybe)
 
+base64P :: Parser ByteString
+base64P = decode <$?> paddedBase64 rawBase64P
+
+paddedBase64 :: Parser ByteString -> Parser ByteString
+paddedBase64 raw = (<>) <$> raw <*> pad
+  where
+    pad = A.takeWhile (== '=')
+
+rawBase64P :: Parser ByteString
+rawBase64P = A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
+
+-- rawBase64UriP :: Parser ByteString
+-- rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')
+
 tsISO8601P :: Parser UTCTime
 tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill wordEnd
 
@@ -138,3 +154,6 @@ singleFieldJSON_ objectTag tagModifier =
 
 defaultJSON :: J.Options
 defaultJSON = J.defaultOptions {J.omitNothingFields = True}
+
+textP :: Parser String
+textP = T.unpack . safeDecodeUtf8 <$> A.takeByteString

src/Simplex/Messaging/Protocol.hs

@@ -43,6 +43,7 @@ module Simplex.Messaging.Protocol
   ( -- * SMP protocol parameters
     supportedSMPClientVRange,
     maxMessageLength,
+    paddedProxiedMsgLength,
     e2eEncConfirmationLength,
     e2eEncMessageLength,
 
@@ -56,6 +57,7 @@ module Simplex.Messaging.Protocol
     SubscriptionMode (..),
     Party (..),
     Cmd (..),
+    DirectParty,
     BrokerMsg (..),
     SParty (..),
     PartyI (..),
@@ -63,6 +65,8 @@ module Simplex.Messaging.Protocol
     ProtocolErrorType (..),
     ErrorType (..),
     CommandError (..),
+    ProxyError (..),
+    BrokerErrorType (..),
     Transmission,
     TransmissionAuth (..),
     SignedTransmission,
@@ -121,6 +125,12 @@ module Simplex.Messaging.Protocol
     EncNMsgMeta,
     SMPMsgMeta (..),
     NMsgMeta (..),
+    EncFwdResponse (..),
+    EncFwdTransmission (..),
+    EncResponse (..),
+    EncTransmission (..),
+    FwdResponse (..),
+    FwdTransmission (..),
     MsgFlags (..),
     initialSMPClientVersion,
     userProtocol,
@@ -146,6 +156,7 @@ module Simplex.Messaging.Protocol
     sameSrvAddr,
     sameSrvAddr',
     noAuthSrv,
+    toMsgInfo,
 
     -- * TCP transport functions
     TransportBatch (..),
@@ -167,6 +178,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 (..))
@@ -174,6 +186,7 @@ import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser, (<?>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
+import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isPrint, isSpace)
@@ -184,20 +197,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 qualified Simplex.Messaging.Encoding.Base64 as B64
 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
 
@@ -228,9 +246,16 @@ currentSMPClientVersion = VersionSMPC 2
 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
 
+paddedProxiedMsgLength :: Int
+paddedProxiedMsgLength = 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)
@@ -238,13 +263,13 @@ type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106
 
 -- it is shorter to allow per-queue e2e encryption DH key in the "public" header
 e2eEncConfirmationLength :: Int
-e2eEncConfirmationLength = 15936
+e2eEncConfirmationLength = 15920 -- 15881 .. 15976
 
 e2eEncMessageLength :: Int
-e2eEncMessageLength = 16032
+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 +277,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 +296,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)
 
@@ -352,6 +388,7 @@ data Command (p :: Party) where
   ACK :: MsgId -> Command Recipient
   OFF :: Command Recipient
   DEL :: Command Recipient
+  QUE :: Command Recipient
   -- SMP sender commands
   -- SEND v1 has to be supported for encoding/decoding
   -- SEND :: MsgBody -> Command Sender
@@ -359,6 +396,17 @@ data Command (p :: Party) where
   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 +432,26 @@ instance Encoding SubscriptionMode where
       'C' -> pure SMOnlyCreate
       _ -> fail "bad SubscriptionMode"
 
+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 +461,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 +478,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 +509,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 +663,12 @@ data CommandTag (p :: Party) where
   ACK_ :: CommandTag Recipient
   OFF_ :: CommandTag Recipient
   DEL_ :: CommandTag Recipient
+  QUE_ :: CommandTag Recipient
   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 +682,11 @@ data BrokerMsgTag
   | MSG_
   | NID_
   | NMSG_
+  | PKEY_
+  | RRES_
+  | PRES_
   | END_
+  | INFO_
   | OK_
   | ERR_
   | PONG_
@@ -605,8 +711,12 @@ instance PartyI p => Encoding (CommandTag p) where
     ACK_ -> "ACK"
     OFF_ -> "OFF"
     DEL_ -> "DEL"
+    QUE_ -> "QUE"
     SEND_ -> "SEND"
     PING_ -> "PING"
+    PRXY_ -> "PRXY"
+    PFWD_ -> "PFWD"
+    RFWD_ -> "RFWD"
     NSUB_ -> "NSUB"
   smpP = messageTagP
 
@@ -621,8 +731,12 @@ instance ProtocolMsgTag CmdTag where
     "ACK" -> Just $ CT SRecipient ACK_
     "OFF" -> Just $ CT SRecipient OFF_
     "DEL" -> Just $ CT SRecipient DEL_
+    "QUE" -> Just $ CT SRecipient QUE_
     "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 +753,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 +769,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 +951,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
@@ -1038,14 +1160,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 +1183,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,8 +1206,36 @@ 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 -> Parser RawTransmission
+transmissionP :: THandleParams v p -> Parser RawTransmission
 transmissionP THandleParams {sessionId, implySessId} = do
   authenticator <- smpP
   authorized <- A.takeByteString
@@ -1089,10 +1249,10 @@ transmissionP THandleParams {sessionId, implySessId} = do
       command <- A.takeByteString
       pure RawTransmission {authenticator, authorized = authorized', sessId, corrId, entityId, command}
 
-class (ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err  where
+class (ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
   type ProtoCommand msg = cmd | cmd -> msg
   type ProtoType msg = (sch :: ProtocolType) | sch -> msg
-  protocolClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c)
+  protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c 'TClient)
   protocolPing :: ProtoCommand msg
   protocolError :: msg -> Maybe err
 
@@ -1132,9 +1292,13 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
     ACK msgId -> e (ACK_, ' ', msgId)
     OFF -> e OFF_
     DEL -> e DEL_
+    QUE -> e QUE_
     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 +1308,33 @@ 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
+    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
@@ -1185,10 +1358,16 @@ 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
         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
@@ -1204,7 +1383,11 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
       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_
@@ -1221,7 +1404,11 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP)
     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 +1420,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 +1460,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 +1475,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,11 +1502,77 @@ 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 -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
+tPut :: Transport c => THandle v c p -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
 tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (batch params) (blockSize params)
   where
     tPutBatch :: TransportBatch () -> IO [Either TransportError ()]
@@ -1317,7 +1581,7 @@ tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (ba
       TBTransmissions s n _ -> replicate n <$> tPutLog th s
       TBTransmission s _ -> (: []) <$> tPutLog th s
 
-tPutLog :: Transport c => THandle v c -> ByteString -> IO (Either TransportError ())
+tPutLog :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
 tPutLog th s = do
   r <- tPutBlock th s
   case r of
@@ -1383,7 +1647,7 @@ tEncodeBatch1 t = lenEncode 1 `B.cons` tEncodeForBatch t
 -- tForAuth is lazy to avoid computing it when there is no key to sign
 data TransmissionForAuth = TransmissionForAuth {tForAuth :: ~ByteString, tToSend :: ByteString}
 
-encodeTransmissionForAuth :: ProtocolEncoding v e c => THandleParams v -> Transmission c -> TransmissionForAuth
+encodeTransmissionForAuth :: ProtocolEncoding v e c => THandleParams v p -> Transmission c -> TransmissionForAuth
 encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId} t =
   TransmissionForAuth {tForAuth, tToSend = if implySessId then t' else tForAuth}
   where
@@ -1391,7 +1655,7 @@ encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId}
     t' = encodeTransmission_ v t
 {-# INLINE encodeTransmissionForAuth #-}
 
-encodeTransmission :: ProtocolEncoding v e c => THandleParams v -> Transmission c -> ByteString
+encodeTransmission :: ProtocolEncoding v e c => THandleParams v p -> Transmission c -> ByteString
 encodeTransmission THandleParams {thVersion = v, sessionId, implySessId} t =
   if implySessId then t' else smpEncode sessionId <> t'
   where
@@ -1404,11 +1668,11 @@ encodeTransmission_ v (CorrId corrId, queueId, command) =
 {-# INLINE encodeTransmission_ #-}
 
 -- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
-tGetParse :: Transport c => THandle v c -> IO (NonEmpty (Either TransportError RawTransmission))
+tGetParse :: Transport c => THandle v c p -> IO (NonEmpty (Either TransportError RawTransmission))
 tGetParse th@THandle {params} = eitherList (tParse params) <$> tGetBlock th
 {-# INLINE tGetParse #-}
 
-tParse :: THandleParams v -> ByteString -> NonEmpty (Either TransportError RawTransmission)
+tParse :: THandleParams v p -> ByteString -> NonEmpty (Either TransportError RawTransmission)
 tParse thParams@THandleParams {batch} s
   | batch = eitherList (L.map (\(Large t) -> tParse1 t)) ts
   | otherwise = [tParse1 s]
@@ -1420,10 +1684,10 @@ eitherList :: (a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b
 eitherList = either (\e -> [Left e])
 
 -- | Receive client and server transmissions (determined by `cmd` type).
-tGet :: forall v err cmd c. (ProtocolEncoding v err cmd, Transport c) => THandle v c -> IO (NonEmpty (SignedTransmission err cmd))
+tGet :: forall v err cmd c p. (ProtocolEncoding v err cmd, Transport c) => THandle v c p -> IO (NonEmpty (SignedTransmission err cmd))
 tGet th@THandle {params} = L.map (tDecodeParseValidate params) <$> tGetParse th
 
-tDecodeParseValidate :: forall v err cmd. ProtocolEncoding v err cmd => THandleParams v -> Either TransportError RawTransmission -> SignedTransmission err cmd
+tDecodeParseValidate :: forall v p err cmd. ProtocolEncoding v err cmd => THandleParams v p -> Either TransportError RawTransmission -> SignedTransmission err cmd
 tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \case
   Right RawTransmission {authenticator, authorized, sessId, corrId, entityId, command}
     | implySessId || sessId == sessionId ->
@@ -1444,4 +1708,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])

src/Simplex/Messaging/Server/CLI.hs

@@ -254,7 +254,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"
 

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
@@ -79,7 +83,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 +109,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 +124,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 +137,20 @@ data Server = Server
     savingLock :: Lock
   }
 
+newtype ProxyAgent = ProxyAgent
+  { smpAgent :: SMPClientAgent
+  }
+
+type ClientId = Int
+
 data Client = Client
-  { clientId :: Int,
+  { clientId :: ClientId,
     subscriptions :: TMap RecipientId (TVar 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,
@@ -154,44 +177,47 @@ 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
   delivered <- newEmptyTMVar
   return Sub {subThread, delivered}
 
-newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env
-newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do
+newEnv :: ServerConfig -> IO Env
+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 <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
-  Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
+  tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
+  Fingerprint fp <- loadFingerprint caCertificateFile
   let serverIdentity = KeyHash fp
-  serverStats <- atomically . newServerStats =<< liftIO getCurrentTime
+  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 -> m (StoreLog 'WriteMode)
+    restoreQueues :: QueueStore -> FilePath -> IO (StoreLog 'WriteMode)
     restoreQueues QueueStore {queues, senders, notifiers} f = do
-      (qs, s) <- liftIO $ readWriteStoreLog f
+      (qs, s) <- readWriteStoreLog f
       atomically $ do
         writeTVar queues =<< mapM newTVar qs
         writeTVar senders $! M.foldr' addSender M.empty qs
@@ -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}

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)

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 "<hostnames>" 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 "<hostnames>") 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
@@ -190,9 +272,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 +293,163 @@ 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
             }
+        textToSocksMode :: Text -> SocksMode
+        textToSocksMode = \case
+          "always" -> SMAlways
+          "onion" -> SMOnion
+          s -> error . T.unpack $ "Invalid socks_mode: " <> s
+        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 +464,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 +521,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 +533,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
-

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

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

@@ -54,7 +54,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

src/Simplex/Messaging/Server/Stats.hs

@@ -26,13 +26,25 @@ 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,
     activeQueuesNtf :: PeriodStats RecipientId,
+    pRelays :: ProxyStats,
+    pRelaysOwn :: ProxyStats,
+    pMsgFwds :: ProxyStats,
+    pMsgFwdsOwn :: ProxyStats,
+    pMsgFwdsRecv :: TVar Int,
     qCount :: TVar Int,
     msgCount :: TVar Int
   }
@@ -44,13 +56,25 @@ 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,
+    _pRelays :: ProxyStatsData,
+    _pRelaysOwn :: ProxyStatsData,
+    _pMsgFwds :: ProxyStatsData,
+    _pMsgFwdsOwn :: ProxyStatsData,
+    _pMsgFwdsRecv :: Int,
     _qCount :: Int,
     _msgCount :: Int
   }
@@ -64,16 +88,28 @@ 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
+  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, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv, qCount, msgCount}
 
 getServerStatsData :: ServerStats -> STM ServerStatsData
 getServerStatsData s = do
@@ -83,16 +119,28 @@ 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
+  _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, _pRelays, _pRelaysOwn, _pMsgFwds, _pMsgFwdsOwn, _pMsgFwdsRecv, _qCount, _msgCount}
 
 setServerStats :: ServerStats -> ServerStatsData -> STM ()
 setServerStats s d = do
@@ -102,35 +150,63 @@ 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)
+  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),
         "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 +215,19 @@ 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="
     _activeQueues <-
       optional ("activeQueues:" <* A.endOfLine) >>= \case
         Just _ -> strP <* optional A.endOfLine
@@ -157,7 +240,18 @@ 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, _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 +325,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}

src/Simplex/Messaging/Server/StoreLog.hs

@@ -25,8 +25,8 @@ where
 
 import Control.Applicative (optional, (<|>))
 import Control.Monad (foldM, unless, when)
-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.Map.Strict (Map)
 import qualified Data.Map.Strict as M
@@ -148,13 +148,14 @@ writeQueues s = mapM_ $ \q -> when (active q) $ logCreateQueue s q
     active QueueRec {status} = status == QueueActive
 
 readQueues :: FilePath -> IO (Map RecipientId QueueRec)
-readQueues f = foldM processLine M.empty . B.lines =<< B.readFile f
+readQueues f = foldM processLine M.empty . LB.lines =<< LB.readFile f
   where
-    processLine :: Map RecipientId QueueRec -> ByteString -> IO (Map RecipientId QueueRec)
-    processLine m s = case strDecode $ trimCR s of
+    processLine :: Map RecipientId QueueRec -> LB.ByteString -> IO (Map RecipientId QueueRec)
+    processLine m s' = case strDecode $ trimCR s of
       Right r -> pure $ procLogRecord r
       Left e -> printError e $> m
       where
+        s = LB.toStrict s'
         procLogRecord :: StoreLogRecord -> Map RecipientId QueueRec
         procLogRecord = \case
           CreateQueue q -> M.insert (recipientId q) q m

src/Simplex/Messaging/Session.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Session where
+
+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,
+    sessionVarTs :: UTCTime
+  }
+
+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, sessionVarTs}
+      TM.insert sessKey v vs
+      pure v
+
+removeSessVar :: Ord k => SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
+removeSessVar = void .:. removeSessVar'
+{-# INLINE removeSessVar #-}
+
+removeSessVar' :: Ord k => SessionVar a -> k -> TMap k (SessionVar a) -> STM Bool
+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)

src/Simplex/Messaging/Transport.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
 -- |
@@ -32,14 +33,19 @@ module Simplex.Messaging.Transport
     VersionSMP,
     VersionRangeSMP,
     THandleSMP,
+    supportedSMPHandshakes,
     supportedClientSMPRelayVRange,
     supportedServerSMPRelayVRange,
+    proxiedSMPRelayVRange,
+    legacyServerSMPRelayVRange,
     currentClientSMPRelayVersion,
+    legacyServerSMPRelayVersion,
     currentServerSMPRelayVersion,
     batchCmdsSMPVersion,
     basicAuthSMPVersion,
     subModeSMPVersion,
     authCmdsSMPVersion,
+    sendingProxySMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -54,6 +60,7 @@ module Simplex.Messaging.Transport
     -- * TLS Transport
     TLS (..),
     SessionId,
+    ALPN,
     connectTLS,
     closeTLS,
     supportedParameters,
@@ -69,14 +76,13 @@ module Simplex.Messaging.Transport
     smpClientHandshake,
     tPutBlock,
     tGetBlock,
-    serializeTransportError,
-    transportErrorP,
     sendHandshake,
     getHandshake,
+    smpTHParamsSetVersion,
   )
 where
 
-import Control.Applicative ((<|>))
+import Control.Applicative (optional)
 import Control.Monad (forM)
 import Control.Monad.Except
 import Control.Monad.Trans.Except (throwE)
@@ -122,7 +128,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
 
@@ -147,20 +153,44 @@ subModeSMPVersion = VersionSMP 6
 authCmdsSMPVersion :: VersionSMP
 authCmdsSMPVersion = VersionSMP 7
 
+sendingProxySMPVersion :: VersionSMP
+sendingProxySMPVersion = VersionSMP 8
+
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 6
+currentClientSMPRelayVersion = VersionSMP 8
+
+legacyServerSMPRelayVersion :: VersionSMP
+legacyServerSMPRelayVersion = VersionSMP 6
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 6
+currentServerSMPRelayVersion = VersionSMP 8
+
+-- 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 8
 
 -- 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
 
@@ -192,6 +222,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 ()
 
@@ -228,10 +261,13 @@ data TLS = TLS
     tlsPeer :: TransportPeer,
     tlsUniq :: ByteString,
     tlsBuffer :: TBuffer,
+    tlsALPN :: Maybe ALPN,
     tlsServerCerts :: X.CertificateChain,
     tlsTransportConfig :: TransportConfig
   }
 
+type ALPN = ByteString
+
 connectTLS :: T.TLSParams p => Maybe HostName -> TransportConfig -> p -> Socket -> IO T.Context
 connectTLS host_ TransportConfig {logTLSErrors} params sock =
   E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx ->
@@ -246,7 +282,8 @@ getTLS tlsPeer cfg tlsServerCerts cxt = withTlsUnique tlsPeer cxt newTLS
   where
     newTLS tlsUniq = do
       tlsBuffer <- atomically newTBuffer
-      pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer}
+      tlsALPN <- T.getNegotiatedProtocol cxt
+      pure TLS {tlsContext = cxt, tlsALPN, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer}
 
 withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c
 withTlsUnique peer cxt f =
@@ -282,6 +319,7 @@ instance Transport TLS where
   getServerConnection = getTLS TServer
   getClientConnection = getTLS TClient
   getServerCerts = tlsServerCerts
+  getSessionALPN = tlsALPN
   tlsUnique = tlsUniq
   closeConnection tls = closeTLS $ tlsContext tls
 
@@ -306,20 +344,22 @@ instance Transport TLS where
 -- * SMP transport
 
 -- | The handle for SMP encrypted transport connection over Transport.
-data THandle v c = THandle
+data THandle v c p = THandle
   { connection :: c,
-    params :: THandleParams v
+    params :: THandleParams v p
   }
 
-type THandleSMP c = THandle SMPVersion c
+type THandleSMP c p = THandle SMPVersion c p
 
-data THandleParams v = THandleParams
+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
-    thAuth :: Maybe THandleAuth,
+    thAuth :: Maybe (THandleAuth p),
     -- | do NOT send session ID in transmission, but include it into signed message
     -- based on protocol version
     implySessId :: Bool,
@@ -328,10 +368,18 @@ data THandleParams v = THandleParams
     batch :: Bool
   }
 
-data THandleAuth = THandleAuth
-  { peerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key
-    privKey :: C.PrivateKeyX25519 -- used to combine with peer's per-queue key (currently only in the server)
-  }
+data THandleAuth (p :: TransportPeer) where
+  THAuthClient ::
+    { serverPeerPubKey :: C.PublicKeyX25519, -- used by the client to combine with client's private per-queue key
+      serverCertKey :: (X.CertificateChain, X.SignedExact X.PubKey), -- the key here is serverPeerPubKey signed with server certificate
+      sessSecret :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
+    } ->
+    THandleAuth 'TClient
+  THAuthServer ::
+    { serverPrivKey :: C.PrivateKeyX25519, -- used by the server to combine with client's public per-queue key
+      sessSecret' :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
+    } ->
+    THandleAuth 'TServer
 
 -- | TLS-unique channel binding
 type SessionId = ByteString
@@ -340,6 +388,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)
   }
 
@@ -385,12 +434,14 @@ encodeAuthEncryptCmds v k
   | otherwise = ""
 
 authEncryptCmdsP :: VersionSMP -> Parser a -> Parser (Maybe a)
-authEncryptCmdsP v p = if v >= authCmdsSMPVersion then Just <$> p else pure Nothing
+authEncryptCmdsP v p = if v >= authCmdsSMPVersion then optional p else pure Nothing
 
 -- | Error of SMP encrypted transport over TCP.
 data TransportError
   = -- | error parsing transport block
     TEBadBlock
+  | -- | incompatible client or server version
+    TEVersion
   | -- | message does not fit in transport block
     TELargeMsg
   | -- | incorrect session ID
@@ -406,40 +457,38 @@ 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 -> ByteString -> IO (Either TransportError ())
+tPutBlock :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
 tPutBlock THandle {connection = c, params = THandleParams {blockSize}} block =
   bimapM (const $ pure TELargeMsg) (cPut c) $
     C.pad block blockSize
 
 -- | Receive block from SMP transport.
-tGetBlock :: Transport c => THandle v c -> IO (Either TransportError ByteString)
+tGetBlock :: Transport c => THandle v c p -> IO (Either TransportError ByteString)
 tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
   msg <- cGet c blockSize
   if B.length msg == blockSize
@@ -449,61 +498,89 @@ tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
 -- | Server SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c)
+smpServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TServer)
 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 $ smpThHandle 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.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c)
-smpClientHandshake c (k, pk) keyHash@(C.KeyHash kh) smpVRange = do
+smpClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TClient)
+smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do
   let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
   ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
   if sessionId /= sessId
     then throwE TEBadSession
-    else case smpVersionRange `compatibleVersion` smpVRange of
-      Just (Compatible v) -> do
-        sk_ <- forM authPubKey $ \(X.CertificateChain cert, exact) ->
+    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
               [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
               _ -> throwError "bad certificate"
             serverKey <- getServerVerifyKey c
             pubKey <- C.verifyX509 serverKey exact
-            C.x509ToPublic (pubKey, []) >>= C.pubKey
-        sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = Just k}
-        pure $ smpThHandle th v pk sk_
-      Nothing -> throwE $ TEHandshake VERSION
+            (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
+        let v = maxVersion vr
+        sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_}
+        pure $ smpTHandleClient th v vr (snd <$> ks_) ck_
+      Nothing -> throwE TEVersion
 
-smpThHandle :: forall c. THandleSMP c -> VersionSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c
-smpThHandle th@THandle {params} v privKey k_ =
+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)
+
+smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleSMP c 'TClient
+smpTHandleClient th v vr pk_ ck_ =
+  let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = C.dh' k <$> pk_}) <$> ck_
+   in smpTHandle_ th v vr 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 thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
-      params' = params {thVersion = v, thAuth, implySessId = v >= authCmdsSMPVersion}
-   in (th :: THandleSMP c) {params = params'}
+  let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion}
+   in (th :: THandleSMP c p) {params = params'}
 
-sendHandshake :: (Transport c, Encoding smp) => THandle v c -> smp -> ExceptT TransportError IO ()
+-- 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
 
 -- ignores tail bytes to allow future extensions
-getHandshake :: (Transport c, Encoding smp) => THandle v c -> ExceptT TransportError IO smp
+getHandshake :: (Transport c, Encoding smp) => THandle v c p -> ExceptT TransportError IO smp
 getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP =<<) <$> tGetBlock th
 
-smpTHandle :: Transport c => c -> THandleSMP c
+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)