Compare commits

..
Author SHA1 Message Date
Evgeny Poberezkin d88b6352f9 agent: disable waiting for network 2024-05-18 10:35:55 +01:00
101 changed files with 3008 additions and 8541 deletions
-47
View File
@@ -1,50 +1,3 @@
# 5.8.1
Agent:
- API to reconnect one server.
- Better error handling of file errors and remote control connection errors.
- Only start uploading file once all chunks were registered on the servers.
SMP server:
- additional stats for sent message notifications.
- fix server page layout.
# 5.8.0
Version 5.8.0.10
SMP server and client:
- protocol extension to forward messages to the destination servers, to protect sending client IP address and transport session.
Agent:
- process timed out subscription responses to reduce the number of resubscriptions.
- avoid sending messages and commands when waiting for response timed out (except batched SUB and DEL commands).
- fix issue with stuck message reception on slow connection (when response to ACK timed out, and the new message was not processed until resubscribed).
- fix issue when temporary file sending or receiving error was treated as permanent.
SMP server:
- include OK responses to all batched SUB requests to reduce subscription timeouts.
XFTP server:
- report file upload timeout as TIMEOUT, to avoid delivery failure.
# 5.7.6
XFTP agent:
- treat XFTP handshake timeouts and network errors as temporary, to retry file operations.
# 5.7.5
SMP agent:
- fail if non-unique connection IDs are passed to sendMessages (to prevent client errors and deadlocks).
# 5.7.4
SMP agent:
- remove re-subscription timeouts (as they are tracked per operation, and could cause failed subscriptions).
- reconnect XFTP clients when network settings changes.
- fix lock contention resulting in stuck subscriptions on network change.
# 5.7.3
SMP/NTF protocol:
+3 -2
View File
@@ -1,9 +1,10 @@
{-# 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"
@@ -19,4 +20,4 @@ main = do
setLogLevel LogDebug
cfgPath <- getEnvPath "SMP_SERVER_CFG_PATH" defaultCfgPath
logPath <- getEnvPath "SMP_SERVER_LOG_PATH" defaultLogPath
withGlobalLogging logCfg $ smpServerCLI_ Static.generateSite Static.serveStaticFiles cfgPath logPath
withGlobalLogging logCfg $ smpServerCLI cfgPath logPath
@@ -1 +0,0 @@
../link.html
File diff suppressed because one or more lines are too long
@@ -1 +0,0 @@
../link.html
File diff suppressed because one or more lines are too long
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.

Before

Width:  |  Height:  |  Size: 18 KiB

@@ -1,26 +0,0 @@
<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>

Before

Width:  |  Height:  |  Size: 16 KiB

-66
View File
@@ -1,66 +0,0 @@
(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";
}
}
})();
Binary file not shown.

Before

Width:  |  Height:  |  Size: 289 KiB

-372
View File
@@ -1,372 +0,0 @@
<?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>

Before

Width:  |  Height:  |  Size: 12 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 1.1 KiB

@@ -1,39 +0,0 @@
<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>

Before

Width:  |  Height:  |  Size: 6.3 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 7.2 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 8.1 KiB

@@ -1,10 +0,0 @@
<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>

Before

Width:  |  Height:  |  Size: 1.1 KiB

@@ -1,15 +0,0 @@
<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>

Before

Width:  |  Height:  |  Size: 1.2 KiB

-3
View File
@@ -1,3 +0,0 @@
<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>

Before

Width:  |  Height:  |  Size: 632 B

File diff suppressed because one or more lines are too long
-39
View File
@@ -1,39 +0,0 @@
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');
}
})
-414
View File
@@ -1,414 +0,0 @@
@font-face {
font-family: Gilroy;
src: url("GilroyRegular.woff2") format("woff2");
font-weight: 400;
font-style: normal;
}
@font-face {
font-family: Gilroy;
src: url("GilroyLight.woff2") format("woff2");
font-weight: 300;
font-style: normal;
}
@font-face {
font-family: Gilroy;
src: url("GilroyMedium.woff2") format("woff2");
font-weight: 500;
font-style: normal;
}
@font-face {
font-family: Gilroy;
src: url("GilroyBold.woff2") format("woff2");
font-weight: 700;
font-style: normal;
}
@font-face {
font-family: Gilroy;
src: url("GilroyRegularItalic.woff2") format("woff2");
font-weight: 400;
font-style: italic;
}
html {
scroll-behavior: smooth;
font-family: Gilroy, Helvetica, sans-serif;
;
letter-spacing: 0.003em;
}
img {
user-select: none;
-webkit-user-select: none;
/* For Safari and older Chrome versions */
-moz-user-select: none;
/* For Firefox */
-ms-user-select: none;
/* For Internet Explorer and Edge */
}
a{
word-wrap: break-word;
}
/* NEW SITE */
.container,
.container-fluid,
.container-xxl,
.container-xl,
.container-lg,
.container-md,
.container-sm {
width: 100%;
/* padding: 0 20px; */
margin-right: auto;
margin-left: auto;
}
@media (min-width: 576px) {
.container-sm,
.container {
max-width: 540px;
}
}
@media (min-width: 768px) {
.container-md,
.container-sm,
.container {
max-width: 720px;
}
}
@media (min-width: 992px) {
.container-lg,
.container-md,
.container-sm,
.container {
max-width: 960px;
}
}
@media (min-width: 1200px) {
.container-xl,
.container-lg,
.container-md,
.container-sm,
.container {
max-width: 1140px;
}
}
@media (min-width: 1400px) {
.container-xxl,
.container-xl,
.container-lg,
.container-md,
.container-sm,
.container {
max-width: 1320px;
}
}
.gradient-text {
background: -webkit-linear-gradient(to bottom, #53C1FF -50%, #0053D0 160%);
background: linear-gradient(to bottom, #53C1FF -50%, #0053D0 160%);
-webkit-background-clip: text;
-webkit-text-fill-color: transparent;
background-clip: text;
text-fill-color: transparent;
}
.dark .border-gradient {
background:
linear-gradient(#11182F, #11182F) padding-box,
linear-gradient(to bottom, transparent, #01F1FF 58%) border-box;
border: 1px solid transparent;
}
.dark .only-light {
display: none;
}
.only-dark {
display: none;
}
.dark .only-dark {
display: inherit;
}
.menu-link {
font-size: 16px;
line-height: 33.42px;
color: #0D0E12;
}
.dark .menu-link {
color: #fff;
}
.nav-link ul li a.active {
color: #0053D0;
}
.dark .nav-link ul li a.active {
color: #66D9E2;
}
@media (min-width:1024px) {
.nav-link-text,
.menu-link {
display: inline-block;
position: relative;
color: #0D0E12;
}
.nav-link-text::before,
.active .nav-link-text::before,
.menu-link::before {
content: "";
position: absolute;
width: 0;
height: 1px;
bottom: 0;
right: 0;
/* background-color: initial; */
transition: width 0.25s ease-out;
}
.menu-link::before {
background-color: #0D0E12;
}
.dark .menu-link::before {
background-color: #fff;
}
.active .nav-link-text::before {
width: 100%;
}
.nav-link:hover .nav-link-text::before,
.menu-link:hover::before {
width: 100%;
left: 0;
right: auto;
}
}
.sub-menu {
visibility: hidden;
opacity: 0;
color: #505158;
}
.sub-menu .no-hover {
color: #505158 !important;
}
.dark .sub-menu,
.dark .sub-menu .no-hover {
color: #fff !important;
}
.dark .sub-menu li:hover {
color: #66D9E2;
}
.sub-menu li:hover {
color: #0053D0;
}
.sub-menu {
transition: all .3s ease !important;
}
.nav-link span svg,
header nav {
transition: all 0.5s ease;
}
.nav-link:hover span svg {
transform: rotate(180deg);
}
@media (min-width:1024px) {
.nav-link:hover .sub-menu,
.nav-link:focus-within .sub-menu {
visibility: visible;
opacity: 1;
margin-top: 0;
}
}
@media (max-width: 1024px) {
.sub-menu {
max-height: 0;
transform: translateY(-10px);
transition: all .7s ease !important;
}
.active .sub-menu {
max-height: 600px;
transform: translateY(0px);
opacity: 1;
visibility: visible;
margin-top: 0;
}
header nav {
visibility: hidden;
opacity: 0;
transform: translateX(100%);
}
header nav.open {
visibility: visible;
opacity: 1;
transform: translateX(0);
}
}
.lock-scroll {
overflow: hidden;
}
/* hero */
header {
transition: all .7s ease;
}
.primary-header {
background: linear-gradient(270deg, #0053D0 35.85%, #0197FF 94.78%);
-webkit-background-clip: text;
-webkit-text-fill-color: transparent;
background-clip: text;
text-shadow: 0px 4px 74px #e9e7e2;
}
.dark .primary-header {
background: linear-gradient(270deg, #70F0F9 100%, #70F0F9 100%);
-webkit-background-clip: text;
-webkit-text-fill-color: transparent;
background-clip: text;
text-shadow: none;
}
.secondary-header {
color: #606c71;
text-shadow: 0px 4px 74px #e9e7e2;
}
.dark .secondary-header {
color: #fff;
text-shadow: none;
}
.description {
width: 31rem;
}
p a {
color: #0053D0;
text-decoration: underline;
text-underline-offset: 2px;
}
.dark p a {
color: #70F0F9;
}
/* For Contact & Invitation Page */
.primary-header-contact {
background: linear-gradient(251.16deg, #53c1ff 1.1%, #0053d0 100.82%);
-webkit-background-clip: text;
-webkit-text-fill-color: transparent;
background-clip: text;
text-shadow: 0px 4px 74px #e9e7e2;
}
.dark .primary-header-contact {
background: linear-gradient(270deg, #70F0F9 100%, #70F0F9 100%);
-webkit-background-clip: text;
-webkit-text-fill-color: transparent;
background-clip: text;
text-shadow: none;
}
.secondary-header-contact {
text-shadow: 0px 4px 74px #e9e7e2;
}
.dark .secondary-header-contact {
text-shadow: none;
}
.content_copy_with_tooltip {
background-color: #f8f8f6;
border-radius: 50px;
padding-bottom: 4px;
padding-top: 8px;
margin-top: 16px;
margin-bottom: 16px;
}
.content_copy_with_tooltip .tooltip {
vertical-align: -6px;
}
.content_copy_with_tooltip .content {
font-size: 15px;
}
.contact-tab>.contact-tab-content,
.job-tab>.job-tab-content {
opacity: 0;
max-height: 0;
transition: all 0.5s ease;
visibility: hidden;
transform: translateY(10px);
overflow: hidden;
}
.contact-tab svg,
.job-tab svg {
transform: rotate(-180deg);
transition: all .5s ease;
}
.contact-tab.active>.contact-tab-content,
.job-tab.active>.job-tab-content {
opacity: 1;
max-height: 300px;
visibility: visible;
transform: translateY(0px);
}
.for-tablet .contact-tab.active>.contact-tab-content,
.for-tablet .job-tab.active>.job-tab-content {
min-height: 450px;
}
.contact-tab.active svg,
.contact-tab:hover svg,
.job-tab.active svg,
.job-tab:hover svg {
transform: rotate(0deg);
}
.d-none-if-js-disabled {
display: none !important;
}
-11
View File
@@ -1,11 +0,0 @@
<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>

Before

Width:  |  Height:  |  Size: 3.5 KiB

File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because it is too large Load Diff
Binary file not shown.

Before

Width:  |  Height:  |  Size: 18 KiB

-176
View File
@@ -1,176 +0,0 @@
{-# 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 <> "}"
-15
View File
@@ -1,15 +0,0 @@
{-# 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/")
+13 -33
View File
@@ -1,5 +1,5 @@
name: simplexmq
version: 5.8.1.0
version: 5.8.0.1
synopsis: SimpleXMQ message broker
description: |
This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -22,8 +22,6 @@ 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.*
@@ -87,9 +85,6 @@ flags:
manual: True
default: True
# cpp-options:
# - -Dslow_servers
when:
- condition: flag(swift)
cpp-options:
@@ -115,16 +110,10 @@ library:
executables:
smp-server:
source-dirs:
- apps/smp-server
- apps/smp-server/web
source-dirs: apps/smp-server
main: Main.hs
dependencies:
- file-embed
- simplexmq
- wai-app-static
- warp
- warp-tls
ghc-options:
- -threaded
- -rtsopts
@@ -147,6 +136,15 @@ 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
@@ -179,31 +177,13 @@ tests:
ghc-options:
# - -haddock
- -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
- -Wall
- -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
+13 -20
View File
@@ -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.
usage_conditions: https://github.com/simplex-chat/simplex-chat/blob/_archived-ep/ios-file-provider/PRIVACY.md
# condition_amendments: link
conditions: https://github.com/simplex-chat/simplex-chat/blob/_archived-ep/ios-file-provider/PRIVACY.md
# conditions_amendments: link
server_country: SE
operator: SimpleX Chat Ltd.
@@ -62,9 +62,9 @@ website: https://simplex.chat
admin_simplex: administrative SimpleX address
admin_email: chat@simplex.chat
admin_pgp: PGP key
complaints_simplex: SimpleX address for feedback, comments and complaints
complaints_email: complaints@simplex.chat
complaints_pgp: PGP key
feedback_simplex: SimpleX address for feedback, comments and complaints
feedback_email: complaints@simplex.chat
feedback_pgp: PGP key
hosting: Linode / Akamai Inc.
hosting_country: US
```
@@ -89,27 +89,20 @@ data ServerHandshake = ServerHandshake
}
data ServerInformation = ServerInformation
{ config :: ServerPublicConfig,
info :: ServerPublicInfo
}
-- based on server configuration
data ServerPublicConfig = ServerPublicConfig
{ persistence :: SMPServerPersistenceMode,
{ -- below is based on the existing server configuration
persistence :: SMPServerPersistenceMode,
messageExpiration :: Int,
statsEnabled :: Bool,
newQueuesAllowed :: Bool,
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
basicAuthEnabled :: Bool, -- server is private if enabled
-- below is based on INFORMATION section of INI file
sourceCode :: Text, -- note that this property is not optional, in line with AGPLv3 license
-- all below properties are optional, except entity name MUST be present if any entity country is present
conditions :: Maybe ServerConditions,
operator :: Maybe Entity,
website :: Maybe Text,
adminContacts :: Maybe ServerContactAddress,
complaintsContacts :: Maybe ServerContactAddress,
admin :: Maybe ServerContactAddress,
feedback :: Maybe ServerContactAddress,
hosting :: Maybe Entity,
serverCountry :: Maybe Text
}
-19
View File
@@ -1,19 +0,0 @@
# 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).
+84 -44
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 5.8.1.0
version: 5.8.0.1
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -28,33 +28,6 @@ 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
@@ -95,6 +68,7 @@ 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
@@ -131,7 +105,6 @@ 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
@@ -166,12 +139,10 @@ 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
@@ -203,7 +174,7 @@ library
src
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
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2
include-dirs:
cbits
c-sources:
@@ -284,7 +255,82 @@ executable ntf-server
apps/ntf-server
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
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
, asn1-encoding ==0.9.*
, asn1-types ==0.3.*
, async ==2.2.*
, attoparsec ==0.14.*
, base >=4.14 && <5
, base64-bytestring >=1.0 && <1.3
, case-insensitive ==1.2.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
, containers ==0.6.*
, crypton ==0.34.*
, crypton-x509 ==1.7.*
, crypton-x509-store ==1.6.*
, crypton-x509-validation ==1.6.*
, cryptostore ==0.3.*
, data-default ==0.7.*
, direct-sqlcipher ==2.3.*
, directory ==1.3.*
, filepath ==1.4.*
, hourglass ==0.2.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
, ini ==0.4.1
, iproute ==1.7.*
, iso8601-time ==0.1.*
, memory ==0.18.*
, mtl >=2.3.1 && <3.0
, network >=3.1.2.7 && <3.2
, network-info ==0.2.*
, network-transport ==0.5.6
, network-udp ==0.0.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, random >=1.1 && <1.3
, simple-logger ==0.1.*
, simplexmq
, socks ==0.6.*
, sqlcipher-simple ==0.4.*
, stm ==2.5.*
, temporary ==1.3.*
, time ==1.12.*
, time-manager ==0.0.*
, tls >=1.7.0 && <1.8
, transformers ==0.6.*
, unliftio ==0.2.*
, unliftio-core ==0.2.*
, websockets ==0.12.*
, yaml ==0.11.*
, zstd ==0.1.3.*
default-language: Haskell2010
if flag(swift)
cpp-options: -DswiftJSON
if impl(ghc >= 9.6.2)
build-depends:
bytestring ==0.11.*
, template-haskell ==2.20.*
, text >=2.0.1 && <2.2
if impl(ghc < 9.6.2)
build-depends:
bytestring ==0.10.*
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3
executable smp-agent
main-is: Main.hs
other-modules:
Paths_simplexmq
hs-source-dirs:
apps/smp-agent
default-extensions:
StrictData
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -354,15 +400,12 @@ executable ntf-server
executable smp-server
main-is: Main.hs
other-modules:
Static
Static.Embedded
Paths_simplexmq
hs-source-dirs:
apps/smp-server
apps/smp-server/web
default-extensions:
StrictData
ghc-options: -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
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -384,7 +427,6 @@ 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.*
@@ -413,9 +455,6 @@ 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.*
@@ -441,7 +480,7 @@ executable xftp
apps/xftp
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
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -516,7 +555,7 @@ executable xftp-server
apps/xftp-server
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
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -601,6 +640,7 @@ test-suite simplexmq-test
CoreTests.CryptoFileTests
CoreTests.CryptoTests
CoreTests.EncodingTests
CoreTests.ProtocolErrorTests
CoreTests.RetryIntervalTests
CoreTests.TRcvQueuesTests
CoreTests.UtilTests
@@ -623,7 +663,7 @@ test-suite simplexmq-test
tests
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
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
build-depends:
HUnit ==1.6.*
, QuickCheck ==2.14.*
+62 -87
View File
@@ -32,13 +32,12 @@ 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 (partitionEithers, rights)
import Data.Either (rights)
import Data.Int (Int64)
import Data.List (foldl', partition, sortOn)
import qualified Data.List.NonEmpty as L
@@ -57,7 +56,6 @@ 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
@@ -71,8 +69,7 @@ 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, ProtocolServer, ProtocolType (..), XFTPServer)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Protocol (EntityId, XFTPServer)
import Simplex.Messaging.Util (catchAll_, liftError, tshow, unlessM, whenM)
import System.FilePath (takeFileName, (</>))
import UnliftIO
@@ -115,8 +112,8 @@ closeXFTPAgent a = do
where
stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AM RcvFileId
xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs approvedRelays = do
xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> AM RcvFileId
xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs = do
g <- asks random
prefixPath <- lift $ getPrefixPath "rcv.xftp"
createDirectory prefixPath
@@ -127,7 +124,7 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi
lift $ createEmptyFile =<< toFSFilePath relSavePath
let saveFile = CryptoFile relSavePath cfArgs
fId <- case redirect of
Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile approvedRelays
Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile
Just _ -> do
-- prepare description paths
let relTmpPathRedirect = relPrefixPath </> "xftp.redirect-encrypted"
@@ -137,14 +134,14 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi
cfArgsRedirect <- atomically $ CF.randomArgs g
let saveFileRedirect = CryptoFile relSavePathRedirect $ Just cfArgsRedirect
-- create download tasks
withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile approvedRelays
withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile
forM_ chunks (downloadChunk c)
pure fId
downloadChunk :: AgentClient -> FileChunk -> AM ()
downloadChunk c FileChunk {replicas = (FileChunkReplica {server} : _)} = do
lift . void $ getXFTPRcvWorker True c (Just server)
downloadChunk _ _ = throwE $ INTERNAL "no replicas"
downloadChunk _ _ = throwError $ INTERNAL "no replicas"
getPrefixPath :: String -> AM' FilePath
getPrefixPath suffix = do
@@ -177,27 +174,26 @@ runXFTPRcvWorker c srv Worker {doWork} = do
runXFTPOperation cfg
where
runXFTPOperation :: AgentConfig -> AM ()
runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpConsecutiveRetries} =
runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} =
withWork c doWork (\db -> getNextRcvChunkToDownload db srv rcvFilesTTL) $ \case
(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
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
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
liftIO $ waitForUserNetwork c
downloadFileChunk fc replica approvedRelays
downloadFileChunk fc replica
`catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
where
retryLoop loop e replicaDelay = do
flip catchAgentError (\_ -> pure ()) $ do
when (serverHostError e) $ notify c rcvFileEntityId $ RFWARN e
when notifyOnRetry $ notify c rcvFileEntityId $ RFERR e
liftIO $ closeXFTPServerClient c userId server digest
withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
atomically $ assertAgentForeground c
loop
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
retryDone e = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (show e)
downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> AM ()
downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica = do
fsFileTmpPath <- lift $ toFSFilePath fileTmpPath
chunkPath <- uniqueCombine fsFileTmpPath $ show chunkNo
let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
@@ -218,10 +214,6 @@ runXFTPRcvWorker c srv Worker {doWork} = do
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}
@@ -238,15 +230,15 @@ withRetryIntervalLimit maxN ri action =
retryOnError :: Text -> AM a -> AM a -> AgentErrorType -> AM a
retryOnError name loop done e = do
logError $ name <> " error: " <> tshow e
if temporaryOrHostError e
if temporaryAgentError e
then loop
else done
rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath err = do
rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> String -> AM ()
rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do
lift $ forM_ tmpPath (removePath <=< toFSFilePath)
withStore' c $ \db -> updateRcvFileError db rcvFileId (show err)
notify c rcvFileEntityId $ RFERR err
withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr
notify c rcvFileEntityId $ RFERR $ INTERNAL internalErrStr
runXFTPRcvLocalWorker :: AgentClient -> Worker -> AM ()
runXFTPRcvLocalWorker c Worker {doWork} = do
@@ -260,7 +252,7 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
runXFTPOperation AgentConfig {rcvFilesTTL} =
withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $
\f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath
decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
decryptFile :: RcvFile -> AM ()
decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do
let CryptoFile savePath cfArgs = saveFile
@@ -270,11 +262,11 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
chunkPaths <- getChunkPaths chunks
encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
when (FileSize encSize /= size) $ throwE $ XFTP "" XFTP.SIZE
when (FileSize encSize /= size) $ throwError $ XFTP "" XFTP.SIZE
encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
when (FileDigest encDigest /= digest) $ throwE $ XFTP "" XFTP.DIGEST
when (FileDigest encDigest /= digest) $ throwError $ XFTP "" XFTP.DIGEST
let destFile = CryptoFile fsSavePath cfArgs
void $ liftError (FILE . FILE_IO . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure destFile
void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure destFile
case redirect of
Nothing -> do
notify c rcvFileEntityId $ RFDONE fsSavePath
@@ -287,13 +279,13 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
atomically $ waitUntilForeground c
withStore' c (`updateRcvFileComplete` rcvFileId)
-- proceed with redirect
yaml <- liftError (FILE . FILE_IO . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `agentFinally` (lift $ toFSFilePath fsSavePath >>= removePath)
yaml <- liftError (INTERNAL . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `agentFinally` (lift $ toFSFilePath fsSavePath >>= removePath)
next@FileDescription {chunks = nextChunks} <- case strDecode (LB.toStrict yaml) of
-- TODO switch to another error constructor
Left _ -> throwE . FILE $ REDIRECT "decode error"
Left _ -> throwError . XFTP "" $ XFTP.REDIRECT "decode error"
Right (ValidFileDescription fd@FileDescription {size = dstSize, digest = dstDigest})
| dstSize /= redirectSize -> throwE . FILE $ REDIRECT "size mismatch"
| dstDigest /= redirectDigest -> throwE . FILE $ REDIRECT "digest mismatch"
| dstSize /= redirectSize -> throwError . XFTP "" $ XFTP.REDIRECT "size mismatch"
| dstDigest /= redirectDigest -> throwError . XFTP "" $ XFTP.REDIRECT "digest mismatch"
| otherwise -> pure fd
-- register and download chunks from the actual file
withStore c $ \db -> updateRcvFileRedirect db redirectDbId next
@@ -306,7 +298,7 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
fsPath <- lift $ toFSFilePath path
pure $ fsPath : ps
getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) =
throwE $ INTERNAL "no chunk path"
throwError $ INTERNAL "no chunk path"
xftpDeleteRcvFile' :: AgentClient -> RcvFileId -> AM' ()
xftpDeleteRcvFile' c rcvFileEntityId = xftpDeleteRcvFiles' c [rcvFileEntityId]
@@ -326,8 +318,8 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do
batchFiles :: (DB.Connection -> DBRcvFileId -> IO a) -> [RcvFile] -> AM' [Either AgentErrorType a]
batchFiles f rcvFiles = withStoreBatch' c $ \db -> map (\RcvFile {rcvFileId} -> f db rcvFileId) rcvFiles
notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> EntityId -> AEvent e -> m ()
notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd)
notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> EntityId -> ACommand 'Agent e -> m ()
notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, APC (sAEntity @e) cmd)
xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId
xftpSendFile' c userId file numRecipients = do
@@ -351,7 +343,7 @@ xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {si
let directYaml = prefixPath </> "direct.yaml"
cfArgs <- atomically $ CF.randomArgs g
let file = CryptoFile directYaml (Just cfArgs)
liftError (FILE . FILE_IO . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect)
liftError (INTERNAL . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect)
key <- atomically $ C.randomSbKey g
nonce <- atomically $ C.randomCbNonce g
fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce $ Just RedirectFileInfo {size, digest}
@@ -379,11 +371,11 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
runXFTPOperation cfg@AgentConfig {sndFilesTTL} =
withWork c doWork (`getNextSndFileToPrepare` sndFilesTTL) $
\f@SndFile {sndFileId, sndFileEntityId, prefixPath} ->
prepareFile cfg f `catchAgentError` sndWorkerInternalError c sndFileId sndFileEntityId prefixPath
prepareFile cfg f `catchAgentError` (sndWorkerInternalError c sndFileId sndFileEntityId prefixPath . show)
prepareFile :: AgentConfig -> SndFile -> AM ()
prepareFile _ SndFile {prefixPath = Nothing} =
throwE $ INTERNAL "no prefix path"
prepareFile cfg sndFile@SndFile {sndFileId, sndFileEntityId, userId, prefixPath = Just ppath, status} = do
throwError $ INTERNAL "no prefix path"
prepareFile cfg sndFile@SndFile {sndFileId, userId, prefixPath = Just ppath, status} = do
SndFile {numRecipients, chunks} <-
if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
then do
@@ -397,14 +389,9 @@ 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?
srvs <- forM pendingChunks $ createChunk numRecipients'
let allSrvs = S.fromList $ preparedSrvs <> srvs
lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv)
forM_ (filter (\SndFileChunk {replicas} -> null replicas) chunks) $ createChunk numRecipients'
withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
where
AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients, messageRetryInterval = ri} = cfg
@@ -413,60 +400,48 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
let CryptoFile {filePath} = srcFile
fileName = takeFileName filePath
fileSize <- liftIO $ fromInteger <$> CF.getFileContentsSize srcFile
when (fileSize > maxFileSizeHard) $ throwE $ FILE FT.SIZE
when (fileSize > maxFileSizeHard) $ throwError $ INTERNAL "max file size exceeded"
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 -> throwE $ FILE FT.SIZE
Nothing -> throwError $ INTERNAL "max file size exceeded for redirect"
Just chunkSize -> pure [chunkSize]
let encSize = sum $ map fromIntegral chunkSizes
void $ liftError (FILE . FILE_IO . show) $ encryptFile srcFile fileHdr key nonce fileSize' encSize fsEncPath
void $ liftError (INTERNAL . show) $ encryptFile srcFile fileHdr key nonce fileSize' encSize fsEncPath
digest <- liftIO $ LC.sha512Hash <$> LB.readFile fsEncPath
let chunkSpecs = prepareChunkSpecs fsEncPath chunkSizes
chunkDigests <- liftIO $ mapM getChunkDigest chunkSpecs
pure (FileDigest digest, zip chunkSpecs $ coerce chunkDigests)
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 :: Int -> SndFileChunk -> AM ()
createChunk numRecipients' ch = do
atomically $ assertAgentForeground c
(replica, ProtoServerWithAuth srv _) <- tryCreate
withStore' c $ \db -> createSndFileReplica db ch replica
pure srv
lift . void $ getXFTPSndWorker True c (Just srv)
where
tryCreate = do
usedSrvs <- newTVarIO ([] :: [XFTPServer])
let AgentClient {xftpServers} = c
userSrvCount <- length <$> atomically (TM.lookup userId xftpServers)
withRetryIntervalCount (riFast ri) $ \n _ loop -> do
withRetryInterval (riFast ri) $ \_ loop -> do
liftIO $ waitForUserNetwork c
let triedAllSrvs = n > userSrvCount
createWithNextSrv usedSrvs
`catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop triedAllSrvs e) (throwE e) e
`catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e
where
-- 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
retryLoop loop = atomically (assertAgentForeground c) >> loop
createWithNextSrv usedSrvs = do
deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId
when deleted $ throwE $ FILE NO_FILE
when deleted $ throwError $ INTERNAL "file deleted, aborting chunk creation"
withNextSrv c userId usedSrvs [] $ \srvAuth -> do
replica <- agentXFTPNewChunk c ch numRecipients' srvAuth
pure (replica, srvAuth)
sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM ()
sndWorkerInternalError c sndFileId sndFileEntityId prefixPath err = do
sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> String -> AM ()
sndWorkerInternalError c sndFileId sndFileEntityId prefixPath internalErrStr = do
lift . forM_ prefixPath $ removePath <=< toFSFilePath
withStore' c $ \db -> updateSndFileError db sndFileId (show err)
notify c sndFileEntityId $ SFERR err
withStore' c $ \db -> updateSndFileError db sndFileId internalErrStr
notify c sndFileEntityId $ SFERR $ INTERNAL internalErrStr
runXFTPSndWorker :: AgentClient -> XFTPServer -> Worker -> AM ()
runXFTPSndWorker c srv Worker {doWork} = do
@@ -477,9 +452,9 @@ runXFTPSndWorker c srv Worker {doWork} = do
runXFTPOperation cfg
where
runXFTPOperation :: AgentConfig -> AM ()
runXFTPOperation cfg@AgentConfig {sndFilesTTL, reconnectInterval = ri, xftpConsecutiveRetries} = do
runXFTPOperation cfg@AgentConfig {sndFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} = do
withWork c doWork (\db -> getNextSndChunkToUpload db srv sndFilesTTL) $ \case
SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) (INTERNAL "chunk has no replicas")
SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) "chunk has no replicas"
fc@SndFileChunk {userId, sndFileId, sndFileEntityId, filePrefixPath, digest, replicas = replica@SndFileChunkReplica {sndChunkReplicaId, server, delay} : _} -> do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
@@ -489,17 +464,17 @@ runXFTPSndWorker c srv Worker {doWork} = do
where
retryLoop loop e replicaDelay = do
flip catchAgentError (\_ -> pure ()) $ do
when (serverHostError e) $ notify c sndFileEntityId $ SFWARN e
when notifyOnRetry $ notify c sndFileEntityId $ SFERR e
liftIO $ closeXFTPServerClient c userId server digest
withStore' c $ \db -> updateSndChunkReplicaDelay db sndChunkReplicaId replicaDelay
atomically $ assertAgentForeground c
loop
retryDone = sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath)
retryDone e = sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) (show e)
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 <- lift $ toFSFilePath filePath
unlessM (doesFileExist fsFilePath) $ throwE $ FILE NO_FILE
unlessM (doesFileExist fsFilePath) $ throwError $ INTERNAL "encrypted file doesn't exist on upload"
let chunkSpec' = chunkSpec {filePath = fsFilePath} :: XFTPChunkSpec
atomically $ assertAgentForeground c
agentXFTPUploadChunk c userId chunkDigest replica' chunkSpec'
@@ -519,7 +494,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
where
addRecipients :: SndFileChunk -> SndFileChunkReplica -> AM SndFileChunkReplica
addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {rcvIdsKeys}
| length rcvIdsKeys > numRecipients = throwE $ INTERNAL "too many recipients"
| length rcvIdsKeys > numRecipients = throwError $ INTERNAL "too many recipients"
| length rcvIdsKeys == numRecipients = pure cr
| otherwise = do
let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients
@@ -527,22 +502,22 @@ runXFTPSndWorker c srv Worker {doWork} = do
cr' <- withStore' c $ \db -> addSndChunkReplicaRecipients db cr $ L.toList rcvIdsKeys'
addRecipients ch cr'
sndFileToDescrs :: SndFile -> AM (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient])
sndFileToDescrs SndFile {digest = Nothing} = throwE $ INTERNAL "snd file has no digest"
sndFileToDescrs SndFile {chunks = []} = throwE $ INTERNAL "snd file has no chunks"
sndFileToDescrs SndFile {digest = Nothing} = throwError $ INTERNAL "snd file has no digest"
sndFileToDescrs SndFile {chunks = []} = throwError $ INTERNAL "snd file has no chunks"
sndFileToDescrs SndFile {digest = Just digest, key, nonce, chunks = chunks@(fstChunk : _), 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 (throwE . INTERNAL) pure $ validateFileDescription fdSnd
validFdSnd <- either (throwError . INTERNAL) pure $ validateFileDescription fdSnd
-- rcv descriptions
let fdRcv = FileDescription {party = SFRecipient, size, digest, key, nonce, chunkSize, chunks = [], redirect}
fdRcvs = createRcvFileDescriptions fdRcv chunks
validFdRcvs <- either (throwE . INTERNAL) pure $ mapM validateFileDescription fdRcvs
validFdRcvs <- either (throwError . INTERNAL) pure $ mapM validateFileDescription fdRcvs
pure (validFdSnd, validFdRcvs)
toSndDescrChunk :: SndFileChunk -> AM FileChunk
toSndDescrChunk SndFileChunk {replicas = []} = throwE $ INTERNAL "snd file chunk has no replicas"
toSndDescrChunk SndFileChunk {replicas = []} = throwError $ 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}]
@@ -643,7 +618,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
runXFTPOperation cfg
where
runXFTPOperation :: AgentConfig -> AM ()
runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpConsecutiveRetries} = do
runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, 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
@@ -656,7 +631,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
where
retryLoop loop e replicaDelay = do
flip catchAgentError (\_ -> pure ()) $ do
when (serverHostError e) $ notify c "" $ SFWARN e
when notifyOnRetry $ notify c "" $ SFERR e
liftIO $ closeXFTPServerClient c userId server chunkDigest
withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay
atomically $ assertAgentForeground c
+27 -27
View File
@@ -14,7 +14,6 @@ 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)
@@ -39,8 +38,8 @@ import Simplex.Messaging.Client
defaultNetworkConfig,
proxyUsername,
transportClientConfig,
unexpectedResponse,
)
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
@@ -52,12 +51,12 @@ import Simplex.Messaging.Protocol
RecipientId,
SenderId,
)
import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters)
import Simplex.Messaging.Transport (ALPN, 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 (liftEitherWith, liftError', tshow, whenM)
import Simplex.Messaging.Util (bshow, liftEitherWith, liftError', tshow, whenM)
import Simplex.Messaging.Version
import UnliftIO
import UnliftIO.Directory
@@ -116,7 +115,8 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
thParams@THandleParams {thVersion} <- case sessionALPN of
Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
_ -> pure thParams0
Nothing -> pure thParams0
_ -> throwError $ PCETransportError TEVersion
logDebug $ "Client negotiated protocol: " <> tshow thVersion
let c = XFTPClient {http2Client, thParams, transportSession, config}
atomically $ writeTVar clientVar $ Just c
@@ -134,15 +134,15 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session
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)
liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c helloReq Nothing
liftHS . smpDecode =<< liftHS (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
unless (sessionId == serverSessId) $ throwError $ PCEResponseError SESSION
case xftpVersionRange `compatibleVRange` serverVRange of
Nothing -> throwE $ PCETransportError TEVersion
Nothing -> throwError $ PCETransportError TEVersion
Just (Compatible vr) ->
fmap (vr,) . liftTransportErr (TEHandshake BAD_AUTH) $ do
fmap (vr,) . liftHS $ do
let (X.CertificateChain cert, exact) = serverAuth
case cert of
[_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
@@ -151,11 +151,11 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session
C.x509ToPublic (pubKey, []) >>= C.pubKey
sendClientHandshake :: XFTPClientHandshake -> ExceptT XFTPClientError IO ()
sendClientHandshake chs = do
chs' <- liftTransportErr TELargeMsg $ C.pad (smpEncode chs) xftpBlockSize
chs' <- liftHS $ 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)
HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c chsReq Nothing
unless (B.null bodyHead) $ throwError $ PCEResponseError HANDSHAKE
liftHS = liftEitherWith (const $ PCEResponseError HANDSHAKE)
closeXFTPClient :: XFTPClient -> IO ()
closeXFTPClient XFTPClient {http2Client} = closeHTTP2Client http2Client
@@ -200,14 +200,14 @@ sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = d
let req = H.requestStreaming N.methodPost "/" [] streamBody
reqTimeout = xftpReqTimeout config $ (\XFTPChunkSpec {chunkSize} -> chunkSize) <$> chunkSpec_
HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req (Just reqTimeout)
when (B.length bodyHead /= xftpBlockSize) $ throwE $ PCEResponseError BLOCK
when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
-- TODO validate that the file ID is the same as in the request?
(_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead
case respOrErr of
Right r -> case protocolError r of
Just e -> throwE $ PCEProtocolError e
Just e -> throwError $ PCEProtocolError e
_ -> pure (r, body)
Left e -> throwE $ PCEResponseError e
Left e -> throwError $ PCEResponseError e
where
streamBody :: (Builder -> IO ()) -> IO () -> IO ()
streamBody send done = do
@@ -215,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 chunkSize
hSendFile h send $ fromIntegral chunkSize
done
createXFTPChunk ::
@@ -228,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, _) -> throwE $ unexpectedResponse r
(r, _) -> throwError . PCEUnexpectedResponse $ bshow 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, _) -> throwE $ unexpectedResponse r
(r, _) -> throwError . PCEUnexpectedResponse $ bshow r
uploadXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
uploadXFTPChunk c spKey fId chunkSpec =
@@ -250,7 +250,7 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
let dhSecret = C.dh' sDhKey rpDhKey
cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce
let t = chunkTimeout config chunkSize
ExceptT (sequence <$> (t `timeout` (download cbState `catches` errors))) >>= maybe (throwE PCEResponseTimeout) pure
ExceptT (sequence <$> (t `timeout` (download cbState `catches` errors))) >>= maybe (throwError PCEResponseTimeout) pure
where
errors =
[ Handler $ \(_e :: H.HTTP2Error) -> pure $ Left PCENetworkError,
@@ -260,9 +260,9 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
download cbState =
runExceptT . withExceptT PCEResponseError $
receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
whenM (doesFileExist filePath) (removeFile filePath) >> throwE e
_ -> throwE $ PCEResponseError NO_FILE
(r, _) -> throwE $ unexpectedResponse r
whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
_ -> throwError $ PCEResponseError NO_FILE
(r, _) -> throwError . PCEUnexpectedResponse $ bshow r
xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
@@ -286,17 +286,17 @@ pingXFTP c@XFTPClient {thParams} = do
(r, _) <- sendXFTPTransmission c t Nothing
case r of
FRPong -> pure ()
_ -> throwE $ unexpectedResponse r
_ -> throwError $ PCEUnexpectedResponse $ bshow r
okResponse :: (FileResponse, HTTP2Body) -> ExceptT XFTPClientError IO ()
okResponse = \case
(FROk, body) -> noFile body ()
(r, _) -> throwE $ unexpectedResponse r
(r, _) -> throwError . PCEUnexpectedResponse $ bshow 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 -- throwE $ PCEResponseError HAS_FILE
Just _ -> pure a -- throwError $ PCEResponseError HAS_FILE
_ -> pure a
-- FACK :: FileCommand Recipient
+2 -2
View File
@@ -11,7 +11,6 @@ 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)
@@ -19,6 +18,7 @@ import Data.Text.Encoding (decodeUtf8)
import Simplex.FileTransfer.Client
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
import Simplex.Messaging.Client.Agent ()
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
import Simplex.Messaging.TMap (TMap)
@@ -109,7 +109,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
else atomically $ do
putTMVar clientVar r
TM.delete srv xftpClients
throwE e
throwError e
tryConnectAsync :: ME ()
tryConnectAsync = void . lift . async . runExceptT $ do
withRetryInterval (reconnectInterval config) $ \_ loop -> void $ tryConnectClient loop
+15 -16
View File
@@ -30,7 +30,6 @@ 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)
@@ -293,7 +292,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) $ throwE $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported"
when (fileSize > maxFileSize) $ throwError $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported"
encPath <- getEncPath tempPath "xftp"
key <- atomically $ C.randomSbKey g
nonce <- atomically $ C.randomCbNonce g
@@ -324,7 +323,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
-- upload doesn't allow other requests within the same client until complete (but download does allow).
logInfo $ "uploading " <> tshow (length chunks) <> " chunks..."
(errs, rs) <- partitionEithers . concat <$> liftIO (pooledForConcurrentlyN 16 chunks' . mapM $ runExceptT . uploadFileChunk a)
mapM_ throwE errs
mapM_ throwError errs
pure $ map snd (sortOn fst rs)
where
uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk)
@@ -333,7 +332,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 = chunkSize, digest}
let ch = FileInfo {sndKey, size = fromIntegral 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
@@ -345,7 +344,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 chunkSize, digest = FileDigest digest, replicas})
pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize $ fromIntegral chunkSize, digest = FileDigest digest, replicas})
getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
getXFTPServer gen = \case
srv :| [] -> pure srv
@@ -438,12 +437,12 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
srvChunks = groupAllOn srv chunks
g <- liftIO C.newRandom
(errs, rs) <- partitionEithers . concat <$> liftIO (pooledForConcurrentlyN 16 srvChunks $ mapM $ runExceptT . downloadFileChunk g a encPath size downloadedChunks)
mapM_ throwE errs
mapM_ throwError errs
let chunkPaths = map snd $ sortOn fst rs
encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
when (encDigest /= unFileDigest digest) $ throwE $ CLIError "File digest mismatch"
when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
when (FileSize encSize /= size) $ throwE $ CLIError "File size mismatch"
when (FileSize encSize /= size) $ throwError $ 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
@@ -465,20 +464,20 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
printProgress "Downloaded" downloaded encSize
when verbose $ putStrLn ""
pure (chunkNo, chunkPath)
downloadFileChunk _ _ _ _ _ _ = throwE $ CLIError "chunk has no replicas"
downloadFileChunk _ _ _ _ _ _ = throwError $ 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) (throwE "File already exists") (pure path)
ifM (doesFileExist path) (throwError "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 _ _ = throwE $ CLIError "chunk has no replicas"
acknowledgeFileChunk _ _ = throwError $ CLIError "chunk has no replicas"
printProgress :: String -> Int64 -> Int64 -> IO ()
printProgress s part total = printNoNewLine $ s <> " " <> show ((part * 100) `div` total) <> "%"
@@ -504,7 +503,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 _ _ = throwE $ CLIError "chunk has no replicas"
deleteFileChunk _ _ = throwError $ CLIError "chunk has no replicas"
cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
cliFileDescrInfo InfoOptions {fileDescription} = do
@@ -534,7 +533,7 @@ getFileDescription path =
getFileDescription' :: FilePartyI p => FilePath -> ExceptT CLIError IO (ValidFileDescription p)
getFileDescription' path =
getFileDescription path >>= \case
AVFD fd -> either (throwE . CLIError) pure $ checkParty fd
AVFD fd -> either (throwError . CLIError) pure $ checkParty fd
singleChunkSize :: Int64 -> Maybe Word32
singleChunkSize size' =
@@ -564,7 +563,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 = sz}
let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = fromIntegral sz}
in (chunkOffset + fromIntegral sz, spec : specs)
getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath
@@ -575,13 +574,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
throwE e
throwError 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 _ = throwE $ CLIError "internal: no retry attempts"
withRetry' 0 _ = throwError $ CLIError "internal: no retry attempts"
withRetry' 1 a = a
withRetry' n a =
a `catchError` \e -> do
+6 -7
View File
@@ -8,7 +8,6 @@ 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
@@ -49,17 +48,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) $ throwE $ FTCEFileIOError "encrypting file: unexpected EOF"
when (B.length ch /= fromIntegral chSize) $ throwError $ 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 _ [] _ _ _ = throwE $ FTCEInvalidHeader "empty"
decryptChunks _ [] _ _ _ = throwError $ 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 $ throwE FTCEInvalidAuthTag
unless authOk $ throwError FTCEInvalidAuthTag
(FileHeader {fileName}, !f') <- parseFileHeader f
destFile <- withExceptT FTCEFileIOError $ getDestFile fileName
CF.writeFile destFile f'
@@ -74,7 +73,7 @@ decryptChunks encSize (chPath : chPaths) key nonce getDestFile = case reverse ch
decryptLastChunk h state' expectedLen
unless authOk $ do
removeFile path
throwE FTCEInvalidAuthTag
throwError FTCEInvalidAuthTag
pure destFile
where
decryptFirstChunk = do
@@ -106,8 +105,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 -> throwE $ FTCEInvalidHeader e
A.Partial _ -> throwE $ FTCEInvalidHeader "incomplete"
A.Fail _ _ e -> throwError $ FTCEInvalidHeader e
A.Partial _ -> throwError $ FTCEInvalidHeader "incomplete"
A.Done rest hdr -> pure (hdr, LB.fromStrict rest <> s')
readChunks :: [FilePath] -> IO LB.ByteString
+7 -30
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -18,7 +17,6 @@ import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Data.Bifunctor (first)
import qualified Data.ByteString.Base64.URL as B64
import Data.ByteString.Builder (Builder, byteString)
@@ -69,9 +67,6 @@ 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)
@@ -137,34 +132,28 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
either sendError pure r
where
processHello = do
unless (B.null bodyHead) $ throwE HANDSHAKE
unless (B.null bodyHead) $ throwError 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
unless (B.length bodyHead == xftpBlockSize) $ throwError HANDSHAKE
body <- liftHS $ C.unPad bodyHead
XFTPClientHandshake {xftpVersion = v, keyHash} <- liftHS $ smpDecode body
kh <- asks serverIdentity
unless (keyHash == kh) $ throwE HANDSHAKE
unless (keyHash == kh) $ throwError 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
Nothing -> throwError HANDSHAKE
sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion 'TServer))
sendError err = do
runExceptT (encodeXftp err) >>= \case
@@ -326,9 +315,6 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
where
sendXFTPResponse (corrId, fId, resp) serverFile_ = do
let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
#ifdef slow_servers
randomDelay
#endif
liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_
where
streamBody t_ send done = do
@@ -340,18 +326,9 @@ 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 fileSize
withFile filePath ReadMode $ \h -> sendEncFile h send sbState (fromIntegral fileSize)
done
#ifdef slow_servers
randomDelay :: M ()
randomDelay = do
d <- asks $ responseDelay . config
when (d > 0) $ do
pc <- getStdRandom (randomR (-200, 200))
threadDelay $ (d * (1000 + pc)) `div` 1000
#endif
data VerificationResult = VRVerified XFTPRequest | VRFailed
verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
@@ -396,7 +373,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
st <- asks store
r <- runExceptT $ do
sizes <- asks $ allowedChunkSizes . config
unless (size file `elem` sizes) $ throwE SIZE
unless (size file `elem` sizes) $ throwError SIZE
ts <- liftIO getSystemTime
-- TODO validate body empty
sId <- ExceptT $ addFileRetry st file 3 ts
@@ -480,7 +457,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
pure $ FRErr e
receiveChunk spec = do
t <- asks $ fileTimeout . config
liftIO $ fromMaybe (Left TIMEOUT) <$> timeout t (runExceptT $ receiveFile getBody spec)
liftIO $ fromMaybe (Left TIMEOUT) <$> timeout t (runExceptT (receiveFile getBody spec) `catchAll_` pure (Left FILE_IO))
sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do
readTVarIO filePath >>= \case
+1 -2
View File
@@ -69,8 +69,7 @@ data XFTPServerConfig = XFTPServerConfig
logStatsStartTime :: Int64,
serverStatsLogFile :: FilePath,
serverStatsBackupFile :: Maybe FilePath,
transportConfig :: TransportServerConfig,
responseDelay :: Int
transportConfig :: TransportServerConfig
}
defaultInactiveClientExpiration :: ExpirationConfig
+11 -13
View File
@@ -7,13 +7,13 @@
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
@@ -29,7 +29,6 @@ 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)
@@ -70,7 +69,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
T.writeFile iniFile $ iniFileContent host
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
@@ -84,7 +83,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: " <> tshow defFileExpirationHours <> "\n\n")
<> ("expire_files_hours: " <> show defFileExpirationHours <> "\n\n")
<> "log_stats: off\n\
\\n\
\[AUTH]\n\
@@ -103,20 +102,20 @@ xftpServerCLI cfgPath logPath = do
\# control_port_user_password:\n\
\[TRANSPORT]\n\
\# host is only used to print server address on start\n"
<> ("host: " <> T.pack host <> "\n")
<> ("port: " <> T.pack defaultServerPort <> "\n")
<> ("host: " <> host <> "\n")
<> ("port: " <> defaultServerPort <> "\n")
<> "log_tls_errors: off\n\
\# control_port: 5226\n\
\\n\
\[FILES]\n"
<> ("path: " <> T.pack filesPath <> "\n")
<> ("storage_quota: " <> safeDecodeUtf8 (strEncode fileSizeQuota) <> "\n")
<> ("path: " <> filesPath <> "\n")
<> ("storage_quota: " <> B.unpack (strEncode fileSizeQuota) <> "\n")
<> "\n\
\[INACTIVE_CLIENTS]\n\
\# TTL and interval to check inactive clients\n\
\disconnect: off\n"
<> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
<> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
<> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
<> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n")
runServer ini = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
@@ -166,7 +165,7 @@ xftpServerCLI cfgPath logPath = do
defaultFileExpiration
{ ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
},
fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk
fileTimeout = 10 * 60 * 1000000, -- 10 mins to send 4mb chunk
inactiveClientExpiration =
settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
$> ExpirationConfig
@@ -185,8 +184,7 @@ xftpServerCLI cfgPath logPath = do
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
alpn = Just supportedXFTPhandshakes
},
responseDelay = 0
}
}
data CliCommand
+10 -12
View File
@@ -34,7 +34,6 @@ 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
@@ -47,10 +46,8 @@ 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
@@ -59,7 +56,7 @@ import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol (CommandError)
import Simplex.Messaging.Transport (SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
import Simplex.Messaging.Transport.HTTP2.File
import Simplex.Messaging.Util (bshow, tshow)
import Simplex.Messaging.Util (bshow)
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
import System.IO (Handle, IOMode (..), withFile)
@@ -148,14 +145,9 @@ sendEncFile h send = go
go sbState' $ sz - fromIntegral (B.length ch)
receiveFile :: (Int -> IO ByteString) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
receiveFile getBody chunk = ExceptT $ runExceptT (receiveFile_ receive chunk) `E.catches` handlers
receiveFile getBody = receiveFile_ receive
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
@@ -194,7 +186,7 @@ receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChu
receiveFile_ receive XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do
ExceptT $ withFile filePath WriteMode (`receive` chunkSize)
digest' <- liftIO $ LC.sha256Hash <$> LB.readFile filePath
when (digest' /= chunkDigest) $ throwE DIGEST
when (digest' /= chunkDigest) $ throwError DIGEST
data XFTPErrorType
= -- | incorrect block format, encoding or signature size
@@ -221,8 +213,10 @@ data XFTPErrorType
HAS_FILE
| -- | file IO error
FILE_IO
| -- | file sending or receiving timeout
| -- | file sending timeout
TIMEOUT
| -- | bad redirect data
REDIRECT {redirectError :: String}
| -- | internal server error
INTERNAL
| -- | used internally, never returned by the server (to be removed)
@@ -232,9 +226,11 @@ 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
@@ -252,6 +248,7 @@ instance Encoding XFTPErrorType where
HAS_FILE -> "HAS_FILE"
FILE_IO -> "FILE_IO"
TIMEOUT -> "TIMEOUT"
REDIRECT err -> "REDIRECT " <> smpEncode err
INTERNAL -> "INTERNAL"
DUPLICATE_ -> "DUPLICATE_"
@@ -270,6 +267,7 @@ 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"
+3 -44
View File
@@ -2,33 +2,24 @@
{-# 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
import Simplex.Messaging.Protocol (XFTPServer)
import Simplex.Messaging.Parsers (fromTextField_)
import Simplex.Messaging.Protocol
import System.FilePath ((</>))
type RcvFileId = ByteString
type SndFileId = ByteString
authTagSize :: Int64
authTagSize = fromIntegral C.authTagSize
@@ -245,35 +236,3 @@ 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)
File diff suppressed because it is too large Load Diff
+140 -217
View File
@@ -28,11 +28,9 @@ module Simplex.Messaging.Agent.Client
withConnLocks,
withInvLock,
withLockMap,
ipAddressProtected,
closeAgentClient,
closeProtocolServerClients,
reconnectServerClients,
reconnectSMPServer,
closeXFTPServerClient,
runSMPServerTest,
runXFTPServerTest,
@@ -43,7 +41,6 @@ module Simplex.Messaging.Agent.Client
getQueueMessage,
decryptSMPMessage,
addSubscription,
failSubscription,
addNewQueueSubscription,
getSubscriptions,
sendConfirmation,
@@ -57,7 +54,6 @@ module Simplex.Messaging.Agent.Client
disableQueueNotifications,
disableQueuesNtfs,
sendAgentMessage,
getQueueInfo,
agentNtfRegisterToken,
agentNtfVerifyToken,
agentNtfCheckToken,
@@ -112,8 +108,8 @@ module Simplex.Messaging.Agent.Client
waitUntilActive,
UserNetworkInfo (..),
UserNetworkType (..),
getNetworkConfig',
waitForUserNetwork,
waitOnlineOrDelay,
isNetworkOnline,
isOnline,
throwWhenInactive,
@@ -139,8 +135,6 @@ module Simplex.Messaging.Agent.Client
getAgentWorkersDetails,
AgentWorkersSummary (..),
getAgentWorkersSummary,
AgentQueuesInfo (..),
getAgentQueuesInfo,
SMPTransportSession,
NtfTransportSession,
XFTPTransportSession,
@@ -169,6 +163,7 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (partitionEithers)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (deleteFirstsBy, foldl', partition, (\\))
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
@@ -179,7 +174,7 @@ import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Data.Time.Clock.System (getSystemTime)
import Data.Word (Word16)
import qualified Database.SQLite.Simple as SQL
@@ -189,7 +184,6 @@ import qualified Simplex.FileTransfer.Client as X
import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb)
import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse)
import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion)
import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..))
import Simplex.FileTransfer.Util (uniqueCombine)
import Simplex.Messaging.Agent.Env.SQLite
@@ -202,6 +196,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues (getRcvQueues))
import qualified Simplex.Messaging.Agent.TRcvQueues as RQ
import Simplex.Messaging.Client
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
@@ -209,7 +204,7 @@ import Simplex.Messaging.Notifications.Client
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Transport (NTFVersion)
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse, sumTypeJSON)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse)
import Simplex.Messaging.Protocol
( AProtocolType (..),
BrokerMsg,
@@ -241,7 +236,6 @@ import Simplex.Messaging.Protocol
sameSrvAddr',
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.Session
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
@@ -257,7 +251,7 @@ import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, removeFile)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
type ClientVar msg = SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg))
type ClientVar msg = SessionVar (Either AgentErrorType (Client msg))
type SMPClientVar = ClientVar SMP.BrokerMsg
@@ -274,8 +268,9 @@ type XFTPTransportSession = TransportSession FileResponse
data AgentClient = AgentClient
{ acThread :: TVar (Maybe (Weak ThreadId)),
active :: TVar Bool,
subQ :: TBQueue ATransmission,
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
rcvQ :: TBQueue (ATransmission 'Client),
subQ :: TBQueue (ATransmission 'Agent),
msgQ :: TBQueue (ServerTransmission SMPVersion ErrorType BrokerMsg),
smpServers :: TMap UserId (NonEmpty SMPServerWithAuth),
smpClients :: TMap SMPTransportSession SMPClientVar,
-- smpProxiedRelays:
@@ -288,7 +283,7 @@ data AgentClient = AgentClient
xftpClients :: TMap XFTPTransportSession XFTPClientVar,
useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks
userNetworkInfo :: TVar UserNetworkInfo,
userNetworkUpdated :: TVar (Maybe UTCTime),
userNetworkDelay :: TVar Int64,
subscrConns :: TVar (Set ConnId),
activeSubs :: TRcvQueues,
pendingSubs :: TRcvQueues,
@@ -373,7 +368,7 @@ getAgentWorker' toW fromW name hasWork c key ws work = do
notifyErr err = do
let e = either ((", error: " <>) . show) (\_ -> ", no error") e_
msg = "Worker " <> name <> " for " <> show key <> " terminated " <> show (restartCount rc) <> " times" <> e
writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err msg)
writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ err msg)
newWorker :: AgentClient -> STM Worker
newWorker c = do
@@ -449,6 +444,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
qSize = tbqSize cfg
acThread <- newTVar Nothing
active <- newTVar True
rcvQ <- newTBQueue qSize
subQ <- newTBQueue qSize
msgQ <- newTBQueue qSize
smpServers <- newTVar smp
@@ -460,7 +456,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
xftpClients <- TM.empty
useNetworkConfig <- newTVar (slowNetworkConfig netCfg, netCfg)
userNetworkInfo <- newTVar $ UserNetworkInfo UNOther True
userNetworkUpdated <- newTVar Nothing
userNetworkDelay <- newTVar $ initialInterval $ userNetworkInterval cfg
subscrConns <- newTVar S.empty
activeSubs <- RQ.empty
pendingSubs <- RQ.empty
@@ -486,6 +482,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
AgentClient
{ acThread,
active,
rcvQ,
subQ,
msgQ,
smpServers,
@@ -497,7 +494,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
xftpClients,
useNetworkConfig,
userNetworkInfo,
userNetworkUpdated,
userNetworkDelay,
subscrConns,
activeSubs,
pendingSubs,
@@ -584,10 +581,9 @@ instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where
getSMPServerClient :: AgentClient -> SMPTransportSession -> AM SMPConnectedClient
getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess smpClients ts)
>>= either newClient (waitForProtocolClient c tSess smpClients)
unlessM (readTVarIO active) . throwError $ INACTIVE
atomically (getSessVar workerSeq tSess smpClients)
>>= either newClient (waitForProtocolClient c tSess)
where
newClient v = do
prs <- atomically TM.empty
@@ -595,32 +591,30 @@ getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
getSMPProxyClient :: AgentClient -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} destSess@(userId, destSrv, qId) = do
unlessM (readTVarIO active) $ throwE INACTIVE
unlessM (readTVarIO active) . throwError $ INACTIVE
proxySrv <- getNextServer c userId [destSrv]
ts <- liftIO getCurrentTime
atomically (getClientVar proxySrv ts) >>= \(tSess, auth, v) ->
either (newProxyClient tSess auth ts) (waitForProxyClient tSess auth) v
atomically (getClientVar proxySrv) >>= \(tSess, auth, v) ->
either (newProxyClient tSess auth) (waitForProxyClient tSess auth) v
where
getClientVar :: SMPServerWithAuth -> UTCTime -> STM (SMPTransportSession, Maybe SMP.BasicAuth, Either SMPClientVar SMPClientVar)
getClientVar proxySrv ts = do
getClientVar :: SMPServerWithAuth -> STM (SMPTransportSession, Maybe SMP.BasicAuth, Either SMPClientVar SMPClientVar)
getClientVar proxySrv = do
ProtoServerWithAuth srv auth <- TM.lookup destSess smpProxiedRelays >>= maybe (TM.insert destSess proxySrv smpProxiedRelays $> proxySrv) pure
let tSess = (userId, srv, qId)
(tSess,auth,) <$> getSessVar workerSeq tSess smpClients ts
newProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> UTCTime -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
newProxyClient tSess auth ts v = do
(tSess,auth,) <$> getSessVar workerSeq tSess smpClients
newProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
newProxyClient tSess auth v = do
(prs, rv) <- atomically $ do
prs <- TM.empty
-- we do not need to check if it is a new proxied relay session,
-- as the client is just created and there are no sessions yet
(prs,) . either id id <$> getSessVar workerSeq destSrv prs ts
(prs,) . either id id <$> getSessVar workerSeq destSrv prs
clnt <- smpConnectClient c tSess prs v
(clnt,) <$> newProxiedRelay clnt auth rv
waitForProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
waitForProxyClient tSess auth v = do
clnt@(SMPConnectedClient _ prs) <- waitForProtocolClient c tSess smpClients v
ts <- liftIO getCurrentTime
clnt@(SMPConnectedClient _ prs) <- waitForProtocolClient c tSess v
sess <-
atomically (getSessVar workerSeq destSrv prs ts)
atomically (getSessVar workerSeq destSrv prs)
>>= either (newProxiedRelay clnt auth) (waitForProxiedRelay tSess)
pure (clnt, sess)
newProxiedRelay :: SMPConnectedClient -> Maybe SMP.BasicAuth -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay)
@@ -631,7 +625,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
liftIO $ incClientStat c userId clnt "PROXY" "OK"
pure $ Right sess
Left e -> do
liftIO $ incClientStat c userId clnt "PROXY" $ bshow e
liftIO $ incClientStat c userId clnt "PROXY" $ strEncode e
atomically $ do
unless (serverHostError e) $ do
removeSessVar rv destSrv prs
@@ -650,7 +644,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
smpConnectClient :: AgentClient -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
smpConnectClient c@AgentClient {smpClients, msgQ} tSess@(_, srv, _) prs v =
newProtocolClient c tSess smpClients connectClient v
`catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e
`catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwError e
where
connectClient :: SMPClientVar -> AM SMPConnectedClient
connectClient v' = do
@@ -690,29 +684,29 @@ smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess
atomically $ mapM_ (releaseGetLock c) qs
runReaderT (resubscribeSMPSession c tSess) env
notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> IO ()
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
resubscribeSMPSession :: AgentClient -> SMPTransportSession -> AM' ()
resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do
ts <- liftIO getCurrentTime
atomically (getWorkerVar ts) >>= mapM_ (either newSubWorker (\_ -> pure ()))
resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess =
atomically getWorkerVar >>= mapM_ (either newSubWorker (\_ -> pure ()))
where
getWorkerVar ts =
getWorkerVar =
ifM
(null <$> getPending)
(pure Nothing) -- prevent race with cleanup and adding pending queues in another call
(Just <$> getSessVar workerSeq tSess smpSubWorkers ts)
(Just <$> getSessVar workerSeq tSess smpSubWorkers)
newSubWorker v = do
a <- async $ void (E.tryAny runSubWorker) >> atomically (cleanup v)
atomically $ putTMVar (sessionVar v) a
runSubWorker = do
ri <- asks $ reconnectInterval . config
timeoutCounts <- newTVarIO 0
withRetryInterval ri $ \_ loop -> do
pending <- atomically getPending
forM_ (L.nonEmpty pending) $ \qs -> do
liftIO $ waitForUserNetwork c
reconnectSMPClient c tSess qs
lift $ waitForUserNetwork c
void . tryAgentError' $ reconnectSMPClient timeoutCounts c tSess qs
loop
getPending = RQ.getSessQueues tSess $ pendingSubs c
cleanup :: SessionVar (Async ()) -> STM ()
@@ -722,36 +716,50 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do
whenM (isEmptyTMVar $ sessionVar v) retry
removeSessVar v tSess smpSubWorkers
reconnectSMPClient :: AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> AM' ()
reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do
cs <- readTVarIO $ RQ.getConnections $ activeSubs c
(rs, sessId_) <- subscribeQueues c $ L.toList qs
let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs
conns = filter (`M.notMember` cs) okConns
unless (null conns) $ notifySub "" $ UP srv conns
let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs
mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs
forM_ (listToMaybe tempErrs) $ \(connId, e) -> do
when (null okConns && M.null cs && null finalErrs) . liftIO $
forM_ sessId_ $ \sessId -> do
-- We only close the client session that was used to subscribe.
v_ <- atomically $ ifM (activeClientSession c tSess sessId) (TM.lookupDelete tSess $ smpClients c) (pure Nothing)
mapM_ (closeClient_ c) v_
notifySub connId $ ERR e
reconnectSMPClient :: TVar Int -> AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> AM ()
reconnectSMPClient tc c tSess@(_, srv, _) qs = do
NetworkConfig {tcpTimeout} <- atomically $ getNetworkConfig c
-- this allows 3x of timeout per batch of subscription (90 queues per batch empirically)
let t = (length qs `div` 90 + 1) * tcpTimeout * 3
ExceptT (sequence <$> (t `timeout` runExceptT resubscribe)) >>= \case
Just _ -> resetTimeouts
-- reset and do not report consecutive timeouts while offline
Nothing -> ifM (atomically $ isNetworkOnline c) notifyTimeout resetTimeouts
where
handleNotify :: AM' () -> AM' ()
handleNotify = E.handleAny $ notifySub "" . ERR . INTERNAL . show
notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> AM' ()
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
resetTimeouts = atomically $ writeTVar tc 0
notifyTimeout = do
tc' <- atomically $ stateTVar tc $ \i -> (i + 1, i + 1)
maxTC <- asks $ maxSubscriptionTimeouts . config
when (tc' >= maxTC) $ do
let msg = show tc' <> " consecutive subscription timeouts: " <> show (length qs) <> " queues, transport session: " <> show tSess
atomically $ writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL msg)
resubscribe :: AM ()
resubscribe = do
cs <- readTVarIO $ RQ.getConnections $ activeSubs c
(rs, sessId_) <- lift . subscribeQueues c $ L.toList qs
let (errs, okConns) = partitionEithers $ map (\(RcvQueue {connId}, r) -> bimap (connId,) (const connId) r) rs
liftIO $ do
let conns = filter (`M.notMember` cs) okConns
unless (null conns) $ notifySub "" $ UP srv conns
let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs
liftIO $ mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs
forM_ (listToMaybe tempErrs) $ \(_, err) -> do
when (null okConns && M.null cs && null finalErrs) . liftIO $
forM_ sessId_ $ \sessId -> do
-- We only close the client session that was used to subscribe.
v_ <- atomically $ ifM (activeClientSession c tSess sessId) (TM.lookupDelete tSess $ smpClients c) (pure Nothing)
mapM_ (closeClient_ c) v_
throwError err
notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId, srv, _) = do
unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess ntfClients ts)
unlessM (readTVarIO active) . throwError $ INACTIVE
atomically (getSessVar workerSeq tSess ntfClients)
>>= either
(newProtocolClient c tSess ntfClients connectClient)
(waitForProtocolClient c tSess ntfClients)
(waitForProtocolClient c tSess)
where
connectClient :: NtfClientVar -> AM NtfClient
connectClient v = do
@@ -765,17 +773,16 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId,
clientDisconnected v client = do
atomically $ removeSessVar v tSess ntfClients
incClientStat c userId client "DISCONNECT" ""
atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client)
atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId, srv, _) = do
unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess xftpClients ts)
unlessM (readTVarIO active) . throwError $ INACTIVE
atomically (getSessVar workerSeq tSess xftpClients)
>>= either
(newProtocolClient c tSess xftpClients connectClient)
(waitForProtocolClient c tSess xftpClients)
(waitForProtocolClient c tSess)
where
connectClient :: XFTPClientVar -> AM XFTPClient
connectClient v = do
@@ -789,29 +796,17 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId
clientDisconnected v client = do
atomically $ removeSessVar v tSess xftpClients
incClientStat c userId client "DISCONNECT" ""
atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client)
atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
waitForProtocolClient ::
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
AgentClient ->
TransportSession msg ->
TMap (TransportSession msg) (ClientVar msg) ->
ClientVar msg ->
AM (Client msg)
waitForProtocolClient c tSess@(_, srv, _) clients v = do
waitForProtocolClient :: ProtocolTypeI (ProtoType msg) => AgentClient -> TransportSession msg -> ClientVar msg -> AM (Client msg)
waitForProtocolClient c (_, srv, _) v = do
NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c
client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
case client_ of
Just (Right smpClient) -> pure smpClient
Just (Left (e, ts_)) -> case ts_ of
Nothing -> throwE e
Just ts ->
ifM
((ts <) <$> liftIO getCurrentTime)
(atomically (removeSessVar v tSess clients) >> getProtocolServerClient c tSess)
(throwE e)
Nothing -> throwE $ BROKER (B.unpack $ strEncode srv) TIMEOUT
liftEither $ case client_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
-- clientConnected arg is only passed for SMP server
newProtocolClient ::
@@ -829,25 +824,20 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v =
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
atomically $ putTMVar (sessionVar v) (Right client)
liftIO $ incClientStat c userId client "CLIENT" "OK"
atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent CONNECT client)
atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent CONNECT client)
pure client
Left e -> do
liftIO $ incServerStat c userId srv "CLIENT" $ bshow e
ei <- asks $ persistErrorInterval . config
if ei == 0
then atomically $ do
removeSessVar v tSess clients
putTMVar (sessionVar v) (Left (e, Nothing))
else do
ts <- addUTCTime ei <$> liftIO getCurrentTime
atomically $ putTMVar (sessionVar v) (Left (e, Just ts))
throwE e -- signal error to caller
liftIO $ incServerStat c userId srv "CLIENT" $ strEncode e
atomically $ do
removeSessVar v tSess clients
putTMVar (sessionVar v) (Left e)
throwError e -- signal error to caller
hostEvent :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> AEvent 'AENone) -> Client msg -> AEvent 'AENone
hostEvent :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> Client msg -> ACommand 'Agent 'AENone
hostEvent event = hostEvent' event . protocolClient
{-# INLINE hostEvent #-}
hostEvent' :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> AEvent 'AENone) -> ProtoClient msg -> AEvent 'AENone
hostEvent' :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> ProtoClient msg -> ACommand 'Agent 'AENone
hostEvent' event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost
getClientConfig :: AgentClient -> (AgentConfig -> ProtocolClientConfig v) -> AM' (ProtocolClientConfig v)
@@ -865,16 +855,25 @@ getNetworkConfig c = do
UNNone -> slowCfg
_ -> fastCfg
-- returns fast network config
getNetworkConfig' :: AgentClient -> IO NetworkConfig
getNetworkConfig' = fmap snd . readTVarIO . useNetworkConfig
{-# INLINE getNetworkConfig' #-}
waitForUserNetwork :: AgentClient -> IO ()
waitForUserNetwork c =
unlessM (atomically $ isNetworkOnline c) $ do
delay <- registerDelay $ userNetworkInterval $ config $ agentEnv c
atomically $ unlessM (isNetworkOnline c) $ unlessM (readTVar delay) retry
waitForUserNetwork c = pure ()
-- unlessM (atomically $ isNetworkOnline c) $
-- readTVarIO (userNetworkDelay c) >>= void . waitOnlineOrDelay c
waitOnlineOrDelay :: AgentClient -> Int64 -> IO Bool
waitOnlineOrDelay c t = do
let maxWait = min t $ fromIntegral (maxBound :: Int)
t' = t - maxWait
delay <- registerDelay $ fromIntegral maxWait
online <-
atomically $ do
expired <- readTVar delay
online <- isNetworkOnline c
unless (expired || online) retry
pure online
if online || t' <= 0
then pure online
else waitOnlineOrDelay c t'
closeAgentClient :: AgentClient -> IO ()
closeAgentClient c = do
@@ -926,16 +925,6 @@ reconnectServerClients :: ProtocolServerClient v err msg => AgentClient -> (Agen
reconnectServerClients c clientsSel =
readTVarIO (clientsSel c) >>= mapM_ (forkIO . closeClient_ c)
reconnectSMPServer :: AgentClient -> UserId -> SMPServer -> IO ()
reconnectSMPServer c userId srv = do
cs <- readTVarIO $ smpClients c
let vs = M.foldrWithKey srvClient [] cs
mapM_ (forkIO . closeClient_ c) vs
where
srvClient (userId', srv', _) v
| userId == userId' && srv == srv' = (v :)
| otherwise = id
closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO ()
closeClient c clientSel tSess =
atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c)
@@ -969,15 +958,15 @@ withInvLock' :: AgentClient -> ByteString -> String -> AM' a -> AM' a
withInvLock' AgentClient {invLocks} = withLockMap invLocks
{-# INLINE withInvLock' #-}
withConnLocks :: AgentClient -> Set ConnId -> String -> AM' a -> AM' a
withConnLocks AgentClient {connLocks} = withLocksMap_ connLocks
withConnLocks :: AgentClient -> [ConnId] -> String -> AM' a -> AM' a
withConnLocks AgentClient {connLocks} = withLocksMap_ connLocks . filter (not . B.null)
{-# INLINE withConnLocks #-}
withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a
withLockMap = withGetLock . getMapLock
{-# INLINE withLockMap #-}
withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> Set k -> String -> m a -> m a
withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> [k] -> String -> m a -> m a
withLocksMap_ = withGetLocks . getMapLock
{-# INLINE withLocksMap_ #-}
@@ -994,9 +983,9 @@ withClient_ c tSess@(userId, srv, _) statCmd action = do
stat cl = liftIO . incClientStat c userId cl statCmd
logServerError :: Client msg -> AgentErrorType -> AM a
logServerError cl e = do
logServer "<--" c srv "" $ bshow e
stat cl $ bshow e
throwE e
logServer "<--" c srv "" $ strEncode e
stat cl $ strEncode e
throwError e
withProxySession :: AgentClient -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
withProxySession c destSess@(userId, destSrv, _) entId cmdStr action = do
@@ -1013,9 +1002,9 @@ withProxySession c destSess@(userId, destSrv, _) entId cmdStr action = do
proxySrv = showServer . protocolClientServer' . protocolClient
logServerError :: SMPConnectedClient -> AgentErrorType -> AM a
logServerError cl e = do
logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ bshow e
stat cl $ bshow e
throwE e
logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ strEncode e
stat cl $ strEncode e
throwError e
withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> AM a) -> AM a
withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do
@@ -1058,35 +1047,17 @@ sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg = do
SPFAllowProtected -> ipAddressProtected cfg destSrv
SPFProhibit -> False
unknownServer = maybe True (all ((destSrv /=) . protoServer)) <$> TM.lookup userId (userServers c)
sendViaProxy destSess@(_, _, qId) = do
sendViaProxy destSess = do
r <- tryAgentError . withProxySession c destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess) -> do
liftClient SMP (clientServer smp) (proxySMPMessage smp proxySess spKey_ senderId msgFlags msg) >>= \case
Right () -> pure . Just $ protocolClientServer' smp
Left proxyErr -> do
case proxyErr of
(ProxyProtocolError (SMP.PROXY SMP.NO_SESSION)) -> atomically deleteRelaySession
_ -> pure ()
Left proxyErr ->
throwE
PROXY
{ proxyServer = protocolClientServer smp,
relayServer = B.unpack $ strEncode destSrv,
proxyErr
}
where
-- checks that the current proxied relay session is the same one that was used to send the message and removes it
deleteRelaySession =
( TM.lookup destSess (smpProxiedRelays c)
$>>= \(ProtoServerWithAuth srv _) -> tryReadSessVar (userId, srv, qId) (smpClients c)
)
>>= \case
Just (Right (SMPConnectedClient smp' prs))
| sameClient smp' ->
tryReadSessVar destSrv prs >>= \case
Just (Right proxySess') | sameProxiedRelay proxySess' -> TM.delete destSrv prs
_ -> pure ()
_ -> pure ()
sameClient smp' = sessionId (thParams smp) == sessionId (thParams smp')
sameProxiedRelay proxySess' = prSessionId proxySess == prSessionId proxySess'
case r of
Right r' -> pure r'
Left e
@@ -1124,7 +1095,7 @@ protocolClientError :: (Show err, Encoding err) => (HostName -> err -> AgentErro
protocolClientError protocolError_ host = \case
PCEProtocolError e -> protocolError_ host e
PCEResponseError e -> BROKER host $ RESPONSE $ B.unpack $ smpEncode e
PCEUnexpectedResponse e -> BROKER host $ UNEXPECTED $ B.unpack e
PCEUnexpectedResponse r -> BROKER host $ UNEXPECTED $ take 32 $ show r
PCEResponseTimeout -> BROKER host TIMEOUT
PCENetworkError -> BROKER host NETWORK
PCEIncompatibleHost -> BROKER host HOST
@@ -1200,7 +1171,7 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec
liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk g xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
unless (digest == rcvDigest) $ throwE $ ProtocolTestFailure TSCompareFile $ XFTP (B.unpack $ strEncode srv) DIGEST
unless (digest == rcvDigest) $ throwError $ ProtocolTestFailure TSCompareFile $ XFTP (B.unpack $ strEncode srv) DIGEST
liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId
ok <- tcpTimeout xftpNetworkConfig `timeout` X.closeXFTPClient xftp
incClientStat c userId xftp "XFTP_TEST" "OK"
@@ -1314,8 +1285,9 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do
processSubResult :: AgentClient -> RcvQueue -> Either SMPClientError () -> STM ()
processSubResult c rq@RcvQueue {connId} = \case
Left e ->
unless (temporaryClientError e) $
failSubscription c rq e
unless (temporaryClientError e) $ do
RQ.deleteQueue rq (pendingSubs c)
TM.insert (RQ.qKey rq) e (removedSubs c)
Right () ->
whenM (hasPendingSubscription c connId) $
addSubscription c rq
@@ -1324,9 +1296,7 @@ temporaryAgentError :: AgentErrorType -> Bool
temporaryAgentError = \case
BROKER _ e -> tempBrokerError e
SMP _ (SMP.PROXY (SMP.BROKER e)) -> tempBrokerError e
XFTP _ XFTP.TIMEOUT -> True
PROXY _ _ (ProxyProtocolError (SMP.PROXY (SMP.BROKER e))) -> tempBrokerError e
PROXY _ _ (ProxyProtocolError (SMP.PROXY SMP.NO_SESSION)) -> True
INACTIVE -> True
_ -> False
where
@@ -1366,7 +1336,7 @@ subscribeQueues c qs = do
where
checkQueue rq = do
prohibited <- atomically $ hasGetLock c rq
pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq
pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED) else Right rq
subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
subscribeQueues_ env session smp qs' = do
rs <- sendBatch subscribeSMPQueues smp qs'
@@ -1437,11 +1407,6 @@ addSubscription c rq@RcvQueue {connId} = do
RQ.addQueue rq $ activeSubs c
RQ.deleteQueue rq $ pendingSubs c
failSubscription :: AgentClient -> RcvQueue -> SMPClientError -> STM ()
failSubscription c rq e = do
RQ.deleteQueue rq (pendingSubs c)
TM.insert (RQ.qKey rq) e (removedSubs c)
addPendingSubscription :: AgentClient -> RcvQueue -> STM ()
addPendingSubscription c rq@RcvQueue {connId} = do
modifyTVar' (subscrConns c) $ S.insert connId
@@ -1494,7 +1459,7 @@ sendConfirmation c sq@SndQueue {userId, server, sndId, sndPublicKey = Just sndPu
let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation
msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
sendOrProxySMPMessage c userId server "<CONF>" Nothing sndId (MsgFlags {notification = True}) msg
sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
sendInvitation :: AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
sendInvitation c userId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
@@ -1589,11 +1554,6 @@ sendAgentMessage c sq@SndQueue {userId, server, sndId, sndPrivateKey} msgFlags a
msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
sendOrProxySMPMessage c userId server "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
getQueueInfo :: AgentClient -> RcvQueue -> AM QueueInfo
getQueueInfo c rq@RcvQueue {rcvId, rcvPrivateKey} =
withSMPClient c rq "QUE" $ \smp ->
getSMPQueueInfo smp rcvPrivateKey rcvId
agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
withClient c (0, ntfServer, Nothing) "TNEW" $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
@@ -1639,7 +1599,7 @@ agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth ->
agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do
rKeys <- xftpRcvKeys n
(sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random
let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
let fileInfo = FileInfo {sndKey, size = fromIntegral chunkSize, digest = chunkDigest}
logServer "-->" c srv "" "FNEW"
tSess <- liftIO $ mkTransportSession c userId srv chunkDigest
(sndId, rIds) <- withClient c tSess "FNEW" $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
@@ -1665,7 +1625,7 @@ xftpRcvKeys n = do
rKeys <- atomically . replicateM n . C.generateAuthKeyPair C.SEd25519 =<< asks random
case L.nonEmpty rKeys of
Just rKeys' -> pure rKeys'
_ -> throwE $ INTERNAL "non-positive number of recipients"
_ -> throwError $ INTERNAL "non-positive number of recipients"
xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey)
xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
@@ -1702,7 +1662,7 @@ agentCbDecrypt dhSecret nonce msg =
cryptoError :: C.CryptoError -> AgentErrorType
cryptoError = \case
C.CryptoLargeMsgError -> CMD LARGE "CryptoLargeMsgError"
C.CryptoLargeMsgError -> CMD LARGE
C.CryptoHeaderError _ -> AGENT A_MESSAGE -- parsing error
C.CERatchetDuplicateMessage -> AGENT A_DUPLICATE
C.AESDecryptError -> c DECRYPT_AES
@@ -1727,7 +1687,7 @@ withWork c doWork getWork action =
Left e -> notifyErr INTERNAL e
where
noWork = liftIO $ noWorkToDo doWork
notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e)
notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ err $ show e)
noWorkToDo :: TMVar () -> IO ()
noWorkToDo = void . atomically . tryTakeTMVar
@@ -1770,7 +1730,7 @@ suspendOperation c op endedAction = do
notifySuspended :: AgentClient -> STM ()
notifySuspended c = do
-- unsafeIOToSTM $ putStrLn "notifySuspended"
writeTBQueue (subQ c) ("", "", AEvt SAENone SUSPENDED)
writeTBQueue (subQ c) ("", "", APC SAENone SUSPENDED)
writeTVar (agentState c) ASSuspended
endOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
@@ -1845,7 +1805,7 @@ storeError = \case
SEConnDuplicate -> CONN DUPLICATE
SEBadConnType CRcv -> CONN SIMPLEX
SEBadConnType CSnd -> CONN SIMPLEX
SEInvitationNotFound -> CMD PROHIBITED "SEInvitationNotFound"
SEInvitationNotFound -> CMD PROHIBITED
-- this error is never reported as store error,
-- it is used to wrap agent operations when "transaction-like" store access is needed
-- NOTE: network IO should NOT be used inside AgentStoreMonad
@@ -1903,7 +1863,7 @@ withUserServers :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient
withUserServers c userId action =
atomically (TM.lookup userId $ userServers c) >>= \case
Just srvs -> action srvs
_ -> throwE $ INTERNAL "unknown userId - no user servers"
_ -> throwError $ INTERNAL "unknown userId - no user servers"
withNextSrv :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> TVar [ProtocolServer p] -> [ProtocolServer p] -> (ProtoServerWithAuth p -> AM a) -> AM a
withNextSrv c userId usedSrvs initUsed action = do
@@ -2067,39 +2027,6 @@ getAgentWorkersSummary AgentClient {smpClients, ntfClients, xftpClients, smpDeli
(pure WorkersSummary {numActive, numIdle = numIdle + 1, totalRestarts = totalRestarts + restartCount})
(pure WorkersSummary {numActive = numActive + 1, numIdle, totalRestarts = totalRestarts + restartCount})
data AgentQueuesInfo = AgentQueuesInfo
{ msgQInfo :: TBQueueInfo,
subQInfo :: TBQueueInfo,
smpClientsQueues :: Map Text (Int, UTCTime, ClientInfo)
}
deriving (Show)
data ClientInfo
= ClientInfoQueues {sndQInfo :: TBQueueInfo, rcvQInfo :: TBQueueInfo}
| ClientInfoError {clientError :: (AgentErrorType, Maybe UTCTime)}
| ClientInfoConnecting
deriving (Show)
getAgentQueuesInfo :: AgentClient -> IO AgentQueuesInfo
getAgentQueuesInfo AgentClient {msgQ, subQ, smpClients} = do
msgQInfo <- atomically $ getTBQueueInfo msgQ
subQInfo <- atomically $ getTBQueueInfo subQ
smpClientsMap <- readTVarIO smpClients
let smpClientsMap' = M.mapKeys (decodeLatin1 . strEncode) smpClientsMap
smpClientsQueues <- mapM getClientQueuesInfo smpClientsMap'
pure AgentQueuesInfo {msgQInfo, subQInfo, smpClientsQueues}
where
getClientQueuesInfo :: SMPClientVar -> IO (Int, UTCTime, ClientInfo)
getClientQueuesInfo SessionVar {sessionVar, sessionVarId, sessionVarTs} = do
clientInfo <-
atomically (tryReadTMVar sessionVar) >>= \case
Just (Right c) -> do
(sndQInfo, rcvQInfo) <- getProtocolClientQueuesInfo $ protocolClient c
pure ClientInfoQueues {sndQInfo, rcvQInfo}
Just (Left e) -> pure $ ClientInfoError e
Nothing -> pure ClientInfoConnecting
pure (sessionVarId, sessionVarTs, clientInfo)
$(J.deriveJSON defaultJSON ''AgentLocks)
$(J.deriveJSON (enumJSON $ dropPrefix "TS") ''ProtocolTestStep)
@@ -2118,10 +2045,6 @@ $(J.deriveJSON defaultJSON {J.fieldLabelModifier = takeWhile (/= '_')} ''AgentWo
$(J.deriveJSON defaultJSON ''AgentWorkersSummary)
$(J.deriveJSON (sumTypeJSON $ dropPrefix "ClientInfo") ''ClientInfo)
$(J.deriveJSON defaultJSON ''AgentQueuesInfo)
$(J.deriveJSON (enumJSON $ dropPrefix "UN") ''UserNetworkType)
$(J.deriveJSON defaultJSON ''UserNetworkInfo)
+17 -6
View File
@@ -54,6 +54,7 @@ import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
@@ -91,20 +92,20 @@ data AgentConfig = AgentConfig
xftpCfg :: XFTPClientConfig,
reconnectInterval :: RetryInterval,
messageRetryInterval :: RetryInterval2,
userNetworkInterval :: Int,
userOfflineDelay :: NominalDiffTime,
userNetworkInterval :: RetryInterval,
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,
@@ -146,6 +147,14 @@ defaultMessageRetryInterval =
}
}
defaultUserNetworkInterval :: RetryInterval
defaultUserNetworkInterval =
RetryInterval
{ initialInterval = 1200_000000, -- 20 minutes
increaseAfter = 0,
maxInterval = 7200_000000 -- 2 hours
}
defaultAgentConfig :: AgentConfig
defaultAgentConfig =
AgentConfig
@@ -161,20 +170,22 @@ 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
userNetworkInterval = defaultUserNetworkInterval,
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 = 5,
storedMsgDataTTL = 21 * nominalDay,
rcvFilesTTL = 2 * nominalDay,
sndFilesTTL = nominalDay,
xftpNotifyErrsOnRetry = True,
xftpConsecutiveRetries = 3,
xftpMaxRecipientsPerRequest = 200,
deleteErrorCount = 10,
+5 -5
View File
@@ -12,8 +12,6 @@ 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
@@ -41,11 +39,13 @@ withGetLock getLock key name a =
(atomically . takeTMVar)
(const a)
withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> String -> m a -> m a
withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> [k] -> String -> m a -> m a
withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const
where
holdLocks = forConcurrently (S.toList keys) $ \key -> atomically $ getPutLock getLock key name
releaseLocks = mapM_ (atomically . takeTMVar)
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
-- 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.
@@ -29,10 +29,11 @@ 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 (AEvent (..), AEvt (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..))
import Simplex.Messaging.Agent.Protocol (ACommand (..), APartyCmd (..), 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
@@ -306,7 +307,7 @@ workerInternalError c connId internalErrStr = do
-- TODO change error
notifyInternalError :: MonadIO m => AgentClient -> ConnId -> String -> m ()
notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AEvt SAEConn $ ERR $ INTERNAL internalErrStr)
notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, APC SAEConn $ ERR $ INTERNAL internalErrStr)
{-# INLINE notifyInternalError #-}
getNtfToken :: AM' (Maybe NtfToken)
File diff suppressed because it is too large Load Diff
+85
View File
@@ -0,0 +1,85 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Agent.Server
( -- * SMP agent over TCP
runSMPAgent,
runSMPAgentBlocking,
)
where
import Control.Logger.Simple (logInfo)
import Control.Monad
import Control.Monad.Reader
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Text.Encoding (decodeUtf8)
import Network.Socket (ServiceName)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Client (newAgentClient)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), simplexMQVersion)
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, loadTLSServerParams, runTransportServer)
import Simplex.Messaging.Util (bshow)
import UnliftIO.Async (race_)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
-- | Runs an SMP agent as a TCP service using passed configuration.
--
-- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
runSMPAgent :: ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> IO ()
runSMPAgent t cfg initServers store =
runSMPAgentBlocking t cfg initServers store 0 =<< newEmptyTMVarIO
-- | Runs an SMP agent as a TCP service using passed configuration with signalling.
--
-- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
-- and when it is disconnected from the TCP socket once the server thread is killed (False).
runSMPAgentBlocking :: ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> Int -> TMVar Bool -> IO ()
runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers store initClientId started =
case tcpPort of
Just port -> newSMPAgentEnv cfg store >>= smpAgent t port
Nothing -> E.throwIO $ userError "no agent port"
where
smpAgent :: forall c. Transport c => TProxy c -> ServiceName -> Env -> IO ()
smpAgent _ port env = do
-- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile Nothing
clientId <- newTVarIO initClientId
runTransportServer started port tlsServerParams defaultTransportServerConfig $ \(h :: c) -> do
putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
cId <- atomically $ stateTVar clientId $ \i -> (i + 1, i + 1)
c <- atomically $ newAgentClient cId initServers env
logConnection c True
race_ (connectClient h c) (runAgentClient c `runReaderT` env)
`E.finally` (disconnectAgentClient c)
connectClient :: Transport c => c -> AgentClient -> IO ()
connectClient h c = race_ (send h c) (receive h c)
receive :: forall c. Transport c => c -> AgentClient -> IO ()
receive h c@AgentClient {rcvQ, subQ} = forever $ do
(corrId, entId, cmdOrErr) <- tGet SClient h
case cmdOrErr of
Right cmd -> write rcvQ (corrId, entId, cmd)
Left e -> write subQ (corrId, entId, APC SAEConn $ ERR e)
where
write :: TBQueue (ATransmission p) -> ATransmission p -> IO ()
write q t = do
logClient c "-->" t
atomically $ writeTBQueue q t
send :: Transport c => c -> AgentClient -> IO ()
send h c@AgentClient {subQ} = forever $ do
t <- atomically $ readTBQueue subQ
tPut h t
logClient c "<--" t
logClient :: AgentClient -> ByteString -> ATransmission a -> IO ()
logClient AgentClient {clientId} dir (corrId, connId, APC _ cmd) = do
logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, connId, B.takeWhile (/= ' ') $ serializeCommand cmd]
+6 -5
View File
@@ -47,6 +47,7 @@ import Simplex.Messaging.Protocol
VersionSMPC,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Util ((<$?>))
-- * Queue types
@@ -343,20 +344,20 @@ instance StrEncoding AgentCmdType where
_ -> fail "bad AgentCmdType"
data AgentCommand
= AClientCommand ACommand
= AClientCommand (APartyCmd 'Client)
| AInternalCommand InternalCommand
instance StrEncoding AgentCommand where
strEncode = \case
AClientCommand cmd -> strEncode (ACClient, Str $ serializeCommand cmd)
AClientCommand (APC _ cmd) -> strEncode (ACClient, Str $ serializeCommand cmd)
AInternalCommand cmd -> strEncode (ACInternal, cmd)
strP =
strP_ >>= \case
ACClient -> AClientCommand <$> dbCommandP
ACClient -> AClientCommand <$> ((\(ACmd _ e cmd) -> checkParty $ APC e cmd) <$?> dbCommandP)
ACInternal -> AInternalCommand <$> strP
data AgentCommandTag
= AClientCommandTag ACommandTag
= AClientCommandTag (APartyCmdTag 'Client)
| AInternalCommandTag InternalCommandTag
deriving (Show)
@@ -435,7 +436,7 @@ instance StrEncoding InternalCommandTag where
agentCommandTag :: AgentCommand -> AgentCommandTag
agentCommandTag = \case
AClientCommand cmd -> AClientCommandTag $ aCommandTag cmd
AClientCommand cmd -> AClientCommandTag $ aPartyCmdTag cmd
AInternalCommand cmd -> AInternalCommandTag $ internalCmdTag cmd
internalCmdTag :: InternalCommand -> InternalCommandTag
+30 -34
View File
@@ -225,7 +225,6 @@ 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
@@ -1046,7 +1045,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 >> throwE e
tryGetItem itemId = ExceptT (getItem itemId) `catchStoreErrors` \e -> mark itemId >> throwError 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,
@@ -2276,20 +2275,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 -> 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
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
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 -> 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
createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> IO (Either StoreError RcvFileId)
createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect"
createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile = runExceptT $ do
(dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing
(_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId)
liftIO $
forM_ redirectChunks $ \fc@FileChunk {replicas} -> do
chunkId <- insertRcvFileChunk db fc redirectId
@@ -2309,8 +2308,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 -> 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
insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> IO (Either StoreError (RcvFileId, DBRcvFileId))
insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ = runExceptT $ do
let (redirectDigest_, redirectSize_) = case redirect of
Just RedirectFileInfo {digest = d, size = s} -> (Just d, Just s)
Nothing -> (Nothing, Nothing)
@@ -2318,8 +2317,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, approved_relays) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_, approvedRelays))
"INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_))
rcvFileId <- liftIO $ insertedRowId db
pure (rcvFileEntityId, rcvFileId)
@@ -2469,7 +2468,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, Bool)))
getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFileChunk))
getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do
getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd)
where
@@ -2493,7 +2492,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
LIMIT 1
|]
(host, port, keyHash, RFSReceiving, cutoffTs)
getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool))
getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError RcvFileChunk)
getChunkData (rcvFileChunkReplicaId, _fileId) =
firstRow toChunk SEFileNotFound $
DB.query
@@ -2501,8 +2500,7 @@ 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,
f.approved_relays
r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries
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
@@ -2511,22 +2509,20 @@ 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) :. 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
)
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}]
}
getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile))
getNextRcvFileToDecrypt db ttl =
@@ -71,7 +71,6 @@ 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)
@@ -111,8 +110,7 @@ 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),
("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays)
("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem)
]
-- | The list of migrations in ascending order by date
@@ -1,18 +0,0 @@
{-# 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;
|]
@@ -287,7 +287,6 @@ 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(
+52 -134
View File
@@ -59,14 +59,12 @@ module Simplex.Messaging.Client
connectSMPProxiedRelay,
proxySMPMessage,
forwardSMPMessage,
getSMPQueueInfo,
sendProtocolCommand,
-- * Supporting types and client configuration
ProtocolClientError (..),
SMPClientError,
ProxyClientError (..),
unexpectedResponse,
ProtocolClientConfig (..),
NetworkConfig (..),
TransportSessionMode (..),
@@ -82,8 +80,8 @@ module Simplex.Messaging.Client
proxyUsername,
temporaryClientError,
smpProxyError,
ServerTransmissionBatch,
ServerTransmission (..),
ServerTransmission,
TransmissionType (..),
ClientCommand,
-- * For testing
@@ -91,11 +89,6 @@ module Simplex.Messaging.Client
mkTransmission,
authTransmission,
smpClientStub,
-- * For debugging
TBQueueInfo (..),
getTBQueueInfo,
getProtocolClientQueuesInfo,
)
where
@@ -118,7 +111,7 @@ import Data.Int (Int64)
import Data.List (find)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (catMaybes, fromMaybe)
import Data.Maybe (fromMaybe)
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
@@ -129,7 +122,6 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
@@ -161,9 +153,9 @@ data PClient v err msg = PClient
timeoutErrorCount :: TVar Int,
clientCorrId :: TVar ChaChaDRG,
sentCommands :: TMap CorrId (Request err msg),
sndQ :: TBQueue (Maybe (TVar Bool), ByteString),
sndQ :: TBQueue ByteString,
rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg))
msgQ :: Maybe (TBQueue (ServerTransmission v err msg))
}
smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> STM SMPClient
@@ -214,14 +206,10 @@ type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg
-- | Type for client command data
type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg)
-- | Type synonym for transmission from SPM servers.
-- Batch response is presented as a single `ServerTransmissionBatch` tuple.
type ServerTransmissionBatch v err msg = (TransportSession msg, Version v, SessionId, NonEmpty (EntityId, ServerTransmission err msg))
-- | Type synonym for transmission from some SPM server queue.
type ServerTransmission v err msg = (TransportSession msg, Version v, SessionId, TransmissionType msg, EntityId, Either (ProtocolClientError err) msg)
data ServerTransmission err msg
= STEvent (Either (ProtocolClientError err) msg)
| STResponse (ProtoCommand msg) (Either (ProtocolClientError err) msg)
| STUnexpectedError (ProtocolClientError err)
data TransmissionType msg = TTEvent | TTUncorrelatedResponse | TTExpiredResponse (ProtoCommand msg)
data HostMode
= -- | prefer (or require) onion hosts when connecting via SOCKS proxy
@@ -291,32 +279,6 @@ data SMPProxyFallback
| SPFProhibit -- prohibit direct connection to destination relay.
deriving (Eq, Show)
instance StrEncoding SMPProxyMode where
strEncode = \case
SPMAlways -> "always"
SPMUnknown -> "unknown"
SPMUnprotected -> "unprotected"
SPMNever -> "never"
strP =
A.takeTill (== ' ') >>= \case
"always" -> pure SPMAlways
"unknown" -> pure SPMUnknown
"unprotected" -> pure SPMUnprotected
"never" -> pure SPMNever
_ -> fail "Invalid SMP proxy mode"
instance StrEncoding SMPProxyFallback where
strEncode = \case
SPFAllow -> "yes"
SPFAllowProtected -> "protected"
SPFProhibit -> "no"
strP =
A.takeTill (== ' ') >>= \case
"yes" -> pure SPFAllow
"protected" -> pure SPFAllowProtected
"no" -> pure SPFProhibit
_ -> fail "Invalid SMP proxy fallback mode"
defaultNetworkConfig :: NetworkConfig
defaultNetworkConfig =
NetworkConfig
@@ -434,7 +396,7 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
--
-- A single queue can be used for multiple 'SMPClient' instances,
-- as 'SMPServerTransmission' includes server information.
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmission v err msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do
case chooseTransportHost networkConfig (host srv) of
Right useHost ->
@@ -507,11 +469,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
`finally` disconnected c'
send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= sendPending
where
sendPending (Nothing, s) = send_ s
sendPending (Just pending, s) = whenM (readTVarIO pending) $ send_ s
send_ = void . tPutLog h
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= void . tPutLog h
receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do
@@ -540,48 +498,38 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
maxCnt = smpPingCount networkConfig
process :: ProtocolClient v err msg -> IO ()
process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= processMsgs c
process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c)
processMsgs :: ProtocolClient v err msg -> NonEmpty (SignedTransmission err msg) -> IO ()
processMsgs c ts = do
ts' <- catMaybes <$> mapM (processMsg c) (L.toList ts)
forM_ msgQ $ \q ->
mapM_ (atomically . writeTBQueue q . serverTransmission c) (L.nonEmpty ts')
processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg))
processMsg ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr))
| B.null $ bs corrId = sendMsg $ STEvent clientResp
| otherwise =
processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO ()
processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr))
| not $ B.null $ bs corrId =
atomically (TM.lookup corrId sentCommands) >>= \case
Nothing -> sendMsg $ STUnexpectedError unexpected
Nothing -> sendMsg TTUncorrelatedResponse
Just Request {entityId, command, pending, responseVar} -> do
wasPending <-
atomically $ do
TM.delete corrId sentCommands
ifM
(swapTVar pending False)
(True <$ tryPutTMVar responseVar (if entityId == entId then clientResp else Left unexpected))
(True <$ tryPutTMVar responseVar (response entityId))
(pure False)
if wasPending
then pure Nothing
else sendMsg $ if entityId == entId then STResponse command clientResp else STUnexpectedError unexpected
unless wasPending $ sendMsg $ if entityId == entId then TTExpiredResponse command else TTUncorrelatedResponse
| otherwise = sendMsg TTEvent
where
unexpected = unexpectedResponse respOrErr
response entityId
| entityId == entId = clientResp
| otherwise = Left . PCEUnexpectedResponse $ bshow respOrErr
clientResp = case respOrErr of
Left e -> Left $ PCEResponseError e
Right r -> case protocolError r of
Just e -> Left $ PCEProtocolError e
_ -> Right r
sendMsg :: ServerTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg))
sendMsg t = case msgQ of
Just _ -> pure $ Just (entId, t)
Nothing ->
Nothing <$ case clientResp of
Left e -> logError $ "SMP client error: " <> tshow e
Right _ -> logWarn "SMP client unprocessed event"
unexpectedResponse :: Show r => r -> ProtocolClientError err
unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show
sendMsg :: TransmissionType msg -> IO ()
sendMsg tType = case msgQ of
Just q -> atomically $ writeTBQueue q $ serverTransmission c tType entId clientResp
Nothing -> case clientResp of
Left e -> logError $ "SMP client error: " <> tshow e
Right _ -> logWarn $ "SMP client unprocessed event"
proxyUsername :: TransportSession msg -> ByteString
proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_
@@ -637,7 +585,7 @@ smpProxyError :: SMPClientError -> ErrorType
smpProxyError = \case
PCEProtocolError e -> PROXY $ PROTOCOL e
PCEResponseError e -> PROXY $ BROKER $ RESPONSE $ B.unpack $ strEncode e
PCEUnexpectedResponse e -> PROXY $ BROKER $ UNEXPECTED $ B.unpack e
PCEUnexpectedResponse s -> PROXY $ BROKER $ UNEXPECTED $ B.unpack $ B.take 32 s
PCEResponseTimeout -> PROXY $ BROKER TIMEOUT
PCENetworkError -> PROXY $ BROKER NETWORK
PCEIncompatibleHost -> PROXY $ BROKER HOST
@@ -658,7 +606,7 @@ createSMPQueue ::
createSMPQueue c (rKey, rpKey) dhKey auth subMode =
sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode) >>= \case
IDS qik -> pure qik
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Subscribe to the SMP queue.
--
@@ -669,7 +617,7 @@ subscribeSMPQueue c@ProtocolClient {client_ = PClient {sendPings}} rpKey rId = d
sendSMPCommand c (Just rpKey) rId SUB >>= \case
OK -> pure ()
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Subscribe to multiple SMP queues batching commands if supported.
subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
@@ -689,15 +637,15 @@ processSUBResponse :: SMPClient -> Response ErrorType BrokerMsg -> IO (Either SM
processSUBResponse c (Response rId r) = case r of
Right OK -> pure $ Right ()
Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
Right r' -> pure . Left $ unexpectedResponse r'
Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r'
Left e -> pure $ Left e
writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c [(rId, STEvent (Right msg))]) (msgQ $ client_ c)
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c TTEvent rId (Right msg)) (msgQ $ client_ c)
serverTransmission :: ProtocolClient v err msg -> NonEmpty (RecipientId, ServerTransmission err msg) -> ServerTransmissionBatch v err msg
serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} ts =
(transportSession, thVersion, sessionId, ts)
serverTransmission :: ProtocolClient v err msg -> TransmissionType msg -> RecipientId -> Either (ProtocolClientError err) msg -> ServerTransmission v err msg
serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} tType entityId msgOrErr =
(transportSession, thVersion, sessionId, tType, entityId, msgOrErr)
-- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
--
@@ -707,7 +655,7 @@ getSMPMessage c rpKey rId =
sendSMPCommand c (Just rpKey) rId GET >>= \case
OK -> pure Nothing
cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Subscribe to the SMP queue notifications.
--
@@ -735,7 +683,7 @@ enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId ->
enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Enable notifications for the multiple queues for push notifications server.
enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
@@ -744,7 +692,7 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
process (Response _ r) = case r of
Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
Right r' -> Left $ unexpectedResponse r'
Right r' -> Left . PCEUnexpectedResponse $ bshow r'
Left e -> Left e
-- | Disable notifications for the queue for push notifications server.
@@ -766,7 +714,7 @@ sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -
sendSMPMessage c spKey sId flags msg =
sendSMPCommand c spKey sId (SEND flags msg) >>= \case
OK -> pure ()
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Acknowledge message delivery (server deletes the message).
--
@@ -776,7 +724,7 @@ ackSMPMessage c rpKey rId msgId =
sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
OK -> return ()
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Irreversibly suspend SMP queue.
-- The existing messages from the queue will still be delivered.
@@ -808,7 +756,7 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t
case supportedClientSMPRelayVRange `compatibleVersion` vr of
Nothing -> throwE $ transportErr TEVersion
Just (Compatible v) -> liftEitherWith (const $ transportErr $ TEHandshake IDENTITY) $ ProxiedRelay sId v <$> validateRelay chain key
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
| otherwise = throwE $ PCETransportError TEVersion
where
tOut = Just $ tcpConnectTimeout + tcpTimeout
@@ -914,14 +862,14 @@ proxySMPMessage c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
(_auth, _signed, (_c, _e, cmd)) -> case cmd of
Right OK -> pure $ Right ()
Right (ERR e) -> throwE $ PCEProtocolError e -- this is the error from the destination relay
Right r' -> throwE $ unexpectedResponse r'
Right e -> throwE $ PCEUnexpectedResponse $ B.take 32 $ bshow e
Left e -> throwE $ PCEResponseError e
_ -> throwE $ PCETransportError TEBadBlock
ERR e -> pure . Left $ ProxyProtocolError e -- this will not happen, this error is returned via Left
_ -> pure . Left $ ProxyUnexpectedResponse $ take 32 $ show r
Left e -> case e of
PCEProtocolError e' -> pure . Left $ ProxyProtocolError e'
PCEUnexpectedResponse e' -> pure . Left $ ProxyUnexpectedResponse $ B.unpack e'
PCEUnexpectedResponse r -> pure . Left $ ProxyUnexpectedResponse $ B.unpack r
PCEResponseError e' -> pure . Left $ ProxyResponseError e'
_ -> throwE e
@@ -933,8 +881,8 @@ forwardSMPMessage :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> E
forwardSMPMessage c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do
-- prepare params
sessSecret <- case thAuth thParams of
Nothing -> throwE $ PCETransportError TENoServerAuth
Just THAuthClient {sessSecret} -> maybe (throwE $ PCETransportError TENoServerAuth) pure sessSecret
Nothing -> throwError $ PCETransportError TENoServerAuth
Just THAuthClient {sessSecret} -> maybe (throwError $ PCETransportError TENoServerAuth) pure sessSecret
nonce <- liftIO . atomically $ C.randomCbNonce g
-- wrap
let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission}
@@ -946,19 +894,13 @@ forwardSMPMessage c@ProtocolClient {thParams, client_ = PClient {clientCorrId =
r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
FwdResponse {fwdCorrId = _, fwdResponse} <- liftEitherWith (const $ PCEResponseError BLOCK) $ smpDecode r'
pure fwdResponse
r -> throwE $ unexpectedResponse r
getSMPQueueInfo :: SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
getSMPQueueInfo c pKey qId =
sendSMPCommand c (Just pKey) qId QUE >>= \case
INFO info -> pure info
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ B.take 32 $ bshow r
okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
okSMPCommand cmd c pKey qId =
sendSMPCommand c (Just pKey) qId cmd >>= \case
OK -> return ()
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateAuthKey, QueueId) -> IO (NonEmpty (Either SMPClientError ()))
okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
@@ -967,7 +909,7 @@ okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
cs = L.map (\(pKey, qId) -> (Just pKey, qId, aCmd)) qs
process (Response _ r) = case r of
Right OK -> Right ()
Right r' -> Left $ unexpectedResponse r'
Right r' -> Left . PCEUnexpectedResponse $ bshow r'
Left e -> Left e
-- | Send SMP command
@@ -1008,33 +950,29 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
pure [Response entityId $ Left $ PCETransportError e]
TBTransmissions s n rs
| n > 0 -> do
atomically $ writeTBQueue sndQ (Nothing, s) -- do not expire batched responses
atomically $ writeTBQueue sndQ s
mapConcurrently (getResponse c Nothing) rs
| otherwise -> pure []
TBTransmission s r -> do
atomically $ writeTBQueue sndQ (Nothing, s)
atomically $ writeTBQueue sndQ s
(: []) <$> getResponse c Nothing r
-- | Send Protocol command
sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
-- Currently there is coupling - batch commands do not expire, and individually sent commands do.
-- This is to reflect the fact that we send subscriptions only as batches, and also because we do not track a separate timeout for the whole batch, so it is not obvious when should we expire it.
-- We could expire a batch of deletes, for example, either when the first response expires or when the last one does.
-- But a better solution is to process delayed delete responses.
sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} nonce_ tOut pKey entId cmd =
ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (pKey, entId, cmd)
where
-- two separate "atomically" needed to avoid blocking
sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg)
sendRecv t_ r@Request {pending} = case t_ of
sendRecv t_ r = case t_ of
Left e -> pure . Left $ PCETransportError e
Right t
| B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg
| otherwise -> do
atomically $ writeTBQueue sndQ (Just pending, s)
atomically $ writeTBQueue sndQ s
response <$> getResponse c tOut r
where
s
@@ -1093,24 +1031,6 @@ authTransmission thAuth pKey_ nonce t = traverse authenticate pKey_
sign :: forall a. (C.AlgorithmI a, C.SignatureAlgorithm a) => C.PrivateKey a -> Either TransportError TransmissionAuth
sign pk = Right $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t)
data TBQueueInfo = TBQueueInfo
{ qLength :: Int,
qFull :: Bool
}
deriving (Show)
getTBQueueInfo :: TBQueue a -> STM TBQueueInfo
getTBQueueInfo q = do
qLength <- fromIntegral <$> lengthTBQueue q
qFull <- isFullTBQueue q
pure TBQueueInfo {qLength, qFull}
getProtocolClientQueuesInfo :: ProtocolClient v err msg -> IO (TBQueueInfo, TBQueueInfo)
getProtocolClientQueuesInfo ProtocolClient {client_ = PClient {sndQ, rcvQ}} = do
sndQInfo <- atomically $ getTBQueueInfo sndQ
rcvQInfo <- atomically $ getTBQueueInfo rcvQ
pure (sndQInfo, rcvQInfo)
$(J.deriveJSON (enumJSON $ dropPrefix "HM") ''HostMode)
$(J.deriveJSON (enumJSON $ dropPrefix "SM") ''SocksMode)
@@ -1124,5 +1044,3 @@ $(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback)
$(J.deriveJSON defaultJSON ''NetworkConfig)
$(J.deriveJSON (enumJSON $ dropPrefix "Proxy") ''ProxyClientError)
$(J.deriveJSON defaultJSON ''TBQueueInfo)
+56 -61
View File
@@ -9,6 +9,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Simplex.Messaging.Client.Agent where
@@ -20,6 +21,7 @@ import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (bimap, first)
import Data.ByteString.Char8 (ByteString)
@@ -45,13 +47,14 @@ 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_, ifM, toChunks, whenM, ($>>=), (<$$>))
import Simplex.Messaging.Util (catchAll_, ifM, toChunks, whenM, ($>>=))
import System.Timeout (timeout)
import UnliftIO (async)
import UnliftIO.Exception (Exception)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
type SMPClientVar = SessionVar (Either (SMPClientError, Maybe UTCTime) (OwnServer, SMPClient))
type SMPClientVar = SessionVar (Either (SMPClientError, Maybe UTCTime) SMPClient)
data SMPClientAgentEvent
= CAConnected SMPServer
@@ -72,8 +75,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
persistErrorInterval :: NominalDiffTime,
msgQSize :: Natural,
agentQSize :: Natural,
agentSubsBatchSize :: Int,
ownServerDomains :: [ByteString]
agentSubsBatchSize :: Int
}
defaultSMPClientAgentConfig :: SMPClientAgentConfig
@@ -86,11 +88,10 @@ defaultSMPClientAgentConfig =
increaseAfter = 10 * second,
maxInterval = 10 * second
},
persistErrorInterval = 30, -- seconds
persistErrorInterval = 0,
msgQSize = 256,
agentQSize = 256,
agentSubsBatchSize = 900,
ownServerDomains = []
agentSubsBatchSize = 900
}
where
second = 1000000
@@ -98,18 +99,41 @@ defaultSMPClientAgentConfig =
data SMPClientAgent = SMPClientAgent
{ agentCfg :: SMPClientAgentConfig,
active :: TVar Bool,
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
msgQ :: TBQueue (ServerTransmission SMPVersion ErrorType BrokerMsg),
agentQ :: TBQueue SMPClientAgentEvent,
randomDrg :: TVar ChaChaDRG,
smpClients :: TMap SMPServer SMPClientVar,
smpSessions :: TMap SessionId (OwnServer, SMPClient),
smpSessions :: TMap SessionId SMPClient,
srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
smpSubWorkers :: TMap SMPServer (SessionVar (Async ())),
workerSeq :: TVar Int
}
type OwnServer = Bool
newtype InternalException e = InternalException {unInternalException :: e}
deriving (Eq, Show)
instance Exception e => Exception (InternalException e)
instance Exception e => MonadUnliftIO (ExceptT e IO) where
{-# INLINE withRunInIO #-}
withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b
withRunInIO inner =
ExceptT . fmap (first unInternalException) . E.try $
withRunInIO $ \run ->
inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT)
-- as MonadUnliftIO instance for IO is `withRunInIO inner = inner id`,
-- the last two lines could be replaced with:
-- inner $ either (E.throwIO . InternalException) pure <=< runExceptT
instance Exception e => MonadUnliftIO (ExceptT e (ReaderT r IO)) where
{-# INLINE withRunInIO #-}
withRunInIO :: ((forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b) -> ExceptT e (ReaderT r IO) b
withRunInIO inner =
withExceptT unInternalException . ExceptT . E.try $
withRunInIO $ \run ->
inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT)
newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> STM SMPClientAgent
newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
@@ -139,60 +163,46 @@ newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg
-- | Get or create SMP client for SMPServer
getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient
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
getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, workerSeq} srv =
atomically getClientVar >>= either (ExceptT . newSMPClient) waitForSMPClient
where
getClientVar :: UTCTime -> STM (Either SMPClientVar SMPClientVar)
getClientVar :: STM (Either SMPClientVar SMPClientVar)
getClientVar = getSessVar workerSeq srv smpClients
waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO (OwnServer, SMPClient)
waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO SMPClient
waitForSMPClient v = do
let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
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)
Just (Left (e, Nothing)) -> throwE e
Just (Left (e, Just ts)) ->
ifM
((ts <) <$> liftIO getCurrentTime)
(atomically (removeSessVar v srv smpClients) >> getSMPServerClient' ca srv)
(throwE e)
Nothing -> throwE PCEResponseTimeout
newSMPClient :: SMPClientVar -> IO (Either SMPClientError (OwnServer, SMPClient))
newSMPClient :: SMPClientVar -> IO (Either SMPClientError 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
putTMVar (sessionVar v) (Right smp)
TM.insert (sessionId $ thParams smp) smp smpSessions
notify ca $ CAConnected srv
pure $ Right c
Left e -> do
let ei = persistErrorInterval agentCfg
if ei == 0
if persistErrorInterval agentCfg == 0 || e == PCENetworkError || e == PCEResponseTimeout
then atomically $ do
putTMVar (sessionVar v) (Left (e, Nothing))
removeSessVar v srv smpClients
else do
ts <- addUTCTime ei <$> liftIO getCurrentTime
ts <- addUTCTime (persistErrorInterval agentCfg) <$> liftIO getCurrentTime
atomically $ putTMVar (sessionVar v) (Left (e, Just ts))
reconnectClient ca srv
pure $ Left e
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)
pure r
-- | Run an SMP client for SMPClientVar
connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
@@ -228,15 +238,14 @@ connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, random
-- | 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 ()))
reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} srv =
whenM (readTVarIO active) $ atomically getWorkerVar >>= mapM_ (either newSubWorker (\_ -> pure ()))
where
getWorkerVar ts =
getWorkerVar =
ifM
(null <$> getPending)
(pure Nothing) -- prevent race with cleanup and adding pending queues in another call
(Just <$> getSessVar workerSeq srv smpSubWorkers ts)
(Just <$> getSessVar workerSeq srv smpSubWorkers)
newSubWorker :: SessionVar (Async ()) -> IO ()
newSubWorker v = do
a <- async $ void (E.tryAny runSubWorker) >> atomically (cleanup v)
@@ -289,21 +298,7 @@ notify :: MonadIO m => SMPClientAgent -> SMPClientAgentEvent -> m ()
notify ca evt = atomically $ writeTBQueue (agentQ ca) evt
{-# INLINE notify #-}
-- Returns already connected client for proxying messages or Nothing if client is absent, not connected yet or stores expired error.
-- If Nothing is return proxy will spawn a new thread to wait or to create another client connection to destination relay.
getConnectedSMPServerClient :: SMPClientAgent -> SMPServer -> IO (Maybe (Either SMPClientError (OwnServer, SMPClient)))
getConnectedSMPServerClient SMPClientAgent {smpClients} srv =
atomically (TM.lookup srv smpClients $>>= \v -> (v,) <$$> tryReadTMVar (sessionVar v)) -- Nothing: client is absent or not connected yet
$>>= \case
(_, Right r) -> pure $ Just $ Right r
(v, Left (e, ts_)) ->
pure ts_ $>>= \ts -> -- proxy will create a new connection if ts_ is Nothing
ifM
((ts <) <$> liftIO getCurrentTime) -- error persistence interval period expired?
(Nothing <$ atomically (removeSessVar v srv smpClients)) -- proxy will create a new connection
(pure $ Just $ Left e) -- not expired, returning error
lookupSMPServerClient :: SMPClientAgent -> SessionId -> STM (Maybe (OwnServer, SMPClient))
lookupSMPServerClient :: SMPClientAgent -> SessionId -> STM (Maybe SMPClient)
lookupSMPServerClient SMPClientAgent {smpSessions} sessId = TM.lookup sessId smpSessions
closeSMPClientAgent :: SMPClientAgent -> IO ()
@@ -320,7 +315,7 @@ closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_
where
closeClient v =
atomically (readTMVar $ sessionVar v) >>= \case
Right (_, smp) -> closeProtocolClient smp `catchAll_` pure ()
Right smp -> closeProtocolClient smp `catchAll_` pure ()
_ -> pure ()
cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
+4 -4
View File
@@ -23,7 +23,6 @@ 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
@@ -32,6 +31,7 @@ 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) $ throwE FTCEInvalidFileSize
when (len < 0) $ throwError 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) $ throwE FTCEInvalidAuthTag
unless (BA.constEq (LB.toStrict tag') tag) $ throwError FTCEInvalidAuthTag
pure $ LB.fromChunks cs
Nothing -> pure s
@@ -97,7 +97,7 @@ hGetTag :: CryptoFileHandle -> ExceptT FTCryptoError IO ()
hGetTag (CFHandle h sb_) = forM_ sb_ $ \sb -> do
tag <- liftIO $ B.hGet h C.authTagSize
tag' <- LC.sbAuth <$> readTVarIO sb
unless (BA.constEq tag tag') $ throwE FTCEInvalidAuthTag
unless (BA.constEq tag tag') $ throwError FTCEInvalidAuthTag
data FTCryptoError
= FTCECryptoError C.CryptoError
+3 -3
View File
@@ -166,9 +166,9 @@ instance TestEquality SRatchetKEMState where
class RatchetKEMStateI (s :: RatchetKEMState) where sRatchetKEMState :: SRatchetKEMState s
instance RatchetKEMStateI 'RKSProposed where sRatchetKEMState = SRKSProposed
instance RatchetKEMStateI RKSProposed where sRatchetKEMState = SRKSProposed
instance RatchetKEMStateI 'RKSAccepted where sRatchetKEMState = SRKSAccepted
instance RatchetKEMStateI RKSAccepted where sRatchetKEMState = SRKSAccepted
checkRatchetKEMState :: forall t s s' a. (RatchetKEMStateI s, RatchetKEMStateI s') => t s' a -> Either String (t s a)
checkRatchetKEMState x = case testEquality (sRatchetKEMState @s) (sRatchetKEMState @s') of
@@ -447,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 -> throwE CERatchetKEMState
Nothing -> throwError 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
@@ -12,6 +12,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes)
import Simplex.Messaging.Protocol (ErrorType)
import Simplex.Messaging.Util (bshow)
type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse
@@ -24,7 +25,7 @@ ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> Exc
ntfRegisterToken c pKey newTkn =
sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
NRTknId tknId dhKey -> pure (tknId, dhKey)
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
@@ -33,7 +34,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 $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
@@ -48,13 +49,13 @@ ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscri
ntfCreateSubscription c pKey newSub =
sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
NRSubId subId -> pure subId
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow 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 $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
ntfDeleteSubscription = okNtfCommand SDEL
@@ -67,4 +68,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 $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
+19 -22
View File
@@ -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, ServerTransmission (..))
import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError)
import Simplex.Messaging.Client.Agent
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
@@ -220,27 +220,23 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
receiveSMP :: M ()
receiveSMP = forever $ do
((_, 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
((_, srv, _), _, _, _tType, ntfId, msgOrErr) <- atomically $ readTBQueue msgQ
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 $
@@ -252,6 +248,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
forM_ subs $ \(_, ntfId) -> do
let smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSInactive
CAResubscribed srv subs -> do
forM_ subs $ \(_, ntfId) -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive
logSubStatus srv "resubscribed" $ length subs
@@ -11,10 +11,9 @@ import Data.Functor (($>))
import Data.Ini (lookupValue, readIniFile)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Network.Socket (HostName)
import Options.Applicative
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Server (runNtfServer)
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
@@ -26,7 +25,6 @@ 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)
@@ -67,7 +65,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
T.writeFile iniFile $ iniFileContent host
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
@@ -83,15 +81,15 @@ ntfServerCLI cfgPath logPath =
<> "log_stats: off\n\n\
\[TRANSPORT]\n\
\# host is only used to print server address on start\n"
<> ("host: " <> T.pack host <> "\n")
<> ("port: " <> T.pack defaultServerPort <> "\n")
<> ("host: " <> host <> "\n")
<> ("port: " <> 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: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
<> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
<> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
<> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n")
runServer ini = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
@@ -115,7 +113,7 @@ ntfServerCLI cfgPath logPath =
clientQSize = 64,
subQSize = 512,
pushQSize = 1048,
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig = defaultAPNSPushClientConfig,
subsBatchSize = 900,
inactiveClientExpiration =
@@ -15,7 +15,6 @@ 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
@@ -354,18 +353,18 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
| status == Just N.ok200 = pure ()
| status == Just N.badRequest400 =
case reason' of
"BadDeviceToken" -> throwE PPTokenInvalid
"DeviceTokenNotForTopic" -> throwE PPTokenInvalid
"TopicDisallowed" -> throwE PPPermanentError
"BadDeviceToken" -> throwError PPTokenInvalid
"DeviceTokenNotForTopic" -> throwError PPTokenInvalid
"TopicDisallowed" -> throwError PPPermanentError
_ -> err status reason'
| status == Just N.forbidden403 = case reason' of
"ExpiredProviderToken" -> throwE PPPermanentError -- there should be no point retrying it as the token was refreshed
"InvalidProviderToken" -> throwE PPPermanentError
"ExpiredProviderToken" -> throwError PPPermanentError -- there should be no point retrying it as the token was refreshed
"InvalidProviderToken" -> throwError PPPermanentError
_ -> err status reason'
| status == Just N.gone410 = throwE PPTokenInvalid
| status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwE PPRetryLater
| status == Just N.gone410 = throwError PPTokenInvalid
| status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwError 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 = throwE $ PPResponseError s r
err s r = throwError $ PPResponseError s r
liftHTTPS2 a = ExceptT $ first PPConnection <$> a
@@ -116,7 +116,7 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
getHandshake th >>= \case
NtfClientHandshake {ntfVersion = v, keyHash}
| keyHash /= kh ->
throwE $ TEHandshake IDENTITY
throwError $ TEHandshake IDENTITY
| otherwise ->
case compatibleVRange' ntfVersionRange v of
Just (Compatible vr) -> pure $ ntfThHandleServer th v vr pk
@@ -128,7 +128,7 @@ 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 throwE TEBadSession
then throwError TEBadSession
else case ntfVersionRange `compatibleVRange` ntfVRange of
Just (Compatible vr) -> do
ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
+1 -4
View File
@@ -24,7 +24,7 @@ import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (FieldParser, returnError)
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok (Ok (Ok))
import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Util ((<$?>))
import Text.Read (readMaybe)
base64P :: Parser ByteString
@@ -154,6 +154,3 @@ singleFieldJSON_ objectTag tagModifier =
defaultJSON :: J.Options
defaultJSON = J.defaultOptions {J.omitNothingFields = True}
textP :: Parser String
textP = T.unpack . safeDecodeUtf8 <$> A.takeByteString
+2 -23
View File
@@ -156,7 +156,6 @@ module Simplex.Messaging.Protocol
sameSrvAddr,
sameSrvAddr',
noAuthSrv,
toMsgInfo,
-- * TCP transport functions
TransportBatch (..),
@@ -198,8 +197,8 @@ import qualified Data.List.NonEmpty as L
import Data.Maybe (isJust, isNothing)
import Data.String
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock.System (SystemTime (..))
import Data.Type.Equality
import Data.Word (Word16)
import qualified Data.X509 as X
@@ -211,7 +210,6 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.ServiceScheme
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
@@ -388,7 +386,6 @@ 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
@@ -466,7 +463,6 @@ data BrokerMsg where
RRES :: EncFwdResponse -> BrokerMsg -- relay to proxy
PRES :: EncResponse -> BrokerMsg -- proxy to client
END :: BrokerMsg
INFO :: QueueInfo -> BrokerMsg
OK :: BrokerMsg
ERR :: ErrorType -> BrokerMsg
PONG :: BrokerMsg
@@ -509,13 +505,6 @@ 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
@@ -663,7 +652,6 @@ 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
@@ -686,7 +674,6 @@ data BrokerMsgTag
| RRES_
| PRES_
| END_
| INFO_
| OK_
| ERR_
| PONG_
@@ -711,7 +698,6 @@ instance PartyI p => Encoding (CommandTag p) where
ACK_ -> "ACK"
OFF_ -> "OFF"
DEL_ -> "DEL"
QUE_ -> "QUE"
SEND_ -> "SEND"
PING_ -> "PING"
PRXY_ -> "PRXY"
@@ -731,7 +717,6 @@ 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_
@@ -757,7 +742,6 @@ instance Encoding BrokerMsgTag where
RRES_ -> "RRES"
PRES_ -> "PRES"
END_ -> "END"
INFO_ -> "INFO"
OK_ -> "OK"
ERR_ -> "ERR"
PONG_ -> "PONG"
@@ -773,7 +757,6 @@ instance ProtocolMsgTag BrokerMsgTag where
"RRES" -> Just RRES_
"PRES" -> Just PRES_
"END" -> Just END_
"INFO" -> Just INFO_
"OK" -> Just OK_
"ERR" -> Just ERR_
"PONG" -> Just PONG_
@@ -1292,7 +1275,6 @@ 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_
@@ -1358,7 +1340,6 @@ 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)
@@ -1387,7 +1368,6 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
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_
@@ -1408,7 +1388,6 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
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
+138 -278
View File
@@ -6,7 +6,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
@@ -45,7 +44,6 @@ import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Crypto.Random
import Control.Monad.STM (retry)
import Data.Bifunctor (first)
import Data.ByteString.Base64 (encode)
import Data.ByteString.Char8 (ByteString)
@@ -59,7 +57,7 @@ import Data.List (intercalate, mapAccumR)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
import Data.Maybe (isNothing)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
@@ -70,8 +68,8 @@ import GHC.Stats (getRTSStats)
import GHC.TypeLits (KnownNat)
import Network.Socket (ServiceName, Socket, socketToHandle)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPMessage, smpProxyError, temporaryClientError)
import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient)
import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), forwardSMPMessage, smpProxyError)
import Simplex.Messaging.Client.Agent (SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient', lookupSMPServerClient)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
@@ -82,7 +80,6 @@ import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.Server.QueueStore.STM as QS
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.Server.StoreLog
@@ -97,6 +94,7 @@ import System.Exit (exitFailure)
import System.IO (hPrint, hPutStrLn, hSetNewlineMode, universalNewlineMode)
import System.Mem.Weak (deRefWeak)
import UnliftIO (timeout)
import UnliftIO.Async (mapConcurrently)
import UnliftIO.Concurrent
import UnliftIO.Directory (doesFileExist, renameFile)
import UnliftIO.Exception
@@ -104,6 +102,7 @@ import UnliftIO.IO
import UnliftIO.STM
#if MIN_VERSION_base(4,18,0)
import Data.List (sort)
import Data.Maybe (fromMaybe)
import GHC.Conc (listThreads, threadStatus)
import GHC.Conc.Sync (threadLabel)
#endif
@@ -182,8 +181,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified
endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s)
endPreviousSubscriptions (qId, c) = do
forkClient c (label <> ".endPreviousSubscriptions") $
tId <- atomically $ stateTVar (endThreadSeq c) $ \next -> (next, next + 1)
t <- forkIO $ do
labelMyThread $ label <> ".endPreviousSubscriptions"
atomically $ writeTBQueue (sndQ c) [(CorrId "", qId, END)]
atomically $ modifyTVar' (endThreads c) $ IM.delete tId
mkWeakThreadId t >>= atomically . modifyTVar' (endThreads c) . IM.insert tId
atomically $ TM.lookupDelete qId (clientSubs c)
receiveFromProxyAgent :: ProxyAgent -> M ()
@@ -229,7 +232,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, qSub, qSubAuth, qSubDuplicate, qSubProhibited, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv} <- asks serverStats
ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats
let interval = 1000000 * logInterval
forever $ do
withFile statsFilePath AppendMode $ \h -> liftIO $ do
@@ -241,74 +244,39 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
qDeletedAll' <- atomically $ swapTVar qDeletedAll 0
qDeletedNew' <- atomically $ swapTVar qDeletedNew 0
qDeletedSecured' <- atomically $ swapTVar qDeletedSecured 0
qSub' <- atomically $ swapTVar qSub 0
qSubAuth' <- atomically $ swapTVar qSubAuth 0
qSubDuplicate' <- atomically $ swapTVar qSubDuplicate 0
qSubProhibited' <- atomically $ swapTVar qSubProhibited 0
msgSent' <- atomically $ swapTVar msgSent 0
msgSentAuth' <- atomically $ swapTVar msgSentAuth 0
msgSentQuota' <- atomically $ swapTVar msgSentQuota 0
msgSentLarge' <- atomically $ swapTVar msgSentLarge 0
msgRecv' <- atomically $ swapTVar msgRecv 0
msgExpired' <- atomically $ swapTVar msgExpired 0
ps <- atomically $ periodStatCounts activeQueues ts
msgSentNtf' <- atomically $ swapTVar msgSentNtf 0
msgRecvNtf' <- atomically $ swapTVar msgRecvNtf 0
psNtf <- atomically $ periodStatCounts activeQueuesNtf ts
msgNtfs' <- atomically $ swapTVar (msgNtfs ss) 0
msgNtfNoSub' <- atomically $ swapTVar (msgNtfNoSub ss) 0
msgNtfLost' <- atomically $ swapTVar (msgNtfLost ss) 0
pRelays' <- atomically $ getResetProxyStatsData pRelays
pRelaysOwn' <- atomically $ getResetProxyStatsData pRelaysOwn
pMsgFwds' <- atomically $ getResetProxyStatsData pMsgFwds
pMsgFwdsOwn' <- atomically $ getResetProxyStatsData pMsgFwdsOwn
pMsgFwdsRecv' <- atomically $ swapTVar pMsgFwdsRecv 0
qCount' <- readTVarIO qCount
msgCount' <- readTVarIO msgCount
hPutStrLn h $
intercalate
","
( [ iso8601Show $ utctDay fromTime',
show qCreated',
show qSecured',
show qDeletedAll',
show msgSent',
show msgRecv',
dayCount ps,
weekCount ps,
monthCount ps,
show msgSentNtf',
show msgRecvNtf',
dayCount psNtf,
weekCount psNtf,
monthCount psNtf,
show qCount',
show msgCount',
show msgExpired',
show qDeletedNew',
show qDeletedSecured'
]
<> showProxyStats pRelays'
<> showProxyStats pRelaysOwn'
<> showProxyStats pMsgFwds'
<> showProxyStats pMsgFwdsOwn'
<> [ show pMsgFwdsRecv',
show qSub',
show qSubAuth',
show qSubDuplicate',
show qSubProhibited',
show msgSentAuth',
show msgSentQuota',
show msgSentLarge',
show msgNtfs',
show msgNtfNoSub',
show msgNtfLost'
]
)
[ iso8601Show $ utctDay fromTime',
show qCreated',
show qSecured',
show qDeletedAll',
show msgSent',
show msgRecv',
dayCount ps,
weekCount ps,
monthCount ps,
show msgSentNtf',
show msgRecvNtf',
dayCount psNtf,
weekCount psNtf,
monthCount psNtf,
show qCount',
show msgCount',
show msgExpired',
show qDeletedNew',
show qDeletedSecured'
]
liftIO $ threadDelay' interval
where
showProxyStats ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} =
[show _pRequests, show _pSuccesses, show _pErrorsConnect, show _pErrorsCompat, show _pErrorsOther]
runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
runClient signKey tp h = do
@@ -378,13 +346,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
subscriptions' <- bshow . M.size <$> readTVarIO subscriptions
hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions']
CPStats -> withAdminRole $ do
ss <- unliftIO u $ asks serverStats
let putStat :: Show a => ByteString -> (ServerStats -> TVar a) -> IO ()
putStat label var = readTVarIO (var ss) >>= \v -> B.hPutStr h $ label <> ": " <> bshow v <> "\n"
putProxyStat :: ByteString -> (ServerStats -> ProxyStats) -> IO ()
putProxyStat label var = do
ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} <- atomically $ getProxyStatsData $ var ss
B.hPutStr h $ label <> ": requests=" <> bshow _pRequests <> ", successes=" <> bshow _pSuccesses <> ", errorsConnect=" <> bshow _pErrorsConnect <> ", errorsCompat=" <> bshow _pErrorsCompat <> ", errorsOther=" <> bshow _pErrorsOther <> "\n"
ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgSentNtf, msgRecvNtf, qCount, msgCount} <- unliftIO u $ asks serverStats
putStat "fromTime" fromTime
putStat "qCreated" qCreated
putStat "qSecured" qSecured
@@ -397,11 +359,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
putStat "msgRecvNtf" msgRecvNtf
putStat "qCount" qCount
putStat "msgCount" msgCount
putProxyStat "pRelays" pRelays
putProxyStat "pRelaysOwn" pRelaysOwn
putProxyStat "pMsgFwds" pMsgFwds
putProxyStat "pMsgFwdsOwn" pMsgFwdsOwn
putStat "pMsgFwdsRecv" pMsgFwdsRecv
where
putStat :: Show a => String -> TVar a -> IO ()
putStat label var = readTVarIO var >>= \v -> hPutStrLn h $ label <> ": " <> show v
CPStatsRTS -> getRTSStats >>= hPrint h
CPThreads -> withAdminRole $ do
#if MIN_VERSION_base(4,18,0)
@@ -526,25 +486,19 @@ receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiv
forever $ do
ts <- L.toList <$> liftIO (tGet h)
atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime
stats <- asks serverStats
(errs, cmds) <- partitionEithers <$> mapM (cmdAction stats) ts
(errs, cmds) <- partitionEithers <$> mapM cmdAction ts
write sndQ errs
write rcvQ cmds
where
cmdAction :: ServerStats -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
cmdAction stats (tAuth, authorized, (corrId, entId, cmdOrError)) =
cmdAction :: SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
cmdAction (tAuth, authorized, (corrId, entId, cmdOrError)) =
case cmdOrError of
Left e -> pure $ Left (corrId, entId, ERR e)
Right cmd -> verified =<< verifyTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) tAuth authorized entId cmd
Right cmd -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) tAuth authorized entId cmd
where
verified = \case
VRVerified qr -> pure $ Right (qr, (corrId, entId, cmd))
VRFailed -> do
case cmd of
Cmd _ SEND {} -> atomically $ modifyTVar' (msgSentAuth stats) (+ 1)
Cmd _ SUB -> atomically $ modifyTVar' (qSubAuth stats) (+ 1)
_ -> pure ()
pure $ Left (corrId, entId, ERR AUTH)
VRVerified qr -> Right (qr, (corrId, entId, cmd))
VRFailed -> Left (corrId, entId, ERR AUTH)
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
send :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> IO ()
@@ -673,133 +627,82 @@ dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/Xo
dummyKeyX25519 :: C.PublicKey 'C.X25519
dummyKeyX25519 = "MCowBQYDK2VuAyEA4JGSMYht18H4mas/jHeBwfcM7jLwNYJNOAhi2/g4RXg="
forkClient :: Client -> String -> M () -> M ()
forkClient Client {endThreads, endThreadSeq} label action = do
tId <- atomically $ stateTVar endThreadSeq $ \next -> (next, next + 1)
t <- forkIO $ do
labelMyThread label
action `finally` atomically (modifyTVar' endThreads $ IM.delete tId)
mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId
client :: THandleParams SMPVersion 'TServer -> Client -> Server -> M ()
client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, notifiers} = do
client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Server {subscribedQ, ntfSubscribedQ, notifiers} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
forever $
atomically (readTBQueue rcvQ)
>>= mapM processCommand
>>= mapM_ reply . L.nonEmpty . catMaybes . L.toList
forever $ do
(proxied, rs) <- partitionEithers . L.toList <$> (mapM processCommand =<< atomically (readTBQueue rcvQ))
forM_ (L.nonEmpty rs) reply
-- TODO cancel this thread if the client gets disconnected
-- TODO limit client concurrency
forM_ (L.nonEmpty proxied) $ \cmds -> forkIO $ mapConcurrently processProxiedCmd cmds >>= reply
where
reply :: MonadIO m => NonEmpty (Transmission BrokerMsg) -> m ()
reply = atomically . writeTBQueue sndQ
processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M (Maybe (Transmission BrokerMsg))
processProxiedCmd (corrId, sessId, command) = (corrId,sessId,) <$$> case command of
PRXY srv auth -> ifM allowProxy getRelay (pure $ Just $ ERR $ PROXY BASIC_AUTH)
processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M (Transmission BrokerMsg)
processProxiedCmd (corrId, sessId, command) = (corrId, sessId,) <$> case command of
PRXY srv auth -> ifM allowProxy getRelay (pure $ ERR $ PROXY BASIC_AUTH)
where
allowProxy = do
ServerConfig {allowSMPProxy, newQueueBasicAuth} <- asks config
pure $ allowSMPProxy && maybe True ((== auth) . Just) newQueueBasicAuth
getRelay = do
ProxyAgent {smpAgent = a} <- asks proxyAgent
liftIO (getConnectedSMPServerClient a srv) >>= \case
Just r -> Just <$> proxyServerResponse a r
Nothing ->
forkProxiedCmd $
liftIO (runExceptT (getSMPServerClient'' a srv) `catch` (pure . Left . PCEIOError))
>>= proxyServerResponse a
proxyServerResponse :: SMPClientAgent -> Either SMPClientError (OwnServer, SMPClient) -> M BrokerMsg
proxyServerResponse a smp_ = do
ServerStats {pRelays, pRelaysOwn} <- asks serverStats
let inc = mkIncProxyStats pRelays pRelaysOwn
case smp_ of
Right (own, smp) -> do
inc own pRequests
case proxyResp smp of
r@PKEY {} -> r <$ inc own pSuccesses
r -> r <$ inc own pErrorsCompat
Left e -> do
let own = isOwnServer a srv
inc own pRequests
inc own $ if temporaryClientError e then pErrorsConnect else pErrorsOther
logWarn $ "Error connecting: " <> decodeLatin1 (strEncode $ host srv) <> " " <> tshow e
pure . ERR $ smpProxyError e
ProxyAgent {smpAgent} <- asks proxyAgent
liftIO $ proxyResp <$> runExceptT (getSMPServerClient' smpAgent srv) `catch` (pure . Left . PCEIOError)
where
proxyResp smp =
let THandleParams {sessionId = srvSessId, thVersion, thServerVRange, thAuth} = thParams smp
in case compatibleVRange thServerVRange proxiedSMPRelayVRange of
-- Cap the destination relay version range to prevent client version fingerprinting.
-- See comment for proxiedSMPRelayVersion.
Just (Compatible vr) | thVersion >= sendingProxySMPVersion -> case thAuth of
Just THAuthClient {serverCertKey} -> PKEY srvSessId vr serverCertKey
Nothing -> ERR $ transportErr TENoServerAuth
_ -> ERR $ transportErr TEVersion
proxyResp = \case
Left err -> ERR $ smpProxyError err
Right smp ->
let THandleParams {sessionId = srvSessId, thVersion, thServerVRange, thAuth} = thParams smp
in case compatibleVRange thServerVRange proxiedSMPRelayVRange of
-- Cap the destination relay version range to prevent client version fingerprinting.
-- See comment for proxiedSMPRelayVersion.
Just (Compatible vr) | thVersion >= sendingProxySMPVersion -> case thAuth of
Just THAuthClient {serverCertKey} -> PKEY srvSessId vr serverCertKey
Nothing -> ERR $ transportErr TENoServerAuth
_ -> ERR $ transportErr TEVersion
PFWD fwdV pubKey encBlock -> do
ProxyAgent {smpAgent = a} <- asks proxyAgent
ServerStats {pMsgFwds, pMsgFwdsOwn} <- asks serverStats
let inc = mkIncProxyStats pMsgFwds pMsgFwdsOwn
atomically (lookupSMPServerClient a sessId) >>= \case
Just (own, smp) -> do
inc own pRequests
if v >= sendingProxySMPVersion
then forkProxiedCmd $ do
liftIO (runExceptT (forwardSMPMessage smp corrId fwdV pubKey encBlock) `catch` (pure . Left . PCEIOError)) >>= \case
Right r -> PRES r <$ inc own pSuccesses
Left e -> ERR (smpProxyError e) <$ case e of
PCEProtocolError {} -> inc own pSuccesses
_ -> inc own pErrorsOther
else Just (ERR $ transportErr TEVersion) <$ inc own pErrorsCompat
ProxyAgent {smpAgent} <- asks proxyAgent
atomically (lookupSMPServerClient smpAgent sessId) >>= \case
Just smp
| v >= sendingProxySMPVersion ->
liftIO $ either (ERR . smpProxyError) PRES <$>
runExceptT (forwardSMPMessage smp corrId fwdV pubKey encBlock) `catchError` (pure . Left . PCEIOError)
| otherwise -> pure . ERR $ transportErr TEVersion
where
THandleParams {thVersion = v} = thParams smp
Nothing -> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION)
where
forkProxiedCmd :: M BrokerMsg -> M (Maybe BrokerMsg)
forkProxiedCmd cmdAction = do
bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " proxy") $ do
-- commands MUST be processed under a reasonable timeout or the client would halt
cmdAction >>= \t -> reply [(corrId, sessId, t)]
pure Nothing
where
wait = do
ServerConfig {serverClientConcurrency} <- asks config
atomically $ do
used <- readTVar procThreads
when (used >= serverClientConcurrency) retry
writeTVar procThreads $! used + 1
signal = atomically $ modifyTVar' procThreads (\t -> t - 1)
Nothing -> pure $ ERR $ PROXY NO_SESSION
transportErr :: TransportError -> ErrorType
transportErr = PROXY . BROKER . TRANSPORT
mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> TVar Int) -> m ()
mkIncProxyStats ps psOwn = \own sel -> do
atomically $ modifyTVar' (sel ps) (+ 1)
when own $ atomically $ modifyTVar' (sel psOwn) (+ 1)
processCommand :: (Maybe QueueRec, Transmission Cmd) -> M (Maybe (Transmission BrokerMsg))
processCommand (qr_, (corrId, queueId, cmd)) = case cmd of
Cmd SProxiedClient command -> processProxiedCmd (corrId, queueId, command)
Cmd SSender command -> Just <$> case command of
SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
PING -> pure (corrId, "", PONG)
RFWD encBlock -> (corrId, "",) <$> processForwardedCommand encBlock
Cmd SNotifier NSUB -> Just <$> subscribeNotifications
Cmd SRecipient command -> do
st <- asks queueStore
Just <$> case command of
NEW rKey dhKey auth subMode ->
ifM
allowNew
(createQueue st rKey dhKey subMode)
(pure (corrId, queueId, ERR AUTH))
where
allowNew = do
ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth
SUB -> withQueue (`subscribeQueue` queueId)
GET -> withQueue getMessage
ACK msgId -> withQueue (`acknowledgeMsg` msgId)
KEY sKey -> secureQueue_ st sKey
NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
NDEL -> deleteQueueNotifier_ st
OFF -> suspendQueue_ st
DEL -> delQueueAndMsgs st
QUE -> withQueue getQueueInfo
processCommand :: (Maybe QueueRec, Transmission Cmd) -> M (Either (Transmission (Command 'ProxiedClient)) (Transmission BrokerMsg))
processCommand (qr_, (corrId, queueId, cmd)) = do
st <- asks queueStore
case cmd of
Cmd SProxiedClient command -> pure $ Left (corrId, queueId, command)
Cmd SSender command -> Right <$> case command of
SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
PING -> pure (corrId, "", PONG)
RFWD encBlock -> (corrId, "",) <$> processForwardedCommand encBlock
Cmd SNotifier NSUB -> Right <$> subscribeNotifications
Cmd SRecipient command ->
Right <$> case command of
NEW rKey dhKey auth subMode ->
ifM
allowNew
(createQueue st rKey dhKey subMode)
(pure (corrId, queueId, ERR AUTH))
where
allowNew = do
ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth
SUB -> withQueue (`subscribeQueue` queueId)
GET -> withQueue getMessage
ACK msgId -> withQueue (`acknowledgeMsg` msgId)
KEY sKey -> secureQueue_ st sKey
NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
NDEL -> deleteQueueNotifier_ st
OFF -> suspendQueue_ st
DEL -> delQueueAndMsgs st
where
createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> M (Transmission BrokerMsg)
createQueue st recipientKey dhKey subMode = time "NEW" $ do
@@ -886,19 +789,15 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
subscribeQueue :: QueueRec -> RecipientId -> M (Transmission BrokerMsg)
subscribeQueue qr rId = do
stats <- asks serverStats
atomically (TM.lookup rId subscriptions) >>= \case
Nothing -> do
atomically $ modifyTVar' (qSub stats) (+ 1)
Nothing ->
newSub >>= deliver
Just sub ->
readTVarIO sub >>= \case
Sub {subThread = ProhibitSub} -> do
Sub {subThread = ProhibitSub} ->
-- cannot use SUB in the same connection where GET was used
atomically $ modifyTVar' (qSubProhibited stats) (+ 1)
pure (corrId, rId, ERR $ CMD PROHIBITED)
s -> do
atomically $ modifyTVar' (qSubDuplicate stats) (+ 1)
s ->
atomically (tryTakeTMVar $ delivered s) >> deliver sub
where
newSub :: M (TVar Sub)
@@ -992,45 +891,29 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
sendMessage :: QueueRec -> MsgFlags -> MsgBody -> M (Transmission BrokerMsg)
sendMessage qr msgFlags msgBody
| B.length msgBody > maxMessageLength thVersion = do
stats <- asks serverStats
atomically $ modifyTVar' (msgSentLarge stats) (+ 1)
pure $ err LARGE_MSG
| otherwise = do
stats <- asks serverStats
case status qr of
QueueOff -> do
atomically $ modifyTVar' (msgSentAuth stats) (+ 1)
pure $ err AUTH
QueueActive ->
case C.maxLenBS msgBody of
Left _ -> pure $ err LARGE_MSG
Right body -> do
msg_ <- time "SEND" $ do
q <- getStoreMsgQueue "SEND" $ recipientId qr
expireMessages q
atomically . writeMsg q =<< mkMessage body
case msg_ of
Nothing -> do
atomically $ modifyTVar' (msgSentQuota stats) (+ 1)
pure $ err QUOTA
Just msg -> time "SEND ok" $ do
when (notification msgFlags) $ do
forM_ (notifier qr) $ \ntf -> do
asks random >>= atomically . trySendNotification ntf msg >>= \case
Nothing -> do
atomically $ modifyTVar' (msgNtfNoSub stats) (+ 1)
logWarn "No notification subscription"
Just False -> do
atomically $ modifyTVar' (msgNtfLost stats) (+ 1)
logWarn "Dropped message notification"
Just True -> atomically $ modifyTVar' (msgNtfs stats) (+ 1)
atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
atomically $ modifyTVar' (msgSent stats) (+ 1)
atomically $ modifyTVar' (msgCount stats) (+ 1)
atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
pure ok
| B.length msgBody > maxMessageLength thVersion = pure $ err LARGE_MSG
| otherwise = case status qr of
QueueOff -> return $ err AUTH
QueueActive ->
case C.maxLenBS msgBody of
Left _ -> pure $ err LARGE_MSG
Right body -> do
msg_ <- time "SEND" $ do
q <- getStoreMsgQueue "SEND" $ recipientId qr
expireMessages q
atomically . writeMsg q =<< mkMessage body
case msg_ of
Nothing -> pure $ err QUOTA
Just msg -> time "SEND ok" $ do
stats <- asks serverStats
when (notification msgFlags) $ do
atomically . trySendNotification msg =<< asks random
atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
atomically $ modifyTVar' (msgSent stats) (+ 1)
atomically $ modifyTVar' (msgCount stats) (+ 1)
atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
pure ok
where
THandleParams {thVersion} = thParams'
mkMessage :: C.MaxLenBS MaxMessageLen -> M Message
@@ -1047,19 +930,18 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
deleted <- atomically $ sum <$> mapM (deleteExpiredMsgs q) old
atomically $ modifyTVar' (msgExpired stats) (+ deleted)
trySendNotification :: NtfCreds -> Message -> TVar ChaChaDRG -> STM (Maybe Bool)
trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg ntfNonceDrg =
mapM (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
trySendNotification msg ntfNonceDrg =
forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM Bool
writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
ifM (isFullTBQueue q) (pure False) (sendNtf $> True)
where
sendNtf = case msg of
Message {msgId, msgTs} -> do
(nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg
writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
_ -> pure ()
unlessM (isFullTBQueue q) $ case msg of
Message {msgId, msgTs} -> do
(nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg
writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
_ -> pure ()
mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg = do
@@ -1091,7 +973,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
Right t''@(_, (corrId', entId', cmd')) -> case cmd' of
Cmd SSender SEND {} ->
-- Left will not be returned by processCommand, as only SEND command is allowed
fromMaybe (corrId', entId', ERR INTERNAL) <$> lift (processCommand t'')
fromRight (corrId', entId', ERR INTERNAL) <$> lift (processCommand t'')
_ ->
pure (corrId', entId', ERR $ CMD PROHIBITED)
-- encode response
@@ -1105,8 +987,6 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
-- encrypt to proxy
let fr = FwdResponse {fwdCorrId, fwdResponse = r2}
r3 = EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr)
stats <- asks serverStats
atomically $ modifyTVar' (pMsgFwdsRecv stats) (+ 1)
pure $ RRES r3
where
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
@@ -1180,26 +1060,6 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
Right q -> updateDeletedStats q $> ok
Left e -> pure $ err e
getQueueInfo :: QueueRec -> M (Transmission BrokerMsg)
getQueueInfo QueueRec {senderKey, notifier} = do
q@MsgQueue {size} <- getStoreMsgQueue "getQueueInfo" queueId
info <- atomically $ do
qiSub <- TM.lookup queueId subscriptions >>= mapM mkQSub
qiSize <- readTVar size
qiMsg <- toMsgInfo <$$> tryPeekMsg q
pure QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg}
pure (corrId, queueId, INFO info)
where
mkQSub sub = do
Sub {subThread, delivered} <- readTVar sub
let qSubThread = case subThread of
NoSub -> QNoSub
SubPending -> QSubPending
SubThread _ -> QSubThread
ProhibitSub -> QProhibitSub
qDelivered <- decodeLatin1 . encode <$$> tryReadTMVar delivered
pure QSub {qSubThread, qDelivered}
ok :: Transmission BrokerMsg
ok = (corrId, queueId, OK)
+1 -1
View File
@@ -254,7 +254,7 @@ onOffPrompt prompt def =
"N" -> pure False
_ -> putStrLn "Invalid input, please enter 'y' or 'n'" >> onOffPrompt prompt def
onOff :: Bool -> Text
onOff :: Bool -> String
onOff True = "on"
onOff _ = "off"
+5 -35
View File
@@ -2,7 +2,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
module Simplex.Messaging.Server.Env.STM where
@@ -16,7 +15,6 @@ 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 (..))
@@ -29,7 +27,6 @@ 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
@@ -84,12 +81,8 @@ data ServerConfig = ServerConfig
transportConfig :: TransportServerConfig,
-- | run listener on control port
controlPort :: Maybe ServiceName,
-- | SMP proxy config
smpAgentCfg :: SMPClientAgentConfig,
allowSMPProxy :: Bool, -- auth is the same with `newQueueBasicAuth`
serverClientConcurrency :: Int,
-- | server public information
information :: Maybe ServerPublicInfo
allowSMPProxy :: Bool -- auth is the same with `newQueueBasicAuth`
}
defMsgExpirationDays :: Int64
@@ -109,12 +102,8 @@ defaultInactiveClientExpiration =
checkInterval = 3600 -- seconds, 1 hours
}
defaultProxyClientConcurrency :: Int
defaultProxyClientConcurrency = 32
data Env = Env
{ config :: ServerConfig,
serverInfo :: ServerInformation,
server :: Server,
serverIdentity :: KeyHash,
queueStore :: QueueStore,
@@ -137,7 +126,7 @@ data Server = Server
savingLock :: Lock
}
newtype ProxyAgent = ProxyAgent
data ProxyAgent = ProxyAgent
{ smpAgent :: SMPClientAgent
}
@@ -150,7 +139,6 @@ data Client = Client
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,
@@ -185,13 +173,12 @@ newClient nextClientId qSize thVersion sessionId createdAt = do
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, msgQ, procThreads, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt}
return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, msgQ, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt}
newSubscription :: SubscriptionThread -> STM Sub
newSubscription subThread = do
@@ -199,7 +186,7 @@ newSubscription subThread = do
return Sub {subThread, delivered}
newEnv :: ServerConfig -> IO Env
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, smpAgentCfg, transportConfig, information, messageExpiration} = do
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, smpAgentCfg, transportConfig} = do
server <- atomically newServer
queueStore <- atomically newQueueStore
msgStore <- atomically newMsgStore
@@ -213,7 +200,7 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
clientSeq <- newTVarIO 0
clients <- newTVarIO mempty
proxyAgent <- atomically $ newSMPProxyAgent smpAgentCfg random
pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients, proxyAgent}
return Env {config, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients, proxyAgent}
where
restoreQueues :: QueueStore -> FilePath -> IO (StoreLog 'WriteMode)
restoreQueues QueueStore {queues, senders, notifiers} f = do
@@ -229,23 +216,6 @@ 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
@@ -1,76 +0,0 @@
{-# 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)
+34 -256
View File
@@ -5,45 +5,33 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Messaging.Server.Main where
import Control.Concurrent.STM
import Control.Logger.Simple
import Control.Monad (void, when, (<$!>))
import Data.ByteString.Char8 (ByteString)
import Control.Monad (void)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlpha, isAscii, toUpper)
import Data.Functor (($>))
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.Ini (lookupValue, readIniFile)
import Data.Maybe (fromMaybe)
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, defaultProxyClientConcurrency)
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration)
import Simplex.Messaging.Server.Expiration
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 (eitherToMaybe, safeDecodeUtf8, tshow)
import Simplex.Messaging.Util (safeDecodeUtf8)
import Simplex.Messaging.Version (mkVersionRange)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (combine)
@@ -51,10 +39,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
import Text.Read (readMaybe)
smpServerCLI :: FilePath -> FilePath -> IO ()
smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ())
smpServerCLI_ :: (ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) -> (EmbeddedWebParams -> IO ()) -> FilePath -> FilePath -> IO ()
smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
smpServerCLI cfgPath logPath =
getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
Init opts ->
doesFileExist iniFile >>= \case
@@ -79,10 +64,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
defaultServerPort = "5223"
executableName = "smp-server"
storeLogFilePath = combine logPath "smp-server-store.log"
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}
initializeServer opts@InitOptions {ip, fqdn, scripted}
| scripted = initialize opts
| otherwise = do
putStrLn "Use `smp-server init -h` for available options."
@@ -93,19 +75,7 @@ smpServerCLI_ generateSite serveStaticFiles 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
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
}
initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn else Just host', password}
where
serverPassword =
getLine >>= \case
@@ -116,7 +86,7 @@ smpServerCLI_ generateSite serveStaticFiles 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, sourceCode, webStaticPath, disableWeb} = do
initialize InitOptions {enableStoreLog, logStats, signAlgorithm, password} = do
clearDirIfExists cfgPath
clearDirIfExists logPath
createDirectoryIfMissing True cfgPath
@@ -126,29 +96,26 @@ smpServerCLI_ generateSite serveStaticFiles 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
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."
writeFile iniFile $ iniFileContent host basicAuth
putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> 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 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"
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"
<> ("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: " <> tshow defMsgExpirationDays <> "\n\n")
<> ("expire_messages_days: " <> show defMsgExpirationDays <> "\n\n")
<> "# Log daily server statistics to CSV file\n"
<> ("log_stats: " <> onOff logStats <> "\n\n")
<> "[AUTH]\n\
@@ -161,7 +128,7 @@ smpServerCLI_ generateSite serveStaticFiles 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: " <> safeDecodeUtf8 (strEncode auth)
Just auth -> "create_password: " <> T.unpack (safeDecodeUtf8 $ strEncode auth)
_ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
)
<> "\n\n\
@@ -169,8 +136,8 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
\# control_port_user_password:\n\n\
\[TRANSPORT]\n\
\# host is only used to print server address on start\n"
<> ("host: " <> T.pack host <> "\n")
<> ("port: " <> T.pack defaultServerPort <> "\n")
<> ("host: " <> host <> "\n")
<> ("port: " <> defaultServerPort <> "\n")
<> "log_tls_errors: off\n\
\websockets: off\n\
\# control_port: 5224\n\n\
@@ -180,45 +147,26 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
\# 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\
\[INACTIVE_CLIENTS]\n\
\# TTL and interval to check inactive clients\n\
\disconnect: off\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")
<> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
<> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\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 {information, transports, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information
cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
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
@@ -231,20 +179,6 @@ smpServerCLI_ generateSite serveStaticFiles 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
@@ -272,9 +206,9 @@ smpServerCLI_ generateSite serveStaticFiles 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
@@ -296,7 +230,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
alpn = Just supportedSMPHandshakes
},
controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini,
controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
smpAgentCfg =
defaultSMPClientAgentConfig
{ smpCfg =
@@ -305,18 +239,15 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
agreeSecret = True,
networkConfig =
defaultNetworkConfig
{ socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,
{ 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
allowSMPProxy = True
}
textToSocksMode :: Text -> SocksMode
textToSocksMode = \case
@@ -328,128 +259,6 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
"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
@@ -464,9 +273,6 @@ data InitOptions = InitOptions
ip :: HostName,
fqdn :: Maybe HostName,
password :: Maybe ServerPassword,
sourceCode :: Maybe Text,
webStaticPath :: Maybe FilePath,
disableWeb :: Bool,
scripted :: Bool
}
deriving (Show)
@@ -521,6 +327,7 @@ cliCommandP cfgPath logPath iniFile =
( long "fqdn"
<> short 'n'
<> help "Server FQDN used as Common Name for TLS online certificate"
<> showDefault
<> metavar "FQDN"
)
password <-
@@ -533,41 +340,12 @@ 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,
sourceCode,
webStaticPath,
disableWeb,
scripted
}
pure InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password, scripted}
parseBasicAuth :: ReadM ServerPassword
parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
@@ -1,55 +0,0 @@
{-# 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
+24 -310
View File
@@ -26,28 +26,13 @@ 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, -- sent messages with NTF flag
msgRecvNtf :: TVar Int, -- received messages with NTF flag
msgSentNtf :: TVar Int,
msgRecvNtf :: TVar Int,
activeQueuesNtf :: PeriodStats RecipientId,
msgNtfs :: TVar Int, -- messages notications delivered to NTF server (<= msgSentNtf)
msgNtfNoSub :: TVar Int, -- no subscriber to notifications (e.g., NTF server not connected)
msgNtfLost :: TVar Int, -- notification is lost because NTF delivery queue is full
pRelays :: ProxyStats,
pRelaysOwn :: ProxyStats,
pMsgFwds :: ProxyStats,
pMsgFwdsOwn :: ProxyStats,
pMsgFwdsRecv :: TVar Int,
qCount :: TVar Int,
msgCount :: TVar Int
}
@@ -59,28 +44,13 @@ data ServerStatsData = ServerStatsData
_qDeletedAll :: Int,
_qDeletedNew :: Int,
_qDeletedSecured :: Int,
_qSub :: Int,
_qSubAuth :: Int,
_qSubDuplicate :: Int,
_qSubProhibited :: Int,
_msgSent :: Int,
_msgSentAuth :: Int,
_msgSentQuota :: Int,
_msgSentLarge :: Int,
_msgRecv :: Int,
_msgExpired :: Int,
_activeQueues :: PeriodStatsData RecipientId,
_msgSentNtf :: Int,
_msgRecvNtf :: Int,
_activeQueuesNtf :: PeriodStatsData RecipientId,
_msgNtfs :: Int,
_msgNtfNoSub :: Int,
_msgNtfLost :: Int,
_pRelays :: ProxyStatsData,
_pRelaysOwn :: ProxyStatsData,
_pMsgFwds :: ProxyStatsData,
_pMsgFwdsOwn :: ProxyStatsData,
_pMsgFwdsRecv :: Int,
_qCount :: Int,
_msgCount :: Int
}
@@ -94,63 +64,16 @@ newServerStats ts = do
qDeletedAll <- newTVar 0
qDeletedNew <- newTVar 0
qDeletedSecured <- newTVar 0
qSub <- newTVar 0
qSubAuth <- newTVar 0
qSubDuplicate <- newTVar 0
qSubProhibited <- newTVar 0
msgSent <- newTVar 0
msgSentAuth <- newTVar 0
msgSentQuota <- newTVar 0
msgSentLarge <- newTVar 0
msgRecv <- newTVar 0
msgExpired <- newTVar 0
activeQueues <- newPeriodStats
msgSentNtf <- newTVar 0
msgRecvNtf <- newTVar 0
activeQueuesNtf <- newPeriodStats
msgNtfs <- newTVar 0
msgNtfNoSub <- newTVar 0
msgNtfLost <- newTVar 0
pRelays <- newProxyStats
pRelaysOwn <- newProxyStats
pMsgFwds <- newProxyStats
pMsgFwdsOwn <- newProxyStats
pMsgFwdsRecv <- newTVar 0
qCount <- newTVar 0
msgCount <- newTVar 0
pure
ServerStats
{ fromTime,
qCreated,
qSecured,
qDeletedAll,
qDeletedNew,
qDeletedSecured,
qSub,
qSubAuth,
qSubDuplicate,
qSubProhibited,
msgSent,
msgSentAuth,
msgSentQuota,
msgSentLarge,
msgRecv,
msgExpired,
activeQueues,
msgSentNtf,
msgRecvNtf,
activeQueuesNtf,
msgNtfs,
msgNtfNoSub,
msgNtfLost,
pRelays,
pRelaysOwn,
pMsgFwds,
pMsgFwdsOwn,
pMsgFwdsRecv,
qCount,
msgCount
}
pure ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount}
getServerStatsData :: ServerStats -> STM ServerStatsData
getServerStatsData s = do
@@ -160,63 +83,16 @@ getServerStatsData s = do
_qDeletedAll <- readTVar $ qDeletedAll s
_qDeletedNew <- readTVar $ qDeletedNew s
_qDeletedSecured <- readTVar $ qDeletedSecured s
_qSub <- readTVar $ qSub s
_qSubAuth <- readTVar $ qSubAuth s
_qSubDuplicate <- readTVar $ qSubDuplicate s
_qSubProhibited <- readTVar $ qSubProhibited s
_msgSent <- readTVar $ msgSent s
_msgSentAuth <- readTVar $ msgSentAuth s
_msgSentQuota <- readTVar $ msgSentQuota s
_msgSentLarge <- readTVar $ msgSentLarge s
_msgRecv <- readTVar $ msgRecv s
_msgExpired <- readTVar $ msgExpired s
_activeQueues <- getPeriodStatsData $ activeQueues s
_msgSentNtf <- readTVar $ msgSentNtf s
_msgRecvNtf <- readTVar $ msgRecvNtf s
_activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
_msgNtfs <- readTVar $ msgNtfs s
_msgNtfNoSub <- readTVar $ msgNtfNoSub s
_msgNtfLost <- readTVar $ msgNtfLost s
_pRelays <- getProxyStatsData $ pRelays s
_pRelaysOwn <- getProxyStatsData $ pRelaysOwn s
_pMsgFwds <- getProxyStatsData $ pMsgFwds s
_pMsgFwdsOwn <- getProxyStatsData $ pMsgFwdsOwn s
_pMsgFwdsRecv <- readTVar $ pMsgFwdsRecv s
_qCount <- readTVar $ qCount s
_msgCount <- readTVar $ msgCount s
pure
ServerStatsData
{ _fromTime,
_qCreated,
_qSecured,
_qDeletedAll,
_qDeletedNew,
_qDeletedSecured,
_qSub,
_qSubAuth,
_qSubDuplicate,
_qSubProhibited,
_msgSent,
_msgSentAuth,
_msgSentQuota,
_msgSentLarge,
_msgRecv,
_msgExpired,
_activeQueues,
_msgSentNtf,
_msgRecvNtf,
_activeQueuesNtf,
_msgNtfs,
_msgNtfNoSub,
_msgNtfLost,
_pRelays,
_pRelaysOwn,
_pMsgFwds,
_pMsgFwdsOwn,
_pMsgFwdsRecv,
_qCount,
_msgCount
}
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _qCount, _msgCount}
setServerStats :: ServerStats -> ServerStatsData -> STM ()
setServerStats s d = do
@@ -226,69 +102,35 @@ setServerStats s d = do
writeTVar (qDeletedAll s) $! _qDeletedAll d
writeTVar (qDeletedNew s) $! _qDeletedNew d
writeTVar (qDeletedSecured s) $! _qDeletedSecured d
writeTVar (qSub s) $! _qSub d
writeTVar (qSubAuth s) $! _qSubAuth d
writeTVar (qSubDuplicate s) $! _qSubDuplicate d
writeTVar (qSubProhibited s) $! _qSubProhibited d
writeTVar (msgSent s) $! _msgSent d
writeTVar (msgSentAuth s) $! _msgSentAuth d
writeTVar (msgSentQuota s) $! _msgSentQuota d
writeTVar (msgSentLarge s) $! _msgSentLarge d
writeTVar (msgRecv s) $! _msgRecv d
writeTVar (msgExpired s) $! _msgExpired d
setPeriodStats (activeQueues s) (_activeQueues d)
writeTVar (msgSentNtf s) $! _msgSentNtf d
writeTVar (msgRecvNtf s) $! _msgRecvNtf d
setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
writeTVar (msgNtfs s) $! _msgNtfs d
writeTVar (msgNtfNoSub s) $! _msgNtfNoSub d
writeTVar (msgNtfLost s) $! _msgNtfLost d
setProxyStats (pRelays s) $! _pRelays d
setProxyStats (pRelaysOwn s) $! _pRelaysOwn d
setProxyStats (pMsgFwds s) $! _pMsgFwds d
setProxyStats (pMsgFwdsOwn s) $! _pMsgFwdsOwn d
writeTVar (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
writeTVar (qCount s) $! _qCount d
writeTVar (msgCount s) $! _msgCount d
instance StrEncoding ServerStatsData where
strEncode d =
strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount} =
B.unlines
[ "fromTime=" <> strEncode (_fromTime d),
"qCreated=" <> strEncode (_qCreated d),
"qSecured=" <> strEncode (_qSecured d),
"qDeletedAll=" <> strEncode (_qDeletedAll d),
"qDeletedNew=" <> strEncode (_qDeletedNew d),
"qDeletedSecured=" <> strEncode (_qDeletedSecured d),
"qCount=" <> strEncode (_qCount d),
"qSub=" <> strEncode (_qSub d),
"qSubAuth=" <> strEncode (_qSubAuth d),
"qSubDuplicate=" <> strEncode (_qSubDuplicate d),
"qSubProhibited=" <> strEncode (_qSubProhibited d),
"msgSent=" <> strEncode (_msgSent d),
"msgSentAuth=" <> strEncode (_msgSentAuth d),
"msgSentQuota=" <> strEncode (_msgSentQuota d),
"msgSentLarge=" <> strEncode (_msgSentLarge d),
"msgRecv=" <> strEncode (_msgRecv d),
"msgExpired=" <> strEncode (_msgExpired d),
"msgSentNtf=" <> strEncode (_msgSentNtf d),
"msgRecvNtf=" <> strEncode (_msgRecvNtf d),
"msgNtfs=" <> strEncode (_msgNtfs d),
"msgNtfNoSub=" <> strEncode (_msgNtfNoSub d),
"msgNtfLost=" <> strEncode (_msgNtfLost d),
[ "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,
"activeQueues:",
strEncode (_activeQueues d),
strEncode _activeQueues,
"activeQueuesNtf:",
strEncode (_activeQueuesNtf d),
"pRelays:",
strEncode (_pRelays d),
"pRelaysOwn:",
strEncode (_pRelaysOwn d),
"pMsgFwds:",
strEncode (_pMsgFwds d),
"pMsgFwdsOwn:",
strEncode (_pMsgFwdsOwn d),
"pMsgFwdsRecv=" <> strEncode (_pMsgFwdsRecv d)
strEncode _activeQueuesNtf
]
strP = do
_fromTime <- "fromTime=" *> strP <* A.endOfLine
@@ -297,22 +139,12 @@ 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 <- opt "qCount="
_qSub <- opt "qSub="
_qSubAuth <- opt "qSubAuth="
_qSubDuplicate <- opt "qSubDuplicate="
_qSubProhibited <- opt "qSubProhibited="
_qCount <- "qCount=" *> strP <* A.endOfLine <|> pure 0
_msgSent <- "msgSent=" *> strP <* A.endOfLine
_msgSentAuth <- opt "msgSentAuth="
_msgSentQuota <- opt "msgSentQuota="
_msgSentLarge <- opt "msgSentLarge="
_msgRecv <- "msgRecv=" *> strP <* A.endOfLine
_msgExpired <- opt "msgExpired="
_msgSentNtf <- opt "msgSentNtf="
_msgRecvNtf <- opt "msgRecvNtf="
_msgNtfs <- opt "msgNtfs="
_msgNtfNoSub <- opt "msgNtfNoSub="
_msgNtfLost <- opt "msgNtfLost="
_msgExpired <- "msgExpired=" *> strP <* A.endOfLine <|> pure 0
_msgSentNtf <- "msgSentNtf=" *> strP <* A.endOfLine <|> pure 0
_msgRecvNtf <- "msgRecvNtf=" *> strP <* A.endOfLine <|> pure 0
_activeQueues <-
optional ("activeQueues:" <* A.endOfLine) >>= \case
Just _ -> strP <* optional A.endOfLine
@@ -325,50 +157,7 @@ instance StrEncoding ServerStatsData where
optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
Just _ -> strP <* optional A.endOfLine
_ -> pure newPeriodStatsData
_pRelays <- proxyStatsP "pRelays:"
_pRelaysOwn <- proxyStatsP "pRelaysOwn:"
_pMsgFwds <- proxyStatsP "pMsgFwds:"
_pMsgFwdsOwn <- proxyStatsP "pMsgFwdsOwn:"
_pMsgFwdsRecv <- opt "pMsgFwdsRecv="
pure
ServerStatsData
{ _fromTime,
_qCreated,
_qSecured,
_qDeletedAll,
_qDeletedNew,
_qDeletedSecured,
_qSub,
_qSubAuth,
_qSubDuplicate,
_qSubProhibited,
_msgSent,
_msgSentAuth,
_msgSentQuota,
_msgSentLarge,
_msgRecv,
_msgExpired,
_msgSentNtf,
_msgRecvNtf,
_msgNtfs,
_msgNtfNoSub,
_msgNtfLost,
_activeQueues,
_activeQueuesNtf,
_pRelays,
_pRelaysOwn,
_pMsgFwds,
_pMsgFwdsOwn,
_pMsgFwdsRecv,
_qCount,
_msgCount = 0
}
where
opt s = A.string s *> strP <* A.endOfLine <|> pure 0
proxyStatsP key =
optional (A.string key >> A.endOfLine) >>= \case
Just _ -> strP <* optional A.endOfLine
_ -> pure newProxyStatsData
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount = 0}
data PeriodStats a = PeriodStats
{ day :: TVar (Set a),
@@ -442,78 +231,3 @@ 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}
+4 -6
View File
@@ -8,25 +8,23 @@ 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
sessionVarId :: Int
}
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
getSessVar :: forall k a. Ord k => TVar Int -> k -> TMap k (SessionVar a) -> STM (Either (SessionVar a) (SessionVar a))
getSessVar sessSeq sessKey vs = maybe (Left <$> newSessionVar) (pure . Right) =<< TM.lookup sessKey vs
where
newSessionVar :: STM (SessionVar a)
newSessionVar = do
sessionVar <- newEmptyTMVar
sessionVarId <- stateTVar sessSeq $ \next -> (next, next + 1)
let v = SessionVar {sessionVar, sessionVarId, sessionVarTs}
let v = SessionVar {sessionVar, sessionVarId}
TM.insert sessKey v vs
pure v
@@ -14,7 +14,6 @@ import Control.Monad
import Data.ByteString.Char8 (ByteString)
import Data.Functor (($>))
import Data.Time (UTCTime, getCurrentTime)
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as XS
import Network.HPACK (BufferSize)
import Network.HTTP2.Client (ClientConfig (..), Request, Response)
@@ -30,6 +29,7 @@ import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Util (eitherToMaybe)
import UnliftIO.STM
import UnliftIO.Timeout
import qualified Data.X509 as X
data HTTP2Client = HTTP2Client
{ action :: Maybe (Async HTTP2Response),
@@ -23,7 +23,7 @@ hReceiveFile getBody h size = get $ fromIntegral size
if
| chSize > sz -> pure (chSize - sz)
| chSize > 0 -> B.hPut h ch >> get (sz - chSize)
| otherwise -> pure (-sz)
| otherwise -> pure (-fromIntegral sz)
hSendFile :: Handle -> (Builder -> IO ()) -> Word32 -> IO ()
hSendFile h send = go
+3 -27
View File
@@ -19,7 +19,7 @@ module Simplex.Messaging.Transport.Server
loadTLSServerParams,
loadFingerprint,
smpServerHandshake,
tlsServerCredentials,
tlsServerCredentials
)
where
@@ -35,14 +35,11 @@ import Data.Maybe (fromJust, fromMaybe)
import qualified Data.X509 as X
import Data.X509.Validation (Fingerprint (..))
import qualified Data.X509.Validation as XV
import Foreign.C.Error
import GHC.IO.Exception (ioe_errno)
import Network.Socket
import qualified Network.TLS as T
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow)
import System.Exit (exitFailure)
import System.IO.Error (tryIOError)
import System.Mem.Weak (Weak, deRefWeak)
import UnliftIO (timeout)
import UnliftIO.Concurrent
@@ -116,36 +113,15 @@ runTCPServer started port server = do
runTCPServerSocket :: SocketState -> TMVar Bool -> IO Socket -> (Socket -> IO ()) -> IO ()
runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket server =
E.bracket getSocket (closeServer started clients) $ \sock ->
forever . E.bracketOnError (safeAccept sock) (close . fst) $ \(conn, _peer) -> do
forever . E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do
cId <- atomically $ stateTVar accepted $ \cId -> let cId' = cId + 1 in cId `seq` (cId', cId')
let closeConn _ = do
atomically $ modifyTVar' clients $ IM.delete cId
gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier
atomically $ modifyTVar' gracefullyClosed (+ 1)
atomically $ modifyTVar' gracefullyClosed (+1)
tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
atomically $ modifyTVar' clients $ IM.insert cId tId
-- | Recover from errors in `accept` whenever it is safe.
-- Some errors are safe to ignore, while blindly restaring `accept` may trigger a busy loop.
--
-- man accept says:
-- @
-- For reliable operation the application should detect the network errors defined for the protocol after accept() and treat them like EAGAIN by retrying.
-- In the case of TCP/IP, these are ENETDOWN, EPROTO, ENOPROTOOPT, EHOSTDOWN, ENONET, EHOSTUNREACH, EOPNOTSUPP, and ENETUNREACH.
-- @
safeAccept :: Socket -> IO (Socket, SockAddr)
safeAccept sock =
tryIOError (accept sock) >>= \case
Right r -> pure r
Left e
| retryAccept -> logWarn err >> safeAccept sock
| otherwise -> logError err >> E.throwIO e
where
retryAccept = maybe False ((`elem` again) . Errno) errno
again = [eAGAIN, eNETDOWN, ePROTO, eNOPROTOOPT, eHOSTDOWN, eNONET, eHOSTUNREACH, eOPNOTSUPP, eNETUNREACH]
err = "socket accept error: " <> tshow e <> maybe "" ((", errno=" <>) . tshow) errno
errno = ioe_errno e
type SocketState = (TVar Int, TVar Int, TVar (IntMap (Weak ThreadId)))
newSocketState :: STM SocketState
+8 -9
View File
@@ -7,7 +7,6 @@ import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Except
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
@@ -98,15 +97,15 @@ catchAll_ :: IO a -> IO a -> IO a
catchAll_ a = catchAll a . const
{-# INLINE catchAll_ #-}
tryAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors err action = ExceptT $ Right <$> runExceptT action `UE.catch` (pure . Left . err)
tryAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m (Either e a)
tryAllErrors err action = tryError action `UE.catch` (pure . Left . err)
{-# INLINE tryAllErrors #-}
tryAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> m (Either e a)
tryAllErrors' err action = runExceptT action `UE.catch` (pure . Left . err)
{-# INLINE tryAllErrors' #-}
catchAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> (e -> m a) -> m a
catchAllErrors err action handler = tryAllErrors err action >>= either handler pure
{-# INLINE catchAllErrors #-}
@@ -114,12 +113,12 @@ catchAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a ->
catchAllErrors' err action handler = tryAllErrors' err action >>= either handler pure
{-# INLINE catchAllErrors' #-}
catchThrow :: MonadUnliftIO m => ExceptT e m a -> (E.SomeException -> e) -> ExceptT e m a
catchThrow action err = catchAllErrors err action throwE
catchThrow :: (MonadUnliftIO m, MonadError e m) => m a -> (E.SomeException -> e) -> m a
catchThrow action err = catchAllErrors err action throwError
{-# INLINE catchThrow #-}
allFinally :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m b -> ExceptT e m a
allFinally err action final = tryAllErrors err action >>= \r -> final >> either throwE pure r
allFinally :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m b -> m a
allFinally err action final = tryAllErrors err action >>= \r -> final >> either throwError pure r
{-# INLINE allFinally #-}
eitherToMaybe :: Either a b -> Maybe b
@@ -150,7 +149,7 @@ safeDecodeUtf8 = decodeUtf8With onError
onError _ _ = Just '?'
timeoutThrow :: MonadUnliftIO m => e -> Int -> ExceptT e m a -> ExceptT e m a
timeoutThrow e ms action = ExceptT (sequence <$> (ms `timeout` runExceptT action)) >>= maybe (throwE e) pure
timeoutThrow e ms action = ExceptT (sequence <$> (ms `timeout` runExceptT action)) >>= maybe (throwError e) pure
threadDelay' :: Int64 -> IO ()
threadDelay' = loop
+18 -21
View File
@@ -30,7 +30,6 @@ import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson as J
import Data.ByteString (ByteString)
@@ -107,9 +106,9 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
action <- liftIO $ runClient c r hostKeys
-- wait for the port to make invitation
portNum <- atomically $ readTMVar startedPort
signedInv@RCSignedInvitation {invitation} <- maybe (throwE RCETLSStartFailed) (liftIO . mkInvitation hostKeys address) portNum
signedInv@RCSignedInvitation {invitation} <- maybe (throwError RCETLSStartFailed) (liftIO . mkInvitation hostKeys address) portNum
when multicast $ case knownHost of
Nothing -> throwE RCENewController
Nothing -> throwError RCENewController
Just KnownHostPairing {hostDhPubKey} -> do
ann <- liftIO . async . runExceptT $ announceRC drg 60 idPrivKey hostDhPubKey hostKeys invitation
atomically $ putTMVar announcer ann
@@ -118,7 +117,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
findCtrlAddress :: ExceptT RCErrorType IO (NonEmpty RCCtrlAddress)
findCtrlAddress = do
found' <- liftIO $ getLocalAddress rcAddrPrefs_
maybe (throwE RCENoLocalAddress) pure $ L.nonEmpty found'
maybe (throwError RCENoLocalAddress) pure $ L.nonEmpty found'
mkClient :: IO RCHClient_
mkClient = do
startedPort <- newEmptyTMVarIO
@@ -212,10 +211,10 @@ prepareHostSession
let sharedKey = C.dh' dhPubKey dhPrivKey
helloBody <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encBody
hostHello@RCHostHello {v, ca, kem = kemPubKey} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody
unless (ca == tlsHostFingerprint) $ throwE RCEIdentity
unless (ca == tlsHostFingerprint) $ throwError RCEIdentity
(kemCiphertext, kemSharedKey) <- liftIO $ sntrup761Enc drg kemPubKey
let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
unless (isCompatible v supportedRCPVRange) $ throwE RCEVersion
unless (isCompatible v supportedRCPVRange) $ throwError RCEVersion
let keys = HostSessKeys {hybridKey, idPrivKey, sessPrivKey}
knownHost' <- updateKnownHost ca dhPubKey
let ctrlHello = RCCtrlHello {}
@@ -228,7 +227,7 @@ prepareHostSession
updateKnownHost :: C.KeyHash -> C.PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing
updateKnownHost ca hostDhPubKey = case knownHost_ of
Just h -> do
unless (hostFingerprint h == tlsHostFingerprint) . throwE $
unless (hostFingerprint h == tlsHostFingerprint) . throwError $
RCEInternal "TLS host CA is different from host pairing, should be caught in TLS handshake"
pure (h :: KnownHostPairing) {hostDhPubKey}
Nothing -> pure KnownHostPairing {hostFingerprint = ca, hostDhPubKey}
@@ -258,7 +257,7 @@ connectRCCtrl drg (RCVerifiedInvitation inv@RCInvitation {ca, idkey}) pairing_ h
pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, dhPrivKey, prevDhPrivKey = Nothing}
updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
updateCtrlPairing pairing@RCCtrlPairing {ctrlFingerprint, idPubKey, dhPrivKey = currDhPrivKey} = do
unless (ca == ctrlFingerprint && idPubKey == idkey) $ throwE RCEIdentity
unless (ca == ctrlFingerprint && idPubKey == idkey) $ throwError RCEIdentity
(_, dhPrivKey) <- atomically $ C.generateKeyPair drg
pure pairing {dhPrivKey, prevDhPrivKey = Just currDhPrivKey}
@@ -279,7 +278,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca,
clientCredentials <-
liftIO (genTLSCredentials drg caKey caCert) >>= \case
TLS.Credentials (creds : _) -> pure $ Just creds
_ -> throwE $ RCEInternal "genTLSCredentials must generate credentials"
_ -> throwError $ RCEInternal "genTLSCredentials must generate credentials"
let clientConfig = defaultTransportClientConfig {clientCredentials}
ExceptT . runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls@TLS {tlsBuffer, tlsContext} -> runExceptT $ do
-- pump socket to detect connection problems
@@ -304,13 +303,11 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca,
logDebug "Session ended"
catchRCError :: ExceptT RCErrorType IO a -> (RCErrorType -> ExceptT RCErrorType IO a) -> ExceptT RCErrorType IO a
catchRCError = catchAllErrors $ \e -> case fromException e of
Just (TLS.Terminated _ _ (TLS.Error_Protocol (_, _, TLS.UnknownCa))) -> RCEIdentity
_ -> RCEException $ show e
catchRCError = catchAllErrors (RCEException . show)
{-# INLINE catchRCError #-}
putRCError :: ExceptT RCErrorType IO a -> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a
a `putRCError` r = a `catchRCError` \e -> atomically (tryPutTMVar r $ Left e) >> throwE e
a `putRCError` r = a `catchRCError` \e -> atomically (tryPutTMVar r $ Left e) >> throwError e
sendRCPacket :: Encoding a => TLS -> a -> ExceptT RCErrorType IO ()
sendRCPacket tls pkt = do
@@ -320,7 +317,7 @@ sendRCPacket tls pkt = do
receiveRCPacket :: Encoding a => TLS -> ExceptT RCErrorType IO a
receiveRCPacket tls = do
b <- liftIO $ cGet tls xrcpBlockSize
when (B.length b /= xrcpBlockSize) $ throwE RCEBlockSize
when (B.length b /= xrcpBlockSize) $ throwError RCEBlockSize
b' <- liftEitherWith (const RCEBlockSize) $ C.unPad b
liftEitherWith RCESyntax $ smpDecode b'
@@ -332,7 +329,7 @@ prepareHostHello
hostAppInfo = do
logDebug "Preparing session"
case compatibleVersion v supportedRCPVRange of
Nothing -> throwE RCEVersion
Nothing -> throwError RCEVersion
Just (Compatible v') -> do
nonce <- liftIO . atomically $ C.randomCbNonce drg
(kemPubKey, kemPrivKey) <- liftIO $ sntrup761Keypair drg
@@ -358,7 +355,7 @@ prepareCtrlSession
pure CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey}
RCCtrlEncError {nonce, encMessage} -> do
message <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encMessage
throwE $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message
throwError $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message
-- * Multicast discovery
@@ -385,7 +382,7 @@ discoverRCCtrl subscribers pairings =
r@(_, RCVerifiedInvitation RCInvitation {host}) <- findRCCtrlPairing pairings encInvitation
case source of
SockAddrInet _ ha | THIPv4 (hostAddressToTuple ha) == host -> pure ()
_ -> throwE RCEInvitation
_ -> throwError RCEInvitation
pure r
where
loop :: ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a
@@ -395,8 +392,8 @@ findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErro
findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do
(pairing, signedInvStr) <- liftEither $ decrypt (L.toList pairings)
signedInv <- liftEitherWith RCESyntax $ strDecode signedInvStr
inv@(RCVerifiedInvitation RCInvitation {dh = invDh}) <- maybe (throwE RCEInvitation) pure $ verifySignedInvitation signedInv
unless (invDh == dhPubKey) $ throwE RCEInvitation
inv@(RCVerifiedInvitation RCInvitation {dh = invDh}) <- maybe (throwError RCEInvitation) pure $ verifySignedInvitation signedInv
unless (invDh == dhPubKey) $ throwError RCEInvitation
pure (pairing, inv)
where
decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString)
@@ -436,7 +433,7 @@ rcEncryptBody drg hybridKey s = do
rcDecryptBody :: KEMHybridSecret -> C.CbNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString
rcDecryptBody hybridKey nonce ct = do
let len = LB.length ct - 16
when (len < 0) $ throwE RCEDecrypt
when (len < 0) $ throwError RCEDecrypt
(ok, s) <- liftEitherWith (const RCEDecrypt) $ LC.kcbDecryptTailTag hybridKey nonce len ct
unless ok $ throwE RCEDecrypt
unless ok $ throwError RCEDecrypt
pure s
+1 -1
View File
@@ -123,7 +123,7 @@ instance StrEncoding RCSignedInvitation where
idsig <- requiredP sigs "idsig" $ parseAll strP
pure RCSignedInvitation {invitation, ssig, idsig}
signInvitation :: C.PrivateKey 'C.Ed25519 -> C.PrivateKey 'C.Ed25519 -> RCInvitation -> RCSignedInvitation
signInvitation :: C.PrivateKey C.Ed25519 -> C.PrivateKey C.Ed25519 -> RCInvitation -> RCSignedInvitation
signInvitation sKey idKey invitation = RCSignedInvitation {invitation, ssig, idsig}
where
uri = strEncode invitation
+616 -2
View File
@@ -7,17 +7,38 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module AgentTests (agentTests) where
import AgentTests.ConnectionRequestTests
import AgentTests.DoubleRatchetTests (doubleRatchetTests)
import AgentTests.FunctionalAPITests (functionalAPITests)
import AgentTests.FunctionalAPITests (functionalAPITests, inAnyOrder, pattern Msg, pattern Msg', pattern SENT)
import AgentTests.MigrationTests (migrationTests)
import AgentTests.NotificationTests (notificationTests)
import AgentTests.SQLiteTests (storeTests)
import Simplex.Messaging.Transport (ATransport (..))
import Control.Concurrent
import Control.Monad (forM_, when)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromJust)
import Data.Type.Equality
import GHC.Stack (withFrozenCallStack)
import Network.HTTP.Types (urlEncode)
import SMPAgentClient
import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
import Simplex.Messaging.Agent.Protocol hiding (CONF, INFO, MID, REQ, SENT)
import qualified Simplex.Messaging.Agent.Protocol as A
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ErrorType (..))
import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..))
import Simplex.Messaging.Util (bshow)
import System.Directory (removeFile)
import System.Timeout
import Test.Hspec
import Util
agentTests :: ATransport -> Spec
agentTests (ATransport t) = do
@@ -27,3 +48,596 @@ agentTests (ATransport t) = do
describe "Notification tests" $ notificationTests (ATransport t)
describe "SQLite store" storeTests
describe "Migration tests" migrationTests
describe "SMP agent protocol syntax" $ syntaxTests t
describe "Establishing duplex connection (via agent protocol)" $ do
skip "These tests are disabled because the agent does not work correctly with multiple connected TCP clients" $
describe "one agent" $ do
it "should connect via one server and one agent" $ do
smpAgentTest2_1_1 $ testDuplexConnection t
it "should connect via one server and one agent (random IDs)" $ do
smpAgentTest2_1_1 $ testDuplexConnRandomIds t
it "should connect via one server and 2 agents" $ do
smpAgentTest2_2_1 $ testDuplexConnection t
it "should connect via one server and 2 agents (random IDs)" $ do
smpAgentTest2_2_1 $ testDuplexConnRandomIds t
describe "should connect via 2 servers and 2 agents" $ do
pqMatrix2 t smpAgentTest2_2_2 testDuplexConnection'
describe "should connect via 2 servers and 2 agents (random IDs)" $ do
pqMatrix2 t smpAgentTest2_2_2 testDuplexConnRandomIds'
describe "Establishing connections via `contact connection`" $ do
describe "should connect via contact connection with one server and 3 agents" $ do
pqMatrix3 t smpAgentTest3 testContactConnection
describe "should connect via contact connection with one server and 2 agents (random IDs)" $ do
pqMatrix2NoInv t smpAgentTest2_2_1 testContactConnRandomIds
it "should support rejecting contact request" $ do
smpAgentTest2_2_1 $ testRejectContactRequest t
describe "Connection subscriptions" $ do
it "should connect via one server and one agent" $ do
smpAgentTest3_1_1 $ testSubscription t
it "should send notifications to client when server disconnects" $ do
smpAgentServerTest $ testSubscrNotification t
describe "Message delivery and server reconnection" $ do
describe "should deliver messages after losing server connection and re-connecting" $
pqMatrix2 t smpAgentTest2_2_2_needs_server testMsgDeliveryServerRestart
it "should connect to the server when server goes up if it initially was down" $ do
smpAgentTestN [] $ testServerConnectionAfterError t
it "should deliver pending messages after agent restarting" $ do
smpAgentTest1_1_1 $ testMsgDeliveryAgentRestart t
it "should concurrently deliver messages to connections without blocking" $ do
smpAgentTest2_2_1 $ testConcurrentMsgDelivery t
it "should deliver messages if one of connections has quota exceeded" $ do
smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t
it "should resume delivering messages after exceeding quota once all messages are received" $ do
smpAgentTest2_2_1 $ testResumeDeliveryQuotaExceeded t
type AEntityTransmission p e = (ACorrId, ConnId, ACommand p e)
type AEntityTransmissionOrError p e = (ACorrId, ConnId, Either AgentErrorType (ACommand p e))
tGetAgent :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
tGetAgent = tGetAgent'
tGetAgent' :: forall c e. (Transport c, AEntityI e) => c -> IO (AEntityTransmissionOrError 'Agent e)
tGetAgent' h = do
(corrId, connId, cmdOrErr) <- pGetAgent h
case cmdOrErr of
Right (APC e cmd) -> case testEquality e (sAEntity @e) of
Just Refl -> pure (corrId, connId, Right cmd)
_ -> error $ "unexpected command " <> show cmd
Left err -> pure (corrId, connId, Left err)
pGetAgent :: forall c. Transport c => c -> IO (ATransmissionOrError 'Agent)
pGetAgent h = do
(corrId, connId, cmdOrErr) <- tGet SAgent h
case cmdOrErr of
Right (APC _ CONNECT {}) -> pGetAgent h
Right (APC _ DISCONNECT {}) -> pGetAgent h
cmd -> pure (corrId, connId, cmd)
-- | receive message to handle `h`
(<#:) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
(<#:) = tGetAgent
(<#:?) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
(<#:?) = pGetAgent
(<#:.) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AENone)
(<#:.) = tGetAgent'
-- | send transmission `t` to handle `h` and get response
(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
h #: t = tPutRaw h t >> (<#:) h
-- | action and expected response
-- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r`
(#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> AEntityTransmission 'Agent 'AEConn -> Expectation
action #> (corrId, connId, cmd) = withFrozenCallStack $ action `shouldReturn` (corrId, connId, Right cmd)
-- | action and predicate for the response
-- `h #:t =#> p` is the test that sends `t` to `h` and validates the response using `p`
(=#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
action =#> p = withFrozenCallStack $ action >>= (`shouldSatisfy` p . correctTransmission)
pattern MID :: AgentMsgId -> ACommand 'Agent 'AEConn
pattern MID msgId = A.MID msgId PQEncOn
correctTransmission :: (ACorrId, ConnId, Either AgentErrorType cmd) -> (ACorrId, ConnId, cmd)
correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of
Right cmd -> (corrId, connId, cmd)
Left e -> error $ show e
-- | receive message to handle `h` and validate that it is the expected one
(<#) :: (HasCallStack, Transport c) => c -> AEntityTransmission 'Agent 'AEConn -> Expectation
h <# (corrId, connId, cmd) = timeout 5000000 (h <#:) `shouldReturn` Just (corrId, connId, Right cmd)
(<#.) :: (HasCallStack, Transport c) => c -> AEntityTransmission 'Agent 'AENone -> Expectation
h <#. (corrId, connId, cmd) = timeout 5000000 (h <#:.) `shouldReturn` Just (corrId, connId, Right cmd)
-- | receive message to handle `h` and validate it using predicate `p`
(<#=) :: (HasCallStack, Transport c) => c -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
h <#= p = timeout 5000000 (h <#:) >>= (`shouldSatisfy` p . correctTransmission . fromJust)
(<#=?) :: (HasCallStack, Transport c) => c -> (ATransmission 'Agent -> Bool) -> Expectation
h <#=? p = timeout 5000000 (h <#:?) >>= (`shouldSatisfy` p . correctTransmission . fromJust)
-- | test that nothing is delivered to handle `h` during 10ms
(#:#) :: Transport c => c -> String -> Expectation
h #:# err = tryGet `shouldReturn` ()
where
tryGet =
10000 `timeout` tGetAgent h >>= \case
Just _ -> error err
_ -> return ()
type PQMatrix2 c =
HasCallStack =>
TProxy c ->
(HasCallStack => (c -> c -> IO ()) -> Expectation) ->
(HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> IO ()) ->
Spec
pqMatrix2 :: PQMatrix2 c
pqMatrix2 = pqMatrix2_ True
pqMatrix2NoInv :: PQMatrix2 c
pqMatrix2NoInv = pqMatrix2_ False
pqMatrix2_ :: Bool -> PQMatrix2 c
pqMatrix2_ pqInv _ smpTest test = do
it "dh/dh handshake" $ smpTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff)
it "dh/pq handshake" $ smpTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn)
it "pq/dh handshake" $ smpTest $ \a b -> test (a, IKPQOn) (b, PQSupportOff)
it "pq/pq handshake" $ smpTest $ \a b -> test (a, IKPQOn) (b, PQSupportOn)
when pqInv $ do
it "pq-inv/dh handshake" $ smpTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff)
it "pq-inv/pq handshake" $ smpTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn)
pqMatrix3 ::
HasCallStack =>
TProxy c ->
(HasCallStack => (c -> c -> c -> IO ()) -> Expectation) ->
(HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()) ->
Spec
pqMatrix3 _ smpTest test = do
it "dh" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff)
it "dh/dh/pq" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOn)
it "dh/pq/dh" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOff)
it "dh/pq/pq" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOn)
it "pq/dh/dh" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOff)
it "pq/dh/pq" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOn)
it "pq/pq/dh" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOff)
it "pq" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn)
testDuplexConnection :: (HasCallStack, Transport c) => TProxy c -> c -> c -> IO ()
testDuplexConnection _ alice bob = testDuplexConnection' (alice, IKPQOn) (bob, PQSupportOn)
testDuplexConnection' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testDuplexConnection' (alice, aPQ) (bob, bPQ) = do
let pq = pqConnectionMode aPQ bPQ
("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
("", "bob", Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:)
pqSup' `shouldBe` CR.connPQEncryption aPQ
alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
bob <# ("", "alice", A.INFO bPQ "alice's connInfo")
bob <# ("", "alice", CON pq)
alice <# ("", "bob", CON pq)
-- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
alice #: ("3", "bob", "SEND F :hello") #> ("3", "bob", A.MID 4 pq)
alice <# ("", "bob", SENT 4)
bob <#= \case ("", "alice", Msg' 4 pq' "hello") -> pq == pq'; _ -> False
bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)
alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", A.MID 5 pq)
alice <# ("", "bob", SENT 5)
bob <#= \case ("", "alice", Msg' 5 pq' "how are you?") -> pq == pq'; _ -> False
bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", A.MID 6 pq)
bob <# ("", "alice", SENT 6)
alice <#= \case ("", "bob", Msg' 6 pq' "hello too") -> pq == pq'; _ -> False
alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)
bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", A.MID 7 pq)
bob <# ("", "alice", SENT 7)
alice <#= \case ("", "bob", Msg' 7 pq' "message 1") -> pq == pq'; _ -> False
alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)
alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", A.MID 8 pq)
bob <#= \case ("", "alice", MERR 8 (SMP _ AUTH)) -> True; _ -> False
alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
alice #:# "nothing else should be delivered to alice"
testDuplexConnRandomIds :: (HasCallStack, Transport c) => TProxy c -> c -> c -> IO ()
testDuplexConnRandomIds _ alice bob = testDuplexConnRandomIds' (alice, IKPQOn) (bob, PQSupportOn)
testDuplexConnRandomIds' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testDuplexConnRandomIds' (alice, aPQ) (bob, bPQ) = do
let pq = pqConnectionMode aPQ bPQ
("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo")
("", bobConn', Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:)
pqSup' `shouldBe` CR.connPQEncryption aPQ
bobConn' `shouldBe` bobConn
alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
bob <# ("", aliceConn, A.INFO bPQ "alice's connInfo")
bob <# ("", aliceConn, CON pq)
alice <# ("", bobConn, CON pq)
alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, A.MID 4 pq)
alice <# ("", bobConn, SENT 4)
bob <#= \case ("", c, Msg' 4 pq' "hello") -> c == aliceConn && pq == pq'; _ -> False
bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK)
alice #: ("3", bobConn, "SEND F :how are you?") #> ("3", bobConn, A.MID 5 pq)
alice <# ("", bobConn, SENT 5)
bob <#= \case ("", c, Msg' 5 pq' "how are you?") -> c == aliceConn && pq == pq'; _ -> False
bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
bob #: ("14", aliceConn, "SEND F 9\nhello too") #> ("14", aliceConn, A.MID 6 pq)
bob <# ("", aliceConn, SENT 6)
alice <#= \case ("", c, Msg' 6 pq' "hello too") -> c == bobConn && pq == pq'; _ -> False
alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK)
bob #: ("15", aliceConn, "SEND F 9\nmessage 1") #> ("15", aliceConn, A.MID 7 pq)
bob <# ("", aliceConn, SENT 7)
alice <#= \case ("", c, Msg' 7 pq' "message 1") -> c == bobConn && pq == pq'; _ -> False
alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK)
alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
bob #: ("17", aliceConn, "SEND F 9\nmessage 3") #> ("17", aliceConn, A.MID 8 pq)
bob <#= \case ("", cId, MERR 8 (SMP _ AUTH)) -> cId == aliceConn; _ -> False
alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
alice #:# "nothing else should be delivered to alice"
testContactConnection :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()
testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do
("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
abPQ = pqConnectionMode aPQ bPQ
aPQMode = CR.connPQEncryption aPQ
bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
("", "alice_contact", Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:)
alice #: ("2", "bob", "ACPT " <> aInvId <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("2", "bob", OK)
("", "alice", Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:)
pqSup'' `shouldBe` bPQ
bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
alice <# ("", "bob", A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2")
alice <# ("", "bob", CON abPQ)
bob <# ("", "alice", CON abPQ)
alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", A.MID 4 abPQ)
alice <# ("", "bob", SENT 4)
bob <#= \case ("", "alice", Msg' 4 pq' "hi") -> pq' == abPQ; _ -> False
bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
let atPQ = pqConnectionMode aPQ tPQ
tom #: ("21", "alice", "JOIN T " <> cReq' <> enableKEMStr tPQ <> " subscribe 14\ntom's connInfo") #> ("21", "alice", OK)
("", "alice_contact", Right (A.REQ aInvId' PQSupportOn _ "tom's connInfo")) <- (alice <#:)
alice #: ("4", "tom", "ACPT " <> aInvId' <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("4", "tom", OK)
("", "alice", Right (A.CONF tConfId pqSup4 _ "alice's connInfo")) <- (tom <#:)
pqSup4 `shouldBe` tPQ
tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
alice <# ("", "tom", A.INFO (CR.connPQEncryption aPQ) "tom's connInfo 2")
alice <# ("", "tom", CON atPQ)
tom <# ("", "alice", CON atPQ)
alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", A.MID 4 atPQ)
alice <# ("", "tom", SENT 4)
tom <#= \case ("", "alice", Msg' 4 pq' "hi there") -> pq' == atPQ; _ -> False
tom #: ("23", "alice", "ACK 4") #> ("23", "alice", OK)
testContactConnRandomIds :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testContactConnRandomIds (alice, aPQ) (bob, bPQ) = do
let pq = pqConnectionMode aPQ bPQ
("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo")
("", aliceContact', Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:)
aliceContact' `shouldBe` aliceContact
("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> enableKEMStr (CR.connPQEncryption aPQ) <> " 16\nalice's connInfo")
("", aliceConn', Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:)
pqSup'' `shouldBe` bPQ
aliceConn' `shouldBe` aliceConn
bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
alice <# ("", bobConn, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2")
alice <# ("", bobConn, CON pq)
bob <# ("", aliceConn, CON pq)
alice #: ("3", bobConn, "SEND F :hi") #> ("3", bobConn, A.MID 4 pq)
alice <# ("", bobConn, SENT 4)
bob <#= \case ("", c, Msg' 4 pq' "hi") -> c == aliceConn && pq == pq'; _ -> False
bob #: ("13", aliceConn, "ACK 4") #> ("13", aliceConn, OK)
testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
testRejectContactRequest _ alice bob = do
("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON subscribe")
let cReq' = strEncode cReq
bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 10\nbob's info") #> ("11", "alice", OK)
("", "a_contact", Right (A.REQ aInvId PQSupportOn _ "bob's info")) <- (alice <#:)
-- RJCT must use correct contact connection
alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
alice #: ("3", "bob", "ACPT " <> aInvId <> " 12\nalice's info") #> ("3", "bob", ERR $ A.CMD PROHIBITED)
bob #:# "nothing should be delivered to bob"
testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
testSubscription _ alice1 alice2 bob = do
(alice1, "alice") `connect` (bob, "bob")
bob #: ("12", "alice", "SEND F 5\nhello") #> ("12", "alice", MID 4)
bob <# ("", "alice", SENT 4)
alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
alice1 #: ("1", "bob", "ACK 4") #> ("1", "bob", OK)
bob #: ("13", "alice", "SEND F 11\nhello again") #> ("13", "alice", MID 5)
bob <# ("", "alice", SENT 5)
alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
alice1 #: ("2", "bob", "ACK 5") #> ("2", "bob", OK)
alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
alice1 <# ("", "bob", END)
bob #: ("14", "alice", "SEND F 2\nhi") #> ("14", "alice", MID 6)
bob <# ("", "alice", SENT 6)
alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
alice2 #: ("22", "bob", "ACK 6") #> ("22", "bob", OK)
alice1 #:# "nothing else should be delivered to alice1"
testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
testSubscrNotification t (server, _) client = do
client #: ("1", "conn1", "NEW T INV subscribe") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
client #:# "nothing should be delivered to client before the server is killed"
killThread server
client <#. ("", "", DOWN testSMPServer ["conn1"])
withSmpServer (ATransport t) $
client <#= \case ("", "conn1", ERR (SMP _ AUTH)) -> True; _ -> False -- this new server does not have the queue
testMsgDeliveryServerRestart :: forall c. Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testMsgDeliveryServerRestart (alice, aPQ) (bob, bPQ) = do
let pq = pqConnectionMode aPQ bPQ
withServer $ do
connect' (alice, "alice", aPQ) (bob, "bob", bPQ)
bob #: ("1", "alice", "SEND F 2\nhi") #> ("1", "alice", A.MID 4 pq)
bob <# ("", "alice", SENT 4)
alice <#= \case ("", "bob", Msg' _ pq' "hi") -> pq == pq'; _ -> False
alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)
alice #:# "nothing else delivered before the server is killed"
let server = SMPServer "localhost" testPort2 testKeyHash
alice <#. ("", "", DOWN server ["bob"])
bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", A.MID 5 pq)
bob #:# "nothing else delivered before the server is restarted"
alice #:# "nothing else delivered before the server is restarted"
withServer $ do
bob <# ("", "alice", SENT 5)
alice <#. ("", "", UP server ["bob"])
alice <#= \case ("", "bob", Msg' _ pq' "hello again") -> pq == pq'; _ -> False
alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
removeFile testStoreLogFile
where
withServer test' = withSmpServerStoreLogOn (transport @c) testPort2 (const test') `shouldReturn` ()
testServerConnectionAfterError :: forall c. Transport c => TProxy c -> [c] -> IO ()
testServerConnectionAfterError t _ = do
withAgent1 $ \bob -> do
withAgent2 $ \alice -> do
withServer $ do
connect (bob, "bob") (alice, "alice")
bob <#. ("", "", DOWN server ["alice"])
alice <#. ("", "", DOWN server ["bob"])
alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
alice #:# "nothing else delivered before the server is restarted"
bob #:# "nothing else delivered before the server is restarted"
withAgent1 $ \bob -> do
withAgent2 $ \alice -> do
bob #: ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
alice #: ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
withServer $ do
alice <#=? \case ("", "bob", APC SAEConn (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
alice <#=? \case ("", "bob", APC SAEConn (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5)
alice <# ("", "bob", SENT 5)
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
removeFile testStoreLogFile
removeFile testDB
removeFile testDB2
where
server = SMPServer "localhost" testPort2 testKeyHash
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
withAgent1 = withAgent agentTestPort testDB 0
withAgent2 = withAgent agentTestPort2 testDB2 10
withAgent :: String -> FilePath -> Int -> (c -> IO a) -> IO a
withAgent agentPort agentDB initClientId = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) initClientId (pure ()) . const . testSMPAgentClientOn agentPort
testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
testMsgDeliveryAgentRestart t bob = do
let server = SMPServer "localhost" testPort2 testKeyHash
withAgent $ \alice -> do
withServer $ do
connect (bob, "bob") (alice, "alice")
alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
alice <# ("", "bob", SENT 4)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK)
bob #:# "nothing else delivered before the server is down"
bob <#. ("", "", DOWN server ["alice"])
alice #: ("2", "bob", "SEND F 11\nhello again") #> ("2", "bob", MID 5)
alice #:# "nothing else delivered before the server is restarted"
bob #:# "nothing else delivered before the server is restarted"
withAgent $ \alice -> do
withServer $ do
tPutRaw alice ("3", "bob", "SUB")
alice <#= \case
(corrId, "bob", cmd) ->
(corrId == "3" && cmd == OK)
|| (corrId == "" && cmd == SENT 5)
_ -> False
bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
removeFile testStoreLogFile
removeFile testDB
where
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) 0 (pure ()) . const . testSMPAgentClientOn agentTestPort
testConcurrentMsgDelivery :: Transport c => TProxy c -> c -> c -> IO ()
testConcurrentMsgDelivery _ alice bob = do
connect (alice, "alice") (bob, "bob")
("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW T INV subscribe")
let cReq' = strEncode cReq
bob #: ("11", "alice2", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") #> ("11", "alice2", OK)
("", "bob2", Right (A.CONF _confId PQSupportOff _ "bob's connInfo")) <- (alice <#:)
-- below commands would be needed to accept bob's connection, but alice does not
-- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
-- bob <# ("", "alice", INFO "alice's connInfo")
-- bob <# ("", "alice", CON)
-- alice <# ("", "bob", CON)
-- the first connection should not be blocked by the second one
sendMessage (alice, "alice") (bob, "bob") "hello"
-- alice #: ("2", "bob", "SEND F :hello") #> ("2", "bob", MID 1)
-- alice <# ("", "bob", SENT 1)
-- bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-- bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 5)
bob <# ("", "alice", SENT 5)
-- if delivery is blocked it won't go further
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
alice #: ("3", "bob", "ACK 5") #> ("3", "bob", OK)
testMsgDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
testMsgDeliveryQuotaExceeded _ alice bob = do
connect (alice, "alice") (bob, "bob")
connect (alice, "alice2") (bob, "bob2")
forM_ [1 .. 4 :: Int] $ \i -> do
let corrId = bshow i
msg = "message " <> bshow i
(_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND F :" <> msg)
alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
(_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND F :over quota")
alice #: ("1", "bob2", "SEND F :hello") #> ("1", "bob2", MID 4)
-- if delivery is blocked it won't go further
alice <# ("", "bob2", SENT 4)
testResumeDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
testResumeDeliveryQuotaExceeded _ alice bob = do
connect (alice, "alice") (bob, "bob")
forM_ [1 .. 4 :: Int] $ \i -> do
let corrId = bshow i
msg = "message " <> bshow i
(_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND F :" <> msg)
alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
("5", "bob", Right (MID 8)) <- alice #: ("5", "bob", "SEND F :over quota")
alice #:# "the last message not sent yet"
bob <#= \case ("", "alice", Msg "message 1") -> True; _ -> False
bob #: ("1", "alice", "ACK 4") #> ("1", "alice", OK)
alice #:# "the last message not sent"
bob <#= \case ("", "alice", Msg "message 2") -> True; _ -> False
bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK)
alice #:# "the last message not sent"
bob <#= \case ("", "alice", Msg "message 3") -> True; _ -> False
bob #: ("3", "alice", "ACK 6") #> ("3", "alice", OK)
alice #:# "the last message not sent"
bob <#= \case ("", "alice", Msg "message 4") -> True; _ -> False
bob #: ("4", "alice", "ACK 7") #> ("4", "alice", OK)
inAnyOrder
(tGetAgent alice)
[ \case ("", c, Right (SENT 8)) -> c == "bob"; _ -> False,
\case ("", c, Right QCONT) -> c == "bob"; _ -> False
]
bob <#= \case ("", "alice", Msg "over quota") -> True; _ -> False
-- message 8 is skipped because of alice agent sending "QCONT" message
bob #: ("5", "alice", "ACK 9") #> ("5", "alice", OK)
connect :: Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
connect (h1, name1) (h2, name2) = connect' (h1, name1, IKPQOn) (h2, name2, PQSupportOn)
connect' :: forall c. Transport c => (c, ByteString, InitialKeys) -> (c, ByteString, PQSupport) -> IO ()
connect' (h1, name1, pqMode1) (h2, name2, pqMode2) = do
("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV" <> pqConnModeStr pqMode1 <> " subscribe")
let cReq' = strEncode cReq
pq = pqConnectionMode pqMode1 pqMode2
h2 #: ("c2", name1, "JOIN T " <> cReq' <> enableKEMStr pqMode2 <> " subscribe 5\ninfo2") #> ("c2", name1, OK)
("", _, Right (A.CONF connId pqSup' _ "info2")) <- (h1 <#:)
pqSup' `shouldBe` CR.connPQEncryption pqMode1
h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
h2 <# ("", name1, A.INFO pqMode2 "info1")
h2 <# ("", name1, CON pq)
h1 <# ("", name2, CON pq)
pqConnectionMode :: InitialKeys -> PQSupport -> PQEncryption
pqConnectionMode pqMode1 pqMode2 = PQEncryption $ supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2
enableKEMStr :: PQSupport -> ByteString
enableKEMStr PQSupportOn = " " <> strEncode PQSupportOn
enableKEMStr _ = ""
pqConnModeStr :: InitialKeys -> ByteString
pqConnModeStr (IKNoPQ PQSupportOff) = ""
pqConnModeStr pq = " " <> strEncode pq
sendMessage :: Transport c => (c, ConnId) -> (c, ConnId) -> ByteString -> IO ()
sendMessage (h1, name1) (h2, name2) msg = do
("m1", name2', Right (MID mId)) <- h1 #: ("m1", name2, "SEND F :" <> msg)
name2' `shouldBe` name2
h1 <#= \case ("", n, SENT m) -> n == name2 && m == mId; _ -> False
("", name1', Right (MSG MsgMeta {recipient = (msgId', _)} _ msg')) <- (h2 <#:)
name1' `shouldBe` name1
msg' `shouldBe` msg
h2 #: ("m2", name1, "ACK " <> bshow msgId') =#> \case ("m2", n, OK) -> n == name1; _ -> False
-- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString)
-- connect' h1 h2 = do
-- ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW T INV subscribe")
-- let cReq' = strEncode cReq
-- ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN T " <> cReq' <> " subscribe 5\ninfo2")
-- ("", _, Right (REQ connId _ "info2")) <- (h1 <#:)
-- h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False
-- h2 <# ("", conn1, INFO "info1")
-- h2 <# ("", conn1, CON)
-- h1 <# ("", conn2, CON)
-- pure (conn1, conn2)
sampleDhKey :: ByteString
sampleDhKey = "MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
syntaxTests :: forall c. Transport c => TProxy c -> Spec
syntaxTests t = do
it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX")
describe "NEW" $ do
describe "valid" $ do
it "with correct parameter" $ ("211", "", "NEW T INV subscribe") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
describe "invalid" $ do
it "with incorrect parameter" $ ("222", "", "NEW T hi subscribe") >#> ("222", "", "ERR CMD SYNTAX")
describe "JOIN" $ do
describe "valid" $ do
it "using same server as in invitation" $
( "311",
"a",
"JOIN T https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
<> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
<> "%40localhost%3A5001%2F3456-w%3D%3D%23"
<> urlEncode True sampleDhKey
<> "&v=2"
<> "&e2e=v%3D2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> " subscribe "
<> "14\nbob's connInfo"
)
>#> ("311", "a", "ERR SMP smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001 AUTH")
describe "invalid" $ do
it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX")
where
-- simple test for one command with the expected response
(>#>) :: ARawTransmission -> ARawTransmission -> Expectation
command >#> response = withFrozenCallStack $ smpAgentTest t command `shouldReturn` response
-- simple test for one command with a predicate for the expected response
(>#>=) :: ARawTransmission -> ((ByteString, ByteString, [ByteString]) -> Bool) -> Expectation
command >#>= p = withFrozenCallStack $ smpAgentTest t command >>= (`shouldSatisfy` p . \(cId, connId, cmd) -> (cId, connId, B.words cmd))
-5
View File
@@ -6,7 +6,6 @@ module AgentTests.EqInstances where
import Data.Type.Equality
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Client (ProxiedRelay (..))
instance Eq SomeConn where
SomeConn d c == SomeConn d' c' = case testEquality d d' of
@@ -24,7 +23,3 @@ deriving instance Eq (StoredSndQueue q)
deriving instance Eq (DBQueueId q)
deriving instance Eq ClientNtfCreds
deriving instance Show ProxiedRelay
deriving instance Eq ProxiedRelay
+127 -383
View File
@@ -1,9 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
@@ -14,6 +12,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module AgentTests.FunctionalAPITests
( functionalAPITests,
@@ -56,8 +55,6 @@ import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.Bifunctor (first)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (isRight)
@@ -67,10 +64,9 @@ import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as M
import Data.Maybe (isJust, isNothing)
import qualified Data.Set as S
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Type.Equality (testEquality, (:~:) (Refl))
import Data.Type.Equality
import Data.Word (Word16)
import qualified Database.SQLite.Simple as SQL
import GHC.Stack (withFrozenCallStack)
@@ -82,11 +78,12 @@ import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestSte
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore)
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT)
import qualified Simplex.Messaging.Agent.Protocol as A
import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..))
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Transport (NTFVersion, authBatchCmdsNTFVersion, pattern VersionNTF)
@@ -94,9 +91,8 @@ import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolS
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, supportedSMPHandshakes)
import Simplex.Messaging.Util (bshow, diffToMicroseconds)
import Simplex.Messaging.Util (diffToMicroseconds)
import Simplex.Messaging.Version (VersionRange (..))
import qualified Simplex.Messaging.Version as V
import Simplex.Messaging.Version.Internal (Version (..))
@@ -106,15 +102,12 @@ import UnliftIO
import Util
import XFTPClient (testXFTPServer)
type AEntityTransmission e = (ACorrId, ConnId, AEvent e)
type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e)
-- deriving instance Eq (ValidFileDescription p)
shouldRespond :: (HasCallStack, MonadUnliftIO m, Eq a, Show a) => m a -> a -> m ()
a `shouldRespond` r = withFrozenCallStack $ withTimeout a (`shouldBe` r)
(##>) :: (HasCallStack, MonadUnliftIO m) => m (AEntityTransmission e) -> AEntityTransmission e -> m ()
a ##> t = a `shouldRespond` t
a ##> t = withTimeout a (`shouldBe` t)
(=##>) :: (Show a, HasCallStack, MonadUnliftIO m) => m a -> (HasCallStack => a -> Bool) -> m ()
a =##> p =
@@ -142,54 +135,47 @@ nGet c = withFrozenCallStack $ get' @'AENone c
get' :: forall e m. (MonadIO m, AEntityI e, HasCallStack) => AgentClient -> m (AEntityTransmission e)
get' c = withFrozenCallStack $ do
(corrId, connId, AEvt e cmd) <- pGet c
(corrId, connId, APC e cmd) <- pGet c
case testEquality e (sAEntity @e) of
Just Refl -> pure (corrId, connId, cmd)
_ -> error $ "unexpected command " <> show cmd
pGet :: forall m. MonadIO m => AgentClient -> m ATransmission
pGet c = pGet' c True
pGet' :: forall m. MonadIO m => AgentClient -> Bool -> m ATransmission
pGet' c skipWarn = do
t@(_, _, AEvt _ cmd) <- atomically (readTBQueue $ subQ c)
pGet :: forall m. MonadIO m => AgentClient -> m (ATransmission 'Agent)
pGet c = do
t@(_, _, APC _ cmd) <- atomically (readTBQueue $ subQ c)
case cmd of
CONNECT {} -> pGet c
DISCONNECT {} -> pGet c
ERR (BROKER _ NETWORK) -> pGet c
MWARN {} | skipWarn -> pGet c
RFWARN {} | skipWarn -> pGet c
SFWARN {} | skipWarn -> pGet c
_ -> pure t
pattern CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> AEvent e
pattern CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand 'Agent e
pattern CONF conId srvs connInfo <- A.CONF conId PQSupportOn srvs connInfo
pattern INFO :: ConnInfo -> AEvent 'AEConn
pattern INFO :: ConnInfo -> ACommand 'Agent 'AEConn
pattern INFO connInfo = A.INFO PQSupportOn connInfo
pattern REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> AEvent e
pattern REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> ACommand 'Agent e
pattern REQ invId srvs connInfo <- A.REQ invId PQSupportOn srvs connInfo
pattern CON :: AEvent 'AEConn
pattern CON :: ACommand 'Agent 'AEConn
pattern CON = A.CON PQEncOn
pattern Msg :: MsgBody -> AEvent e
pattern Msg :: MsgBody -> ACommand 'Agent e
pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk, pqEncryption = PQEncOn} _ msgBody
pattern Msg' :: AgentMsgId -> PQEncryption -> MsgBody -> AEvent e
pattern Msg' :: AgentMsgId -> PQEncryption -> MsgBody -> ACommand 'Agent e
pattern Msg' aMsgId pq msgBody <- MSG MsgMeta {integrity = MsgOk, recipient = (aMsgId, _), pqEncryption = pq} _ msgBody
pattern MsgErr :: AgentMsgId -> MsgErrorType -> MsgBody -> AEvent 'AEConn
pattern MsgErr :: AgentMsgId -> MsgErrorType -> MsgBody -> ACommand 'Agent 'AEConn
pattern MsgErr msgId err msgBody <- MSG MsgMeta {recipient = (msgId, _), integrity = MsgError err} _ msgBody
pattern MsgErr' :: AgentMsgId -> MsgErrorType -> PQEncryption -> MsgBody -> AEvent 'AEConn
pattern MsgErr' :: AgentMsgId -> MsgErrorType -> PQEncryption -> MsgBody -> ACommand 'Agent 'AEConn
pattern MsgErr' msgId err pq msgBody <- MSG MsgMeta {recipient = (msgId, _), integrity = MsgError err, pqEncryption = pq} _ msgBody
pattern SENT :: AgentMsgId -> AEvent 'AEConn
pattern SENT :: AgentMsgId -> ACommand 'Agent 'AEConn
pattern SENT msgId = A.SENT msgId Nothing
pattern Rcvd :: AgentMsgId -> AEvent 'AEConn
pattern Rcvd :: AgentMsgId -> ACommand 'Agent 'AEConn
pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}]
smpCfgVPrev :: ProtocolClientConfig SMPVersion
@@ -239,7 +225,7 @@ mkVersionRange :: Word16 -> Word16 -> VersionRange v
mkVersionRange v1 v2 = V.mkVersionRange (Version v1) (Version v2)
runRight_ :: (Eq e, Show e, HasCallStack) => ExceptT e IO () -> Expectation
runRight_ action = withFrozenCallStack $ runExceptT action `shouldReturn` Right ()
runRight_ action = runExceptT action `shouldReturn` Right ()
runRight :: (Show e, HasCallStack) => ExceptT e IO a -> IO a
runRight action =
@@ -247,13 +233,13 @@ runRight action =
Right x -> pure x
Left e -> error $ "Unexpected error: " <> show e
getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission -> Bool] -> Expectation
getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission 'Agent -> Bool] -> Expectation
getInAnyOrder c ts = withFrozenCallStack $ inAnyOrder (pGet c) ts
inAnyOrder :: (Show a, MonadUnliftIO m, HasCallStack) => m a -> [a -> Bool] -> m ()
inAnyOrder :: (Show a, MonadIO m, HasCallStack) => m a -> [a -> Bool] -> m ()
inAnyOrder _ [] = pure ()
inAnyOrder g rs = withFrozenCallStack $ do
r <- 5000000 `timeout` g >>= maybe (error "inAnyOrder timeout") pure
r <- g
let rest = filter (not . expected r) rs
if length rest < length rs
then inAnyOrder g rest
@@ -284,20 +270,12 @@ functionalAPITests t = do
withSmpServer t testAgentClient3
it "should establish connection without PQ encryption and enable it" $
withSmpServer t testEnablePQEncryption
describe "Establishing duplex connection, different PQ settings" $ do
testPQMatrix2 t $ runAgentClientTestPQ True
describe "Establishing duplex connection v2, different Ratchet versions" $
testRatchetMatrix2 t runAgentClientTest
describe "Establish duplex connection via contact address" $
testMatrix2 t runAgentClientContactTest
describe "Establish duplex connection via contact address, different PQ settings" $ do
testPQMatrix2NoInv t $ runAgentClientContactTestPQ True PQSupportOn
describe "Establish duplex connection via contact address v2, different Ratchet versions" $
testRatchetMatrix2 t runAgentClientContactTest
describe "Establish duplex connection via contact address, different PQ settings" $ do
testPQMatrix3 t $ runAgentClientContactTestPQ3 True
it "should support rejecting contact request" $
withSmpServer t testRejectContactRequest
describe "Establishing connection asynchronously" $ do
it "should connect with initiating client going offline" $
withSmpServer t testAsyncInitiatingOffline
@@ -324,10 +302,6 @@ functionalAPITests t = do
testDuplicateMessage t
it "should report error via msg integrity on skipped messages" $
testSkippedMessages t
it "should connect to the server when server goes up if it initially was down" $
testDeliveryAfterSubscriptionError t
it "should deliver messages if one of connections has quota exceeded" $
testMsgDeliveryQuotaExceeded t
describe "message expiration" $ do
it "should expire one message" $ testExpireMessage t
it "should expire multiple messages" $ testExpireManyMessages t
@@ -465,11 +439,8 @@ functionalAPITests t = do
it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent t
describe "user network info" $ do
it "should wait for user network" testWaitForUserNetwork
it "should not reset online to offline if happens too quickly" testDoNotResetOnlineToOffline
it "should not reset offline interval while offline" testDoNotResetOfflineInterval
it "should resume multiple threads" testResumeMultipleThreads
describe "SMP queue info" $ do
it "server should respond with queue and subscription information" $
withSmpServer t testServerQueueInfo
testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> IO Int
testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do
@@ -489,7 +460,7 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) =
let v = basicAuthSMPVersion
in allowNew && (isNothing srvAuth || (srvVersion >= v && clntVersion >= v && srvAuth == clntAuth))
testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testMatrix2 :: ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testMatrix2 t runTest = do
it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True
it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn False
@@ -501,7 +472,7 @@ testMatrix2 t runTest = do
it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False
it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False
testRatchetMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testRatchetMatrix2 :: ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testRatchetMatrix2 t runTest = do
it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True
it "ratchet next" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn False
@@ -512,50 +483,11 @@ testRatchetMatrix2 t runTest = do
it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 3 $ runTest PQSupportOff False
it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 3 $ runTest PQSupportOff False
testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec
testServerMatrix2 :: ATransport -> (InitialAgentServers -> IO ()) -> Spec
testServerMatrix2 t runTest = do
it "1 server" $ withSmpServer t $ runTest initAgentServers
it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2
testPQMatrix2 :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
testPQMatrix2 = pqMatrix2_ True
testPQMatrix2NoInv :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
testPQMatrix2NoInv = pqMatrix2_ False
pqMatrix2_ :: HasCallStack => Bool -> ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
pqMatrix2_ pqInv t test = do
it "dh/dh handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff)
it "dh/pq handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn)
it "pq/dh handshake" $ runTest $ \a b -> test (a, IKPQOn) (b, PQSupportOff)
it "pq/pq handshake" $ runTest $ \a b -> test (a, IKPQOn) (b, PQSupportOn)
when pqInv $ do
it "pq-inv/dh handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff)
it "pq-inv/pq handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn)
where
runTest = withSmpServerProxy t . runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3
testPQMatrix3 ::
HasCallStack =>
ATransport ->
(HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) ->
Spec
testPQMatrix3 t test = do
it "dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff)
it "dh/dh/pq" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOn)
it "dh/pq/dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOff)
it "dh/pq/pq" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOn)
it "pq/dh/dh" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOff)
it "pq/dh/pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOn)
it "pq/pq/dh" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOff)
it "pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn)
where
runTest test' =
withSmpServerProxy t $
runTestCfgServers2 agentProxyCfg agentProxyCfg servers 3 $ \a b baseMsgId ->
withAgent 3 agentProxyCfg servers testDB3 $ \c -> test' a b c baseMsgId
servers = initAgentServersProxy SPMAlways SPFProhibit
runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO ()
runTestCfg2 aCfg bCfg = runTestCfgServers2 aCfg bCfg initAgentServers
{-# INLINE runTestCfg2 #-}
@@ -565,17 +497,17 @@ runTestCfgServers2 aCfg bCfg servers baseMsgId runTest =
withAgentClientsCfgServers2 aCfg bCfg servers $ \a b -> runTest a b baseMsgId
{-# INLINE runTestCfgServers2 #-}
withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a
withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO ()
withAgentClientsCfgServers2 aCfg bCfg servers runTest =
withAgent 1 aCfg servers testDB $ \a ->
withAgent 2 bCfg servers testDB2 $ \b ->
runTest a b
withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a
withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO ()
withAgentClientsCfg2 aCfg bCfg = withAgentClientsCfgServers2 aCfg bCfg initAgentServers
{-# INLINE withAgentClientsCfg2 #-}
withAgentClients2 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a
withAgentClients2 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO ()
withAgentClients2 = withAgentClientsCfg2 agentCfg agentCfg
{-# INLINE withAgentClients2 #-}
@@ -586,20 +518,16 @@ withAgentClients3 runTest =
runTest a b c
runAgentClientTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
runAgentClientTest pqSupport viaProxy alice bob baseId =
runAgentClientTestPQ viaProxy (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId
runAgentClientTestPQ :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
runAgentClientTestPQ viaProxy (alice, aPQ) (bob, bPQ) baseId =
runAgentClientTest pqSupport viaProxy alice@AgentClient {} bob baseId =
runRight_ $ do
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing aPQ SMSubscribe
aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" bPQ SMSubscribe
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (IKNoPQ pqSupport) SMSubscribe
aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" pqSupport SMSubscribe
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ
liftIO $ pqSup' `shouldBe` pqSupport
allowConnection alice bobId confId "alice's connInfo"
let pqEnc = PQEncryption $ pqConnectionMode aPQ bPQ
let pqEnc = CR.pqSupportToEnc pqSupport
get alice ##> ("", bobId, A.CON pqEnc)
get bob ##> ("", aliceId, A.INFO bPQ "alice's connInfo")
get bob ##> ("", aliceId, A.INFO pqSupport "alice's connInfo")
get bob ##> ("", aliceId, A.CON pqEnc)
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
let proxySrv = if viaProxy then Just testSMPServer else Nothing
@@ -627,9 +555,6 @@ runAgentClientTestPQ viaProxy (alice, aPQ) (bob, bPQ) baseId =
where
msgId = subtract baseId . fst
pqConnectionMode :: InitialKeys -> PQSupport -> Bool
pqConnectionMode pqMode1 pqMode2 = supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2
testEnablePQEncryption :: HasCallStack => IO ()
testEnablePQEncryption =
withAgentClients2 $ \ca cb -> runRight_ $ do
@@ -647,13 +572,13 @@ testEnablePQEncryption =
-- switched to smaller envelopes (before reporting PQ encryption enabled)
sml <- largeMsg g PQSupportOn
-- fail because of message size
Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg
Left (A.CMD LARGE) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg
(9, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml
get ca =##> \case ("", connId, SENT 9) -> connId == bId; _ -> False
get cb =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False
ackMessage cb aId 8 Nothing
-- -- fail in reply to sync IDss
Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg
Left (A.CMD LARGE) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg
(10, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml
get cb =##> \case ("", connId, SENT 10) -> connId == aId; _ -> False
get ca =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False
@@ -680,8 +605,8 @@ testEnablePQEncryption =
(b, 26, sml) \#>\ a
(a, 27, sml) \#>\ b
-- PQ encryption is now disabled, but support remained enabled, so we still cannot send larger messages
Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456")
Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456")
Left (A.CMD LARGE) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456")
Left (A.CMD LARGE) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456")
pure ()
where
(\#>\) = PQEncOff `sndRcv` PQEncOff
@@ -722,23 +647,19 @@ testAgentClient3 =
runAgentClientContactTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
runAgentClientContactTest pqSupport viaProxy alice bob baseId =
runAgentClientContactTestPQ viaProxy pqSupport (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId
runAgentClientContactTestPQ :: HasCallStack => Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
runAgentClientContactTestPQ viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId =
runRight_ $ do
(_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" bPQ SMSubscribe
(_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing (IKNoPQ pqSupport) SMSubscribe
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo pqSupport
aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" pqSupport SMSubscribe
liftIO $ aliceId' `shouldBe` aliceId
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` reqPQSupport
bobId <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
liftIO $ pqSup' `shouldBe` pqSupport
bobId <- acceptContact alice True invId "alice's connInfo" PQSupportOn SMSubscribe
("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
liftIO $ pqSup'' `shouldBe` bPQ
liftIO $ pqSup'' `shouldBe` pqSupport
allowConnection bob aliceId confId "bob's connInfo"
let pqEnc = PQEncryption $ pqConnectionMode aPQ bPQ
get alice ##> ("", bobId, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo")
let pqEnc = CR.pqSupportToEnc pqSupport
get alice ##> ("", bobId, A.INFO pqSupport "bob's connInfo")
get alice ##> ("", bobId, A.CON pqEnc)
get bob ##> ("", aliceId, A.CON pqEnc)
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
@@ -767,41 +688,6 @@ runAgentClientContactTestPQ viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId
where
msgId = subtract baseId . fst
runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do
(_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe
(bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo
sentMessages abPQEnc alice bobId bob bAliceId
(tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo
sentMessages atPQEnc alice tomId tom tAliceId
where
msgId = subtract baseId . fst
connectViaContact b pq qInfo = do
aId <- A.prepareConnectionToJoin b 1 True qInfo pq
aId' <- A.joinConnection b 1 (Just aId) True qInfo "bob's connInfo" pq SMSubscribe
liftIO $ aId' `shouldBe` aId
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` PQSupportOn
bId <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
liftIO $ pqSup'' `shouldBe` pq
allowConnection b aId confId "bob's connInfo"
let pqEnc = PQEncryption $ pqConnectionMode aPQ pq
get alice ##> ("", bId, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo")
get alice ##> ("", bId, A.CON pqEnc)
get b ##> ("", aId, A.CON pqEnc)
pure (aId, bId, pqEnc)
sentMessages pqEnc a bId b aId = do
let proxySrv = if viaProxy then Just testSMPServer else Nothing
1 <- msgId <$> A.sendMessage a bId pqEnc SMP.noMsgFlags "hello"
get a ##> ("", bId, A.SENT (baseId + 1) proxySrv)
get b =##> \case ("", c, Msg' _ pq "hello") -> c == aId && pq == pqEnc; _ -> False
ackMessage b aId (baseId + 1) Nothing
2 <- msgId <$> A.sendMessage b aId pqEnc SMP.noMsgFlags "hello too"
get b ##> ("", aId, A.SENT (baseId + 2) proxySrv)
get a =##> \case ("", c, Msg' _ pq "hello too") -> c == bId && pq == pqEnc; _ -> False
ackMessage a bId (baseId + 2) Nothing
noMessages :: HasCallStack => AgentClient -> String -> Expectation
noMessages c err = tryGet `shouldReturn` ()
where
@@ -810,18 +696,6 @@ noMessages c err = tryGet `shouldReturn` ()
Just msg -> error $ err <> ": " <> show msg
_ -> return ()
testRejectContactRequest :: HasCallStack => IO ()
testRejectContactRequest =
withAgentClients2 $ \alice bob -> runRight_ $ do
(addrConnId, qInfo) <- A.createConnection alice 1 True SCMContact Nothing IKPQOn SMSubscribe
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe
liftIO $ aliceId' `shouldBe` aliceId
("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice
liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND)
rejectContact alice addrConnId invId
liftIO $ noMessages bob "nothing delivered to bob"
testAsyncInitiatingOffline :: HasCallStack => IO ()
testAsyncInitiatingOffline =
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> runRight_ $ do
@@ -1186,53 +1060,6 @@ testSkippedMessages t = do
disposeAgentClient alice2
disposeAgentClient bob2
testDeliveryAfterSubscriptionError :: HasCallStack => ATransport -> IO ()
testDeliveryAfterSubscriptionError t = do
(aId, bId) <- withAgentClients2 $ \a b -> do
(aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False
4 <- runRight $ sendMessage a bId SMP.noMsgFlags "hello"
liftIO $ noMessages b "not delivered"
pure (aId, bId)
withAgentClients2 $ \a b -> do
Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection a bId
Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection b aId
pure ()
withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
withUP a bId $ \case ("", c, SENT 4) -> c == bId; _ -> False
withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False
ackMessage b aId 4 Nothing
testMsgDeliveryQuotaExceeded :: HasCallStack => ATransport -> IO ()
testMsgDeliveryQuotaExceeded t =
withAgentClients2 $ \a b -> withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
(aId, bId) <- makeConnection a b
(aId', bId') <- makeConnection a b
forM_ ([1 .. 4] :: [Int]) $ \i -> do
mId <- sendMessage a bId SMP.noMsgFlags $ "message " <> bshow i
get a =##> \case ("", c, SENT mId') -> bId == c && mId == mId'; _ -> False
8 <- sendMessage a bId SMP.noMsgFlags "over quota"
pGet' a False =##> \case ("", c, AEvt _ (MWARN 8 (SMP _ QUOTA))) -> bId == c; _ -> False
4 <- sendMessage a bId' SMP.noMsgFlags "hello"
get a =##> \case ("", c, SENT 4) -> bId' == c; _ -> False
get b =##> \case ("", c, Msg "message 1") -> aId == c; _ -> False
get b =##> \case ("", c, Msg "hello") -> aId' == c; _ -> False
ackMessage b aId' 4 Nothing
ackMessage b aId 4 Nothing
get b =##> \case ("", c, Msg "message 2") -> aId == c; _ -> False
ackMessage b aId 5 Nothing
get b =##> \case ("", c, Msg "message 3") -> aId == c; _ -> False
ackMessage b aId 6 Nothing
get b =##> \case ("", c, Msg "message 4") -> aId == c; _ -> False
ackMessage b aId 7 Nothing
get a =##> \case ("", c, QCONT) -> bId == c; _ -> False
get b =##> \case ("", c, Msg "over quota") -> aId == c; _ -> False
ackMessage b aId 9 Nothing -- msg 8 was QCONT
get a =##> \case ("", c, SENT 8) -> bId == c; _ -> False
liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events")
testExpireMessage :: HasCallStack => ATransport -> IO ()
testExpireMessage t =
withAgent 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a ->
@@ -1285,8 +1112,8 @@ withUP a bId p =
liftIO $
getInAnyOrder
a
[ \case ("", "", AEvt SAENone (UP _ [c])) -> c == bId; _ -> False,
\case (corrId, c, AEvt SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False
[ \case ("", "", APC SAENone (UP _ [c])) -> c == bId; _ -> False,
\case (corrId, c, APC SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False
]
testExpireMessageQuota :: HasCallStack => ATransport -> IO ()
@@ -1308,8 +1135,8 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP
get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False
ackMessage b' aId 4 Nothing
liftIO . getInAnyOrder a $
[ \case ("", c, AEvt SAEConn (SENT 6)) -> c == bId; _ -> False,
\case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False
[ \case ("", c, APC SAEConn (SENT 6)) -> c == bId; _ -> False,
\case ("", c, APC SAEConn QCONT) -> c == bId; _ -> False
]
get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 4) "3") -> c == aId; _ -> False
ackMessage b' aId 6 Nothing
@@ -1345,8 +1172,8 @@ testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1}
get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False
ackMessage b' aId 4 Nothing
liftIO . getInAnyOrder a $
[ \case ("", c, AEvt SAEConn (SENT 8)) -> c == bId; _ -> False,
\case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False
[ \case ("", c, APC SAEConn (SENT 8)) -> c == bId; _ -> False,
\case ("", c, APC SAEConn QCONT) -> c == bId; _ -> False
]
get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 6) "5") -> c == aId; _ -> False
ackMessage b' aId 6 Nothing
@@ -1419,9 +1246,9 @@ ratchetSyncP cId rss = \case
cId' == cId && rss' == rss && ratchetSyncState == rss
_ -> False
ratchetSyncP' :: ConnId -> RatchetSyncState -> ATransmission -> Bool
ratchetSyncP' :: ConnId -> RatchetSyncState -> ATransmission 'Agent -> Bool
ratchetSyncP' cId rss = \case
(_, cId', AEvt SAEConn (RSYNC rss' _ ConnectionStats {ratchetSyncState})) ->
(_, cId', APC SAEConn (RSYNC rss' _ ConnectionStats {ratchetSyncState})) ->
cId' == cId && rss' == rss && ratchetSyncState == rss
_ -> False
@@ -1437,18 +1264,23 @@ testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do
liftIO $ ratchetSyncState `shouldBe` RSStarted
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
concurrently_
(getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP])
(getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP])
runRight_ $ do
liftIO . getInAnyOrder alice $
[ ratchetSyncP' bobId RSAgreed,
serverUpP
]
liftIO . getInAnyOrder bob2 $
[ ratchetSyncP' aliceId RSAgreed,
serverUpP
]
get alice =##> ratchetSyncP bobId RSOk
get bob2 =##> ratchetSyncP aliceId RSOk
exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
disposeAgentClient bob2
serverUpP :: ATransmission -> Bool
serverUpP :: ATransmission 'Agent -> Bool
serverUpP = \case
("", "", AEvt SAENone (UP _ _)) -> True
("", "", APC SAENone (UP _ _)) -> True
_ -> False
testRatchetSyncClientRestart :: HasCallStack => ATransport -> IO ()
@@ -1494,10 +1326,15 @@ testRatchetSyncSuspendForeground t = do
foregroundAgent bob2
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
concurrently_
(getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP])
(getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP])
runRight_ $ do
liftIO . getInAnyOrder alice $
[ ratchetSyncP' bobId RSAgreed,
serverUpP
]
liftIO . getInAnyOrder bob2 $
[ ratchetSyncP' aliceId RSAgreed,
serverUpP
]
get alice =##> ratchetSyncP bobId RSOk
get bob2 =##> ratchetSyncP aliceId RSOk
exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
@@ -1522,10 +1359,15 @@ testRatchetSyncSimultaneous t = do
liftIO $ aRSS `shouldBe` RSStarted
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
concurrently_
(getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP])
(getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP])
runRight_ $ do
liftIO . getInAnyOrder alice $
[ ratchetSyncP' bobId RSAgreed,
serverUpP
]
liftIO . getInAnyOrder bob2 $
[ ratchetSyncP' aliceId RSAgreed,
serverUpP
]
get alice =##> ratchetSyncP bobId RSOk
get bob2 =##> ratchetSyncP aliceId RSOk
exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
@@ -1597,8 +1439,8 @@ testInactiveNoSubs t = do
withSmpServerConfigOn t cfg' testPort $ \_ ->
withAgent 1 agentCfg initAgentServers testDB $ \alice -> do
runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check
Just (_, _, AEvt SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice)
Just (_, _, AEvt SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice)
Just (_, _, APC SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice)
Just (_, _, APC SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice)
pure ()
testInactiveWithSubs :: ATransport -> IO ()
@@ -1674,13 +1516,13 @@ testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do
liftIO $ suspendAgent b 5000000
withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do
pGet b =##> \case ("", c, AEvt SAEConn (SENT 5)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False
pGet b =##> \case ("", c, AEvt SAEConn (SENT 5)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False
pGet b =##> \case ("", c, AEvt SAEConn (SENT 6)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False
pGet b =##> \case ("", c, APC SAEConn (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
pGet b =##> \case ("", c, APC SAEConn (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
pGet b =##> \case ("", c, APC SAEConn (SENT 6)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
("", "", SUSPENDED) <- nGet b
pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False
pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False
pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
ackMessage a bId 5 Nothing
get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
ackMessage a bId 6 Nothing
@@ -1971,8 +1813,8 @@ testWaitDelivery t =
liftIO $
getInAnyOrder
bob
[ \case ("", "", AEvt SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
\case ("", cId, AEvt SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
[ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
\case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
]
ackMessage bob aliceId (baseId + 3) Nothing
get bob =##> \case ("", c, Msg "message 1") -> c == aliceId; _ -> False
@@ -2108,8 +1950,8 @@ testWaitDeliveryTimeout2 t =
liftIO $
getInAnyOrder
bob
[ \case ("", "", AEvt SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
\case ("", cId, AEvt SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
[ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
\case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
]
liftIO $ noMessages alice "nothing else should be delivered to alice"
liftIO $ noMessages bob "nothing else should be delivered to bob"
@@ -2135,10 +1977,10 @@ testJoinConnectionAsyncReplyError t = do
get b =##> \case ("2", c, OK) -> c == aId; _ -> False
confId <- withSmpServerStoreLogOn t testPort $ \_ -> do
pGet a >>= \case
("", "", AEvt _ (UP _ [_])) -> do
("", "", APC _ (UP _ [_])) -> do
("", _, CONF confId _ "bob's connInfo") <- get a
pure confId
("", _, AEvt _ (CONF confId _ "bob's connInfo")) -> do
("", _, APC _ (CONF confId _ "bob's connInfo")) -> do
("", "", UP _ [_]) <- nGet a
pure confId
r -> error $ "unexpected response " <> show r
@@ -2149,8 +1991,8 @@ testJoinConnectionAsyncReplyError t = do
ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
pure ()
withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
pGet a =##> \case ("3", c, AEvt _ OK) -> c == bId; ("", "", AEvt _ (UP _ [c])) -> c == bId; _ -> False
pGet a =##> \case ("3", c, AEvt _ OK) -> c == bId; ("", "", AEvt _ (UP _ [c])) -> c == bId; _ -> False
pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False
pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False
get a ##> ("", bId, CON)
get b ##> ("", aId, INFO "alice's connInfo")
get b ##> ("", aId, CON)
@@ -2295,7 +2137,7 @@ testSwitchAsync servers = do
withB = withAgent 2 agentCfg servers testDB2
withAgent :: HasCallStack => Int -> AgentConfig -> InitialAgentServers -> FilePath -> (HasCallStack => AgentClient -> IO a) -> IO a
withAgent clientId cfg' servers dbPath = bracket (getSMPAgentClient' clientId cfg' servers dbPath) (\a -> disposeAgentClient a >> threadDelay 100000)
withAgent clientId cfg' servers dbPath = bracket (getSMPAgentClient' clientId cfg' servers dbPath) disposeAgentClient
sessionSubscribe :: (forall a. (AgentClient -> IO a) -> IO a) -> [ConnId] -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO ()
sessionSubscribe withC connIds a =
@@ -2422,20 +2264,20 @@ testAbortSwitchStartedReinitiate servers = do
withB :: (AgentClient -> IO a) -> IO a
withB = withAgent 2 agentCfg servers testDB2
switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ATransmission -> Bool
switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ATransmission 'Agent -> Bool
switchPhaseRcvP cId sphase swchStatuses = switchPhaseP cId QDRcv sphase (\stats -> rcvSwchStatuses' stats == swchStatuses)
switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> ATransmission -> Bool
switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> ATransmission 'Agent -> Bool
switchPhaseSndP cId sphase swchStatuses = switchPhaseP cId QDSnd sphase (\stats -> sndSwchStatuses' stats == swchStatuses)
switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> ATransmission -> Bool
switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> ATransmission 'Agent -> Bool
switchPhaseP cId qd sphase statsP = \case
(_, cId', AEvt SAEConn (SWITCH qd' sphase' stats)) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats
(_, cId', APC SAEConn (SWITCH qd' sphase' stats)) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats
_ -> False
errQueueNotFoundP :: ConnId -> ATransmission -> Bool
errQueueNotFoundP :: ConnId -> ATransmission 'Agent -> Bool
errQueueNotFoundP cId = \case
(_, cId', AEvt SAEConn (ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}})) -> cId' == cId
(_, cId', APC SAEConn (ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}})) -> cId' == cId
_ -> False
testCannotAbortSwitchSecured :: HasCallStack => InitialAgentServers -> IO ()
@@ -2650,7 +2492,7 @@ testDeliveryReceipts =
get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
ackMessage a bId 6 $ Just ""
get b =##> \case ("", c, Rcvd 6) -> c == aId; _ -> False
ackMessage b aId 7 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e)
ackMessage b aId 7 (Just "") `catchError` \e -> liftIO $ e `shouldBe` A.CMD PROHIBITED
ackMessage b aId 7 Nothing
testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO ()
@@ -2868,8 +2710,11 @@ testWaitForUserNetwork = do
a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNNone False
threadDelay 5000
networkDelay a 100000
networkDelay a 100000
networkDelay a 150000
networkDelay a 200000
networkDelay a 200000
setUserNetworkInfo a $ UserNetworkInfo UNCellular True
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNCellular False
@@ -2879,29 +2724,26 @@ testWaitForUserNetwork = do
(networkDelay a 50000)
noNetworkDelay a
where
aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0}
aCfg = agentCfg {userNetworkInterval = RetryInterval {initialInterval = 100000, increaseAfter = 0, maxInterval = 200000}}
testDoNotResetOnlineToOffline :: IO ()
testDoNotResetOnlineToOffline = do
testDoNotResetOfflineInterval :: IO ()
testDoNotResetOfflineInterval = do
a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNWifi False
threadDelay 5000
networkDelay a 100000
setUserNetworkInfo a $ UserNetworkInfo UNWifi False
setUserNetworkInfo a $ UserNetworkInfo UNWifi True
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNWifi False -- ingnored
noNetworkDelay a
threadDelay 100000
setUserNetworkInfo a $ UserNetworkInfo UNWifi False
networkDelay a 100000
networkDelay a 150000
setUserNetworkInfo a $ UserNetworkInfo UNCellular False
networkDelay a 200000
setUserNetworkInfo a $ UserNetworkInfo UNNone False
networkDelay a 100000
setUserNetworkInfo a $ UserNetworkInfo UNWifi True
setUserNetworkInfo a $ UserNetworkInfo UNNone False -- ingnored
networkDelay a 200000
setUserNetworkInfo a $ UserNetworkInfo UNCellular True
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNCellular False
networkDelay a 100000
where
aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0.1}
aCfg = agentCfg {userNetworkInterval = RetryInterval {initialInterval = 100000, increaseAfter = 0, maxInterval = 200000}}
testResumeMultipleThreads :: IO ()
testResumeMultipleThreads = do
@@ -2916,99 +2758,14 @@ testResumeMultipleThreads = do
threadDelay 1000000
setUserNetworkInfo a $ UserNetworkInfo UNCellular True
ts <- mapM (atomically . readTMVar) vs
-- print $ minimum ts
-- print $ maximum ts
-- print $ sum ts `div` fromIntegral (length ts)
print $ minimum ts
print $ maximum ts
print $ sum ts `div` fromIntegral (length ts)
let average = sum ts `div` fromIntegral (length ts)
average < 3000000 `shouldBe` True
maximum ts < 4000000 `shouldBe` True
where
aCfg = agentCfg {userOfflineDelay = 0}
testServerQueueInfo :: IO ()
testServerQueueInfo = do
withAgentClients2 $ \alice bob -> runRight_ $ do
(bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
liftIO $ threadDelay 200000
checkEmptyQ alice bobId False
aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
("", _, CONF confId _ "bob's connInfo") <- get alice
liftIO $ threadDelay 200000
checkEmptyQ alice bobId False
allowConnection alice bobId confId "alice's connInfo"
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, INFO "alice's connInfo")
get bob ##> ("", aliceId, CON)
liftIO $ threadDelay 200000
checkEmptyQ alice bobId True
checkEmptyQ bob aliceId True
let msgId = 4
(msgId', PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello"
liftIO $ msgId' `shouldBe` msgId
get alice ##> ("", bobId, SENT msgId)
liftIO $ threadDelay 200000
Just srvMsgId <- checkMsgQ bob aliceId 1
get bob =##> \case
("", c, MSG MsgMeta {integrity = MsgOk, broker = (smId, _), recipient = (mId, _), pqEncryption = PQEncOn} _ "hello") ->
c == aliceId && decodeLatin1 (B64.encode smId) == srvMsgId && mId == msgId
_ -> False
ackMessage bob aliceId msgId Nothing
liftIO $ threadDelay 200000
checkEmptyQ bob aliceId True
(msgId1, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 1"
get alice ##> ("", bobId, SENT msgId1)
Just _ <- checkMsgQ bob aliceId 1
(msgId2, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 2"
get alice ##> ("", bobId, SENT msgId2)
(msgId3, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 3"
get alice ##> ("", bobId, SENT msgId3)
(msgId4, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 4"
get alice ##> ("", bobId, SENT msgId4)
Just _ <- checkMsgQ bob aliceId 4
(msgId5, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello: quota exceeded"
liftIO $ threadDelay 200000
Just _ <- checkMsgQ bob aliceId 5
get bob =##> \case ("", c, Msg' mId PQEncOn "hello 1") -> c == aliceId && mId == msgId1; _ -> False
ackMessage bob aliceId msgId1 Nothing
liftIO $ threadDelay 200000
Just _ <- checkMsgQ bob aliceId 4
get bob =##> \case ("", c, Msg' mId PQEncOn "hello 2") -> c == aliceId && mId == msgId2; _ -> False
ackMessage bob aliceId msgId2 Nothing
get bob =##> \case ("", c, Msg' mId PQEncOn "hello 3") -> c == aliceId && mId == msgId3; _ -> False
ackMessage bob aliceId msgId3 Nothing
liftIO $ threadDelay 200000
Just _ <- checkMsgQ bob aliceId 2
get bob =##> \case ("", c, Msg' mId PQEncOn "hello 4") -> c == aliceId && mId == msgId4; _ -> False
ackMessage bob aliceId msgId4 Nothing
liftIO $ threadDelay 200000
Just _ <- checkMsgQ bob aliceId 1 -- the one that did not fit now accepted
get alice ##> ("", bobId, QCONT)
get alice ##> ("", bobId, SENT msgId5)
liftIO $ threadDelay 200000
Just _srvMsgId <- checkQ bob aliceId True (Just QNoSub) 1 (Just MTMessage)
get bob =##> \case ("", c, Msg' mId PQEncOn "hello: quota exceeded") -> c == aliceId && mId == msgId5 + 1; _ -> False
ackMessage bob aliceId (msgId5 + 1) Nothing
liftIO $ threadDelay 200000
checkEmptyQ bob aliceId True
pure ()
where
checkEmptyQ c cId qiSnd' = do
r <- checkQ c cId qiSnd' (Just QSubThread) 0 Nothing
liftIO $ r `shouldBe` Nothing
checkMsgQ c cId qiSize' = do
r <- checkQ c cId True (Just QNoSub) qiSize' (Just MTMessage)
liftIO $ isJust r `shouldBe` True
pure r
checkQ c cId qiSnd' qiSubThread_ qiSize' msgType_ = do
QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg} <- getConnectionQueueInfo c cId
liftIO $ do
qiSnd `shouldBe` qiSnd'
qiNtf `shouldBe` False
qSubThread <$> qiSub `shouldBe` qiSubThread_
qiSize `shouldBe` qiSize'
msgId_ <- forM qiMsg $ \MsgInfo {msgId, msgType} -> msgId <$ (Just msgType `shouldBe` msgType_)
qDelivered <$> qiSub `shouldBe` Just msgId_
pure msgId_
aCfg = agentCfg {userNetworkInterval = RetryInterval {initialInterval = 1000000, increaseAfter = 0, maxInterval = 3600_000_000}}
noNetworkDelay :: AgentClient -> IO ()
noNetworkDelay a = do
@@ -3064,16 +2821,3 @@ exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do
get bob ##> ("", aliceId, SENT bobMsgId')
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
ackMessage alice bobId aliceMsgId' Nothing
newtype InternalException e = InternalException {unInternalException :: e}
deriving (Eq, Show)
instance Exception e => Exception (InternalException e)
instance Exception e => MonadUnliftIO (ExceptT e IO) where
{-# INLINE withRunInIO #-}
withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b
withRunInIO inner =
ExceptT . fmap (first unInternalException) . try $
withRunInIO $ \run ->
inner $ run . (either (throwIO . InternalException) pure <=< runExceptT)
+6 -17
View File
@@ -7,6 +7,7 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module AgentTests.NotificationTests where
@@ -56,7 +57,7 @@ import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMes
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT)
import Simplex.Messaging.Agent.Store.SQLite (closeSQLiteStore, getSavedNtfToken, reopenSQLiteStore)
import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
@@ -161,12 +162,11 @@ testNtfMatrix t runTest = do
it "servers: next SMP v7, curr NTF v2; clients: curr/new" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfgV7 runTest
runNtfTestCfg :: ATransport -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest = do
runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest =
withSmpServerConfigOn t smpCfg testPort $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t)]} $ \_ ->
withAgentClientsCfg2 aCfg bCfg $ runTest apns
threadDelay 100000
testNotificationToken :: APNSMockServer -> IO ()
testNotificationToken APNSMockServer {apnsQ} = do
@@ -182,7 +182,7 @@ testNotificationToken APNSMockServer {apnsQ} = do
NTActive <- checkNtfToken a tkn
deleteNtfToken a tkn
-- agent deleted this token
Left (CMD PROHIBITED _) <- tryE $ checkNtfToken a tkn
Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn
pure ()
(.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
@@ -335,7 +335,6 @@ testNtfTokenChangeServers t APNSMockServer {apnsQ} =
getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
killThread ntf
withNtfServerOn t ntfTestPort2 $ runRight_ $ do
liftIO $ threadDelay 1000000 -- for notification server to reconnect
tkn <- registerTestToken a "qwer" NMInstant apnsQ
checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
@@ -346,7 +345,7 @@ testRunNTFServerTests t srv =
testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg}} bob = do
(bobId, aliceId, nonce, message) <- runRight $ do
-- establish connection
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
@@ -375,23 +374,13 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen
pure (bobId, aliceId, nonce, message)
-- alice client already has subscription for the connection
Left (CMD PROHIBITED _) <- runExceptT $ getNotificationMessage alice nonce message
threadDelay 200000
suspendAgent alice 0
closeSQLiteStore store
threadDelay 200000
Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message
-- aliceNtf client doesn't have subscription and is allowed to get notification message
withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do
(_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
pure ()
threadDelay 200000
reopenSQLiteStore store
foregroundAgent alice
threadDelay 200000
runRight_ $ do
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
ackMessage alice bobId (baseId + 1) Nothing
+6 -6
View File
@@ -663,7 +663,7 @@ testGetPendingServerCommand st = do
Right (Just PendingCommand {corrId = corrId'}) <- getPendingServerCommand db (Just smpServer1)
corrId' `shouldBe` "4"
where
command = AClientCommand $ NEW True (ACM SCMInvitation) (IKNoPQ PQSupportOn) SMSubscribe
command = AClientCommand $ APC SAEConn $ NEW True (ACM SCMInvitation) (IKNoPQ PQSupportOn) SMSubscribe
corruptCmd :: DB.Connection -> ByteString -> ConnId -> IO ()
corruptCmd db corrId connId = DB.execute db "UPDATE commands SET command = cast('bad' as blob) WHERE conn_id = ? AND corr_id = ?" (connId, corrId)
@@ -709,15 +709,15 @@ testGetNextRcvChunkToDownload st = do
withTransaction st $ \db -> do
Right Nothing <- getNextRcvChunkToDownload db xftpServer1 86400
Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1"
Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
Left e <- getNextRcvChunkToDownload db xftpServer1 86400
show e `shouldContain` "ConversionFailed"
DB.query_ db "SELECT rcv_file_id FROM rcv_files WHERE failed = 1" `shouldReturn` [Only (1 :: Int)]
Right (Just (RcvFileChunk {rcvFileEntityId}, _)) <- getNextRcvChunkToDownload db xftpServer1 86400
Right (Just RcvFileChunk {rcvFileEntityId}) <- getNextRcvChunkToDownload db xftpServer1 86400
rcvFileEntityId `shouldBe` fId2
testGetNextRcvFileToDecrypt :: SQLiteStore -> Expectation
@@ -726,10 +726,10 @@ testGetNextRcvFileToDecrypt st = do
withTransaction st $ \db -> do
Right Nothing <- getNextRcvFileToDecrypt db 86400
Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
DB.execute_ db "UPDATE rcv_files SET status = 'received' WHERE rcv_file_id = 1"
DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1"
Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
DB.execute_ db "UPDATE rcv_files SET status = 'received' WHERE rcv_file_id = 2"
Left e <- getNextRcvFileToDecrypt db 86400
+3 -3
View File
@@ -57,7 +57,7 @@ smpServerTest :: Bool -> Bool -> IO ()
smpServerTest storeLog basicAuth = do
-- init
capture_ (withArgs (["init", "-y"] <> ["-l" | storeLog] <> ["--no-password" | not basicAuth]) $ smpServerCLI cfgPath logPath)
>>= (`shouldSatisfy` (("Server initialized, please provide additional server information in " <> cfgPath <> "/smp-server.ini") `isPrefixOf`))
>>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> cfgPath <> "/smp-server.ini") `isPrefixOf`))
Right ini <- readIniFile $ cfgPath <> "/smp-server.ini"
lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
@@ -77,13 +77,13 @@ smpServerTest storeLog basicAuth = do
let certPath = cfgPath </> "server.crt"
oldCrt@X.Certificate {} <-
XF.readSignedObject certPath >>= \case
[cert'] -> pure . X.signedObject $ X.getSigned cert'
[cert] -> pure . X.signedObject $ X.getSigned cert
_ -> error "bad crt format"
r' <- lines <$> capture_ (withArgs ["cert"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
r' `shouldContain` ["Generated new server credentials"]
newCrt <-
XF.readSignedObject certPath >>= \case
[cert'] -> pure . X.signedObject $ X.getSigned cert'
[cert] -> pure . X.signedObject $ X.getSigned cert
_ -> error "bad crt format after cert"
X.certSignatureAlg oldCrt `shouldBe` X.certSignatureAlg newCrt
X.certSubjectDN oldCrt `shouldBe` X.certSubjectDN newCrt
+111
View File
@@ -0,0 +1,111 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module CoreTests.ProtocolErrorTests where
import GHC.Generics (Generic)
import Generic.Random (genericArbitraryU)
import Simplex.FileTransfer.Transport (XFTPErrorType (..))
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as Agent
import Simplex.Messaging.Client (ProxyClientError (..))
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (CommandError (..), ErrorType (..))
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport (HandshakeError (..), TransportError (..))
import Simplex.RemoteControl.Types (RCErrorType (..))
import Test.Hspec
import Test.Hspec.QuickCheck (modifyMaxSuccess)
import Test.QuickCheck
protocolErrorTests :: Spec
protocolErrorTests = modifyMaxSuccess (const 1000) $ do
describe "errors parsing / serializing" $ do
it "should parse SMP protocol errors" . property . forAll possibleErrorType $ \err ->
smpDecode (smpEncode err) == Right err
it "should parse SMP agent errors" . property . forAll possibleAgentErrorType $ \err ->
strDecode (strEncode err) == Right err
where
possibleErrorType :: Gen ErrorType
possibleErrorType = arbitrary >>= \e -> if skipErrorType e then discard else pure e
possibleAgentErrorType :: Gen AgentErrorType
possibleAgentErrorType =
arbitrary >>= \case
BROKER srv _ | hasSpaces srv -> discard
SMP srv e | hasSpaces srv || skipErrorType e -> discard
NTF srv e | hasSpaces srv || skipErrorType e -> discard
XFTP srv _ | hasSpaces srv -> discard
Agent.PROXY pxy srv _ | hasSpaces pxy || hasSpaces srv -> discard
Agent.PROXY _ _ (ProxyProtocolError e) | skipErrorType e -> discard
Agent.PROXY _ _ (ProxyUnexpectedResponse e) | hasUnicode e -> discard
Agent.PROXY _ _ (ProxyResponseError e) | skipErrorType e -> discard
ok -> pure ok
hasSpaces :: String -> Bool
hasSpaces = any (== ' ')
hasUnicode :: String -> Bool
hasUnicode = any (>= '\255')
skipErrorType = \case
SMP.PROXY (SMP.PROTOCOL e) -> skipErrorType e
SMP.PROXY (SMP.BROKER (UNEXPECTED s)) -> hasUnicode s
SMP.PROXY (SMP.BROKER (RESPONSE s)) -> hasUnicode s
_ -> False
deriving instance Generic AgentErrorType
deriving instance Generic CommandErrorType
deriving instance Generic ConnectionErrorType
deriving instance Generic ProxyClientError
deriving instance Generic BrokerErrorType
deriving instance Generic SMPAgentError
deriving instance Generic AgentCryptoError
deriving instance Generic ErrorType
deriving instance Generic CommandError
deriving instance Generic SMP.ProxyError
deriving instance Generic TransportError
deriving instance Generic HandshakeError
deriving instance Generic XFTPErrorType
deriving instance Generic RCErrorType
instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU
instance Arbitrary CommandErrorType where arbitrary = genericArbitraryU
instance Arbitrary ConnectionErrorType where arbitrary = genericArbitraryU
instance Arbitrary ProxyClientError where arbitrary = genericArbitraryU
instance Arbitrary BrokerErrorType where arbitrary = genericArbitraryU
instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU
instance Arbitrary AgentCryptoError where arbitrary = genericArbitraryU
instance Arbitrary ErrorType where arbitrary = genericArbitraryU
instance Arbitrary CommandError where arbitrary = genericArbitraryU
instance Arbitrary SMP.ProxyError where arbitrary = genericArbitraryU
instance Arbitrary TransportError where arbitrary = genericArbitraryU
instance Arbitrary HandshakeError where arbitrary = genericArbitraryU
instance Arbitrary XFTPErrorType where arbitrary = genericArbitraryU
instance Arbitrary RCErrorType where arbitrary = genericArbitraryU
+1 -1
View File
@@ -2,11 +2,11 @@
module CoreTests.UtilTests where
import AgentTests.FunctionalAPITests ()
import Control.Exception (Exception, SomeException, throwIO)
import Control.Monad.Except
import Control.Monad.IO.Class
import Data.IORef
import Simplex.Messaging.Client.Agent ()
import Simplex.Messaging.Util
import Test.Hspec
import qualified UnliftIO.Exception as UE
+2 -4
View File
@@ -89,7 +89,7 @@ ntfServerCfg =
clientQSize = 1,
subQSize = 1,
pushQSize = 1,
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig =
defaultAPNSPushClientConfig
{ apnsPort = apnsTestPort,
@@ -115,11 +115,9 @@ ntfServerCfgV2 :: NtfServerConfig
ntfServerCfgV2 =
ntfServerCfg
{ ntfServerVRange = mkVersionRange initialNTFVersion authBatchCmdsNTFVersion,
smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}},
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}},
Env.transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes}
}
where
smpAgentCfg' = smpAgentCfg ntfServerCfg
withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t)]}
+180 -4
View File
@@ -10,20 +10,54 @@
module SMPAgentClient where
import Control.Monad
import Control.Monad.IO.Unlift
import qualified Data.ByteString.Char8 as B
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified Database.SQLite.Simple as SQL
import Network.Socket (ServiceName)
import NtfClient (ntfTestPort)
import SMPClient (proxyVRange, testPort)
import SMPClient
( proxyVRange,
serverBracket,
testKeyHash,
testPort,
testPort2,
withSmpServer,
withSmpServerOn,
withSmpServerThreadOn,
)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback, SMPProxyMode, defaultNetworkConfig, defaultSMPClientConfig)
import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback, SMPProxyMode, chooseTransportHost, defaultNetworkConfig, defaultSMPClientConfig)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Test.Hspec
import UnliftIO.Concurrent
import UnliftIO.Directory
import XFTPClient (testXFTPServer)
agentTestHost :: NonEmpty TransportHost
agentTestHost = "localhost"
agentTestPort :: ServiceName
agentTestPort = "5010"
agentTestPort2 :: ServiceName
agentTestPort2 = "5011"
agentTestPort3 :: ServiceName
agentTestPort3 = "5012"
testDB :: FilePath
testDB = "tests/tmp/smp-agent.test.protocol.db"
@@ -33,6 +67,114 @@ testDB2 = "tests/tmp/smp-agent2.test.protocol.db"
testDB3 :: FilePath
testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
smpAgentTest :: forall c. Transport c => TProxy c -> ARawTransmission -> IO ARawTransmission
smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> get h
where
get h = do
t@(_, _, cmdStr) <- tGetRaw h
case parseAll networkCommandP cmdStr of
Right (ACmd SAgent _ CONNECT {}) -> get h
Right (ACmd SAgent _ DISCONNECT {}) -> get h
_ -> pure t
runSmpAgentTest :: forall c a. Transport c => (c -> IO a) -> IO a
runSmpAgentTest test = withSmpServer t . withSmpAgent t $ testSMPAgentClient test
where
t = transport @c
runSmpAgentServerTest :: forall c a. Transport c => ((ThreadId, ThreadId) -> c -> IO a) -> IO a
runSmpAgentServerTest test =
withSmpServerThreadOn t testPort $
\server -> withSmpAgentThreadOn t (agentTestPort, testPort, testDB) $
\agent -> testSMPAgentClient $ test (server, agent)
where
t = transport @c
smpAgentServerTest :: Transport c => ((ThreadId, ThreadId) -> c -> IO ()) -> Expectation
smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` ()
runSmpAgentTestN :: forall c a. Transport c => [(ServiceName, ServiceName, FilePath)] -> ([c] -> IO a) -> IO a
runSmpAgentTestN agents test = withSmpServer t $ run agents []
where
run :: [(ServiceName, ServiceName, FilePath)] -> [c] -> IO a
run [] hs = test hs
run (a@(p, _, _) : as) hs = withSmpAgentOn t a $ testSMPAgentClientOn p $ \h -> run as (h : hs)
t = transport @c
runSmpAgentTestN_1 :: forall c a. Transport c => Int -> ([c] -> IO a) -> IO a
runSmpAgentTestN_1 nClients test = withSmpServer t . withSmpAgent t $ run nClients []
where
run :: Int -> [c] -> IO a
run 0 hs = test hs
run n hs = testSMPAgentClient $ \h -> run (n - 1) (h : hs)
t = transport @c
smpAgentTestN :: Transport c => [(ServiceName, ServiceName, FilePath)] -> ([c] -> IO ()) -> Expectation
smpAgentTestN agents test' = runSmpAgentTestN agents test' `shouldReturn` ()
smpAgentTestN_1 :: Transport c => Int -> ([c] -> IO ()) -> Expectation
smpAgentTestN_1 n test' = runSmpAgentTestN_1 n test' `shouldReturn` ()
smpAgentTest2_2_2 :: forall c. Transport c => (c -> c -> IO ()) -> Expectation
smpAgentTest2_2_2 test' =
withSmpServerOn (transport @c) testPort2 $
smpAgentTest2_2_2_needs_server test'
smpAgentTest2_2_2_needs_server :: forall c. Transport c => (c -> c -> IO ()) -> Expectation
smpAgentTest2_2_2_needs_server test' =
smpAgentTestN
[ (agentTestPort, testPort, testDB),
(agentTestPort2, testPort2, testDB2)
]
_test
where
_test [h1, h2] = test' h1 h2
_test _ = error "expected 2 handles"
smpAgentTest2_2_1 :: Transport c => (c -> c -> IO ()) -> Expectation
smpAgentTest2_2_1 test' =
smpAgentTestN
[ (agentTestPort, testPort, testDB),
(agentTestPort2, testPort, testDB2)
]
_test
where
_test [h1, h2] = test' h1 h2
_test _ = error "expected 2 handles"
smpAgentTest2_1_1 :: Transport c => (c -> c -> IO ()) -> Expectation
smpAgentTest2_1_1 test' = smpAgentTestN_1 2 _test
where
_test [h1, h2] = test' h1 h2
_test _ = error "expected 2 handles"
smpAgentTest3 :: Transport c => (c -> c -> c -> IO ()) -> Expectation
smpAgentTest3 test' =
smpAgentTestN
[ (agentTestPort, testPort, testDB),
(agentTestPort2, testPort, testDB2),
(agentTestPort3, testPort, testDB3)
]
_test
where
_test [h1, h2, h3] = test' h1 h2 h3
_test _ = error "expected 3 handles"
smpAgentTest3_1_1 :: Transport c => (c -> c -> c -> IO ()) -> Expectation
smpAgentTest3_1_1 test' = smpAgentTestN_1 3 _test
where
_test [h1, h2, h3] = test' h1 h2 h3
_test _ = error "expected 3 handles"
smpAgentTest1_1_1 :: forall c. Transport c => (c -> IO ()) -> Expectation
smpAgentTest1_1_1 test' =
smpAgentTestN
[(agentTestPort2, testPort2, testDB2)]
_test
where
_test [h] = test' h
_test _ = error "expected 1 handle"
testSMPServer :: SMPServer
testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"
@@ -64,13 +206,13 @@ initAgentServersProxy smpProxyMode smpProxyFallback =
agentCfg :: AgentConfig
agentCfg =
defaultAgentConfig
{ tcpPort = Nothing,
{ tcpPort = Just agentTestPort,
tbqSize = 4,
-- database = testDB,
smpCfg = defaultSMPClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS), networkConfig},
ntfCfg = defaultNTFClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS), networkConfig},
reconnectInterval = fastRetryInterval,
persistErrorInterval = 1,
xftpNotifyErrsOnRetry = False,
ntfWorkerDelay = 100,
ntfSMPWorkerDelay = 100,
caCertificateFile = "tests/fixtures/ca.crt",
@@ -89,5 +231,39 @@ fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000}
fastMessageRetryInterval :: RetryInterval2
fastMessageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval}
withSmpAgentThreadOn_ :: ATransport -> (ServiceName, ServiceName, FilePath) -> Int -> IO () -> (ThreadId -> IO a) -> IO a
withSmpAgentThreadOn_ t (port', smpPort', db') initClientId afterProcess =
let cfg' = agentCfg {tcpPort = Just port'}
initServers' = initAgentServers {smp = userServers [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]}
in serverBracket
( \started -> do
Right st <- liftIO $ createAgentStore db' "" False MCError
when (dbNew st) . liftIO $ withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1)")
runSMPAgentBlocking t cfg' initServers' st initClientId started
)
afterProcess
userServers :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ProtoServerWithAuth p))
userServers srvs = M.fromList [(1, srvs)]
withSmpAgentThreadOn :: ATransport -> (ServiceName, ServiceName, FilePath) -> (ThreadId -> IO a) -> IO a
withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a 0 $ removeFile db'
withSmpAgentOn :: ATransport -> (ServiceName, ServiceName, FilePath) -> IO a -> IO a
withSmpAgentOn t (port', smpPort', db') = withSmpAgentThreadOn t (port', smpPort', db') . const
withSmpAgent :: ATransport -> IO a -> IO a
withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
testSMPAgentClientOn :: Transport c => ServiceName -> (c -> IO a) -> IO a
testSMPAgentClientOn port' client = do
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig agentTestHost
runTransportClient defaultTransportClientConfig Nothing useHost port' (Just testKeyHash) $ \h -> do
line <- getLn h
if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
then client h
else do
error $ "wrong welcome message: " <> B.unpack line
testSMPAgentClient :: Transport c => (c -> IO a) -> IO a
testSMPAgentClient = testSMPAgentClientOn agentTestPort
+7 -10
View File
@@ -59,9 +59,6 @@ testStoreLogFile2 = "tests/tmp/smp-server-store.log.2"
testStoreMsgsFile :: FilePath
testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
testStoreMsgsFile2 :: FilePath
testStoreMsgsFile2 = "tests/tmp/smp-server-messages.log.2"
testServerStatsBackupFile :: FilePath
testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
@@ -121,10 +118,8 @@ cfg =
smpServerVRange = supportedServerSMPRelayVRange,
transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedSMPHandshakes},
controlPort = Nothing,
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds
allowSMPProxy = False,
serverClientConcurrency = 2,
information = Nothing
smpAgentCfg = defaultSMPClientAgentConfig,
allowSMPProxy = False
}
cfgV7 :: ServerConfig
@@ -138,10 +133,12 @@ proxyCfg =
cfgV7
{ allowSMPProxy = True,
smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion,
smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {serverVRange = proxyVRange, agreeSecret = True}}
smpAgentCfg =
defaultSMPClientAgentConfig
{ smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = proxyVRange, agreeSecret = True},
persistErrorInterval = 3 -- seconds
}
}
where
smpAgentCfg' = smpAgentCfg cfgV7
proxyVRange :: VersionRangeSMP
proxyVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion
+30 -233
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
@@ -9,16 +8,13 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module SMPProxyTests where
import AgentTests.EqInstances ()
import AgentTests.FunctionalAPITests
import Control.Concurrent (ThreadId, threadDelay)
import Control.Logger.Simple
import Control.Monad (forM, forM_, forever, replicateM_)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Control.Monad.Trans.Except (runExceptT)
import Data.ByteString.Char8 (ByteString)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
@@ -37,13 +33,9 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (bshow, tshow)
import Simplex.Messaging.Version (mkVersionRange)
import System.FilePath (splitExtensions)
import System.Random (randomRIO)
import Test.Hspec
import UnliftIO
import Util
smpProxyTests :: Spec
smpProxyTests = do
@@ -79,26 +71,6 @@ smpProxyTests = do
deliverMessageViaProxy proxyServ relayServ C.SEd25519 msg1 msg2
it "max message size, X25519 keys" . twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SX25519 msg1 msg2
describe "stress test 1k" $ do
let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n])
it "1x1000" . twoServersFirstProxy $ deliver 1000
it "5x200" . twoServersFirstProxy $ 5 `inParrallel` deliver 200
it "10x100" . twoServersFirstProxy $ 10 `inParrallel` deliver 100
describe "stress test - no host" $ do
it "1x1000, no delay" . oneServer $ proxyConnectDeadRelay 1000 0 srv1
xit "1x1000, 100ms" . oneServer $ proxyConnectDeadRelay 1000 100000 srv1
xit "100x1000, 100ms" . oneServer $ 100 `inParrallel` (randomRIO (0, 1000000) >>= threadDelay >> proxyConnectDeadRelay 1000 100000 srv1)
xdescribe "stress test 10k" $ do
let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n])
it "1x10000" . twoServersFirstProxy $ deliver 10000
it "5x2000" . twoServersFirstProxy $ 5 `inParrallel` deliver 2000
it "10x1000" . twoServersFirstProxy $ 10 `inParrallel` deliver 1000
it "100x100 N1" . twoServersFirstProxy $ withNumCapabilities 1 $ 100 `inParrallel` deliver 100
it "100x100 N4 C1" . twoServersNoConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C2" . twoServersFirstProxy $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C16" . twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N" . twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100
it "500x20" . twoServersFirstProxy $ 500 `inParrallel` deliver 20
describe "agent API" $ do
describe "one server" $ do
it "always via proxy" . oneServer $
@@ -120,84 +92,46 @@ smpProxyTests = do
agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2"
it "fails when fallback is prohibited" . twoServers_ proxyCfg cfgV7 $
agentViaProxyVersionError
it "retries sending when destination or proxy relay is offline" $
agentViaProxyRetryOffline
describe "stress test 1k" $ do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
it "2 agents, 250 messages" . oneServer $ deliver 2 250
it "5 agents, 10 pairs, 50 messages, N1" . oneServer . withNumCapabilities 1 $ deliver 5 50
it "5 agents, 10 pairs, 50 messages. N4" . oneServer . withNumCapabilities 4 $ deliver 5 50
xdescribe "stress test 10k" $ do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17
where
oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128} testPort . const
oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg testPort . const
twoServers = twoServers_ proxyCfg proxyCfg
twoServersFirstProxy = twoServers_ proxyCfg cfgV8 {msgQueueQuota = 128}
twoServersMoreConc = twoServers_ proxyCfg {serverClientConcurrency = 128} cfgV8 {msgQueueQuota = 128}
twoServersNoConc = twoServers_ proxyCfg {serverClientConcurrency = 1} cfgV8 {msgQueueQuota = 128}
twoServersFirstProxy = twoServers_ proxyCfg cfgV8
twoServers_ cfg1 cfg2 runTest =
withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) cfg2 testPort2 $ const runTest
deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO ()
deliverMessageViaProxy proxyServ relayServ alg msg msg' = deliverMessagesViaProxy proxyServ relayServ alg [msg] [msg']
deliverMessagesViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> [ByteString] -> [ByteString] -> IO ()
deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
deliverMessageViaProxy proxyServ relayServ alg msg msg' = do
g <- C.newRandom
-- set up proxy
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ())
pc <- either (fail . show) pure pc'
Right pc <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ())
THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
-- set up relay
msgQ <- newTBQueueIO 1024
rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) (\_ -> pure ())
rc <- either (fail . show) pure rc'
-- prepare receiving queue
(rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
(rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe
let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv
-- get proxy session
sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct")
sess <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct")
sess0 `shouldBe` sess
-- send via proxy to unsecured queue
forM_ unsecuredMsgs $ \msg -> do
runExceptT' (proxySMPMessage pc sess Nothing sndId noMsgFlags msg) `shouldReturn` Right ()
runExceptT' (proxySMPMessage pc sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION)
msgQ <- newTBQueueIO 4
Right rc <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) (\_ -> pure ())
runRight_ $ do
-- prepare receiving queue
(rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
(rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe
let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv
-- get proxy session
sess <- connectSMPProxiedRelay pc relayServ (Just "correct")
-- send via proxy to unsecured queue
Right () <- proxySMPMessage pc sess Nothing sndId noMsgFlags msg
-- receive 1
(_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody})))]) <- atomically $ readTBQueue msgQ
dec msgId encBody `shouldBe` Right msg
runExceptT' $ ackSMPMessage rc rPriv rcvId msgId
-- secure queue
(sPub, sPriv) <- atomically $ C.generateAuthKeyPair alg g
runExceptT' $ secureSMPQueue rc rPriv rcvId sPub
-- send via proxy to secured queue
waitSendRecv
( forM_ securedMsgs $ \msg' ->
runExceptT' (proxySMPMessage pc sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right ()
)
( forM_ securedMsgs $ \msg' -> do
(_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'})))]) <- atomically $ readTBQueue msgQ
dec msgId' encBody' `shouldBe` Right msg'
runExceptT' $ ackSMPMessage rc rPriv rcvId msgId'
)
proxyConnectDeadRelay :: Int -> Int -> SMPServer -> IO ()
proxyConnectDeadRelay n d proxyServ = do
g <- C.newRandom
-- set up proxy
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ())
pc <- either (fail . show) pure pc'
THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
-- get proxy session
replicateM_ n $ do
sess0 <- runExceptT $ connectSMPProxiedRelay pc (SMPServer testHost "45678" testKeyHash) (Just "correct")
case sess0 of
Right !_noWay -> error "got unexpected client"
Left !_err -> threadDelay d
(_tSess, _v, _sid, _isResp, _entId, Right (SMP.MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody})) <- atomically $ readTBQueue msgQ
liftIO $ dec msgId encBody `shouldBe` Right msg
ackSMPMessage rc rPriv rcvId msgId
-- secure queue
(sPub, sPriv) <- atomically $ C.generateAuthKeyPair alg g
secureSMPQueue rc rPriv rcvId sPub
-- send via proxy to secured queue
Right () <- proxySMPMessage pc sess (Just sPriv) sndId noMsgFlags msg'
-- receive 2
(_tSess, _v, _sid, _isResp, _entId, Right (SMP.MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'})) <- atomically $ readTBQueue msgQ
liftIO $ dec msgId' encBody' `shouldBe` Right msg'
ackSMPMessage rc rPriv rcvId msgId'
agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> IO ()
agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 =
@@ -237,71 +171,6 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b
aCfg = agentProxyCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg}
servers (srvs, smpProxyMode, _) = (initAgentServersProxy smpProxyMode SPFAllow) {smp = userServers $ L.map noAuthSrv srvs}
agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO ()
agentDeliverMessagesViaProxyConc agentServers msgs =
withAgents $ \agents -> do
let pairs = combinations 2 agents
logNote $ "Pairing " <> tshow (length agents) <> " agents into " <> tshow (length pairs) <> " connections"
connections <- forM pairs $ \case
[a, b] -> prePair a b
_ -> error "agents must be paired"
logNote "Running..."
mapConcurrently_ run connections
where
withAgents :: ([AgentClient] -> IO ()) -> IO ()
withAgents action = go [] (zip [1 :: Int ..] agentServers)
where
go agents = \case
[] -> action agents
(aId, aSrvs) : next -> withAgent aId aCfg (servers aSrvs) (dbPrefix <> show aId <> dbSuffix) $ \a -> (a : agents) `go` next
(dbPrefix, dbSuffix) = splitExtensions testDB
-- agent connections have to be set up in advance
-- otherwise the CONF messages would get mixed with MSG
prePair alice bob = do
(bobId, qInfo) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
aliceId <- runExceptT' $ A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
confId <-
get alice >>= \case
("", _, A.CONF confId pqSup' _ "bob's connInfo") -> do
pqSup' `shouldBe` PQSupportOn
pure confId
huh -> fail $ show huh
runExceptT' $ allowConnection alice bobId confId "alice's connInfo"
get alice ##> ("", bobId, A.CON pqEnc)
get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo")
get bob ##> ("", aliceId, A.CON pqEnc)
pure (alice, bobId, bob, aliceId)
-- stream messages in opposite directions, while getting deliveries and sending ACKs
run (alice, bobId, bob, aliceId) = do
aSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage alice bobId pqEnc noMsgFlags
bRecipient <-
async $
forever $
get bob >>= \case
("", _, A.SENT _ _) -> pure ()
("", _, Msg' mId' _ _) -> runExceptT' $ ackMessage alice bobId mId' Nothing
huh -> fail (show huh)
bSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage bob aliceId pqEnc noMsgFlags
aRecipient <-
async $
forever $
get alice >>= \case
("", _, A.SENT _ _) -> pure ()
("", _, Msg' mId' _ _) -> runExceptT' $ ackMessage alice bobId mId' Nothing
huh -> fail (show huh)
logDebug "run waiting..."
a2b <- async $ (waitCatch aSender >>= either throwIO pure) `finally` cancel bRecipient -- stopped sender cancels paired recipient loop
b2a <- async $ (waitCatch bSender >>= either throwIO pure) `finally` cancel aRecipient
waitEitherCatch a2b b2a >>= \case
Right (Right ()) -> wait b2a
Right (Left e) -> cancel bSender >> throwIO e
Left (Right ()) -> wait a2b
Left (Left e) -> cancel aSender >> throwIO e
logDebug "run finished"
pqEnc = CR.PQEncOn
aCfg = agentProxyCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448}
servers srvs = (initAgentServersProxy SPMAlways SPFAllow) {smp = userServers $ L.map noAuthSrv srvs}
agentViaProxyVersionError :: IO ()
agentViaProxyVersionError =
withAgent 1 agentProxyCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do
@@ -313,68 +182,6 @@ agentViaProxyVersionError =
where
servers srvs = (initAgentServersProxy SPMUnknown SPFProhibit) {smp = userServers $ L.map noAuthSrv srvs}
agentViaProxyRetryOffline :: IO ()
agentViaProxyRetryOffline = do
let srv1 = SMPServer testHost testPort testKeyHash
srv2 = SMPServer testHost testPort2 testKeyHash
msg1 = "hello 1"
msg2 = "hello 2"
aProxySrv = Just srv1
bProxySrv = Just srv2
withAgent 1 aCfg (servers srv1) testDB $ \alice ->
withAgent 2 aCfg (servers srv2) testDB2 $ \bob -> do
let pqEnc = CR.PQEncOn
withServer $ \_ -> do
(aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` PQSupportOn
allowConnection alice bobId confId "alice's connInfo"
get alice ##> ("", bobId, A.CON pqEnc)
get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo")
get bob ##> ("", aliceId, A.CON pqEnc)
1 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1
get alice ##> ("", bobId, A.SENT (baseId + 1) aProxySrv)
get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False
ackMessage bob aliceId (baseId + 1) Nothing
2 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2
get bob ##> ("", aliceId, A.SENT (baseId + 2) bProxySrv)
get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False
ackMessage alice bobId (baseId + 2) Nothing
pure (aliceId, bobId)
runRight_ $ do
-- destination relay down
3 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1
bob `down` aliceId
withServer2 $ \_ -> runRight_ $ do
bob `up` aliceId
get alice ##> ("", bobId, A.SENT (baseId + 3) aProxySrv)
get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False
ackMessage bob aliceId (baseId + 3) Nothing
runRight_ $ do
-- proxy relay down
4 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2
bob `down` aliceId
withServer2 $ \_ -> runRight_ $ do
bob `up` aliceId
get bob ##> ("", aliceId, A.SENT (baseId + 4) bProxySrv)
get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False
ackMessage alice bobId (baseId + 4) Nothing
where
withServer :: (ThreadId -> IO a) -> IO a
withServer = withServer_ testStoreLogFile testStoreMsgsFile testPort
withServer2 :: (ThreadId -> IO a) -> IO a
withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testPort2
withServer_ storeLog storeMsgs port =
withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs} port
a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False
a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False
aCfg = agentProxyCfg {messageRetryInterval = fastMessageRetryInterval}
baseId = 3
msgId = subtract baseId . fst
servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers $ L.map noAuthSrv [srv]}
testNoProxy :: IO ()
testNoProxy = do
withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do
@@ -394,13 +201,3 @@ testProxyAuth = do
todo :: IO ()
todo = do
fail "TODO"
runExceptT' :: Exception e => ExceptT e IO a -> IO a
runExceptT' a = runExceptT a >>= either throwIO pure
waitSendRecv :: IO () -> IO () -> IO ()
waitSendRecv s r = do
s' <- async s
r' <- async r
waitCatch s' >>= either (\e -> cancel r' >> fail (show e)) pure
waitCatch r' >>= either (\e -> cancel s' >> fail (show e)) pure
+3 -3
View File
@@ -608,7 +608,7 @@ testRestoreMessages at@(ATransport t) =
logSize testStoreLogFile `shouldReturn` 2
logSize testStoreMsgsFile `shouldReturn` 5
logSize testServerStatsBackupFile `shouldReturn` 55
logSize testServerStatsBackupFile `shouldReturn` 20
Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats1 [rId] 5 1
@@ -626,7 +626,7 @@ testRestoreMessages at@(ATransport t) =
logSize testStoreLogFile `shouldReturn` 1
-- the last message is not removed because it was not ACK'd
logSize testStoreMsgsFile `shouldReturn` 3
logSize testServerStatsBackupFile `shouldReturn` 55
logSize testServerStatsBackupFile `shouldReturn` 20
Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats2 [rId] 5 3
@@ -645,7 +645,7 @@ testRestoreMessages at@(ATransport t) =
logSize testStoreLogFile `shouldReturn` 1
logSize testStoreMsgsFile `shouldReturn` 0
logSize testServerStatsBackupFile `shouldReturn` 55
logSize testServerStatsBackupFile `shouldReturn` 20
Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats3 [rId] 5 5
+2
View File
@@ -11,6 +11,7 @@ import CoreTests.BatchingTests
import CoreTests.CryptoFileTests
import CoreTests.CryptoTests
import CoreTests.EncodingTests
import CoreTests.ProtocolErrorTests
import CoreTests.RetryIntervalTests
import CoreTests.TRcvQueuesTests
import CoreTests.UtilTests
@@ -48,6 +49,7 @@ main = do
describe "Core tests" $ do
describe "Batching tests" batchingTests
describe "Encoding tests" encodingTests
describe "Protocol error tests" protocolErrorTests
describe "Version range" versionRangeTests
describe "Encryption tests" cryptoTests
describe "Encrypted files tests" cryptoFileTests
-22
View File
@@ -1,28 +1,6 @@
module Util where
import Control.Monad (replicateM)
import Data.Either (partitionEithers)
import Data.List (tails)
import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities)
import Test.Hspec
import UnliftIO
skip :: String -> SpecWith a -> SpecWith a
skip = before_ . pendingWith
withNumCapabilities :: Int -> IO a -> IO a
withNumCapabilities new a = getNumCapabilities >>= \old -> bracket_ (setNumCapabilities new) (setNumCapabilities old) a
withNCPUCapabilities :: IO a -> IO a
withNCPUCapabilities a = getNumProcessors >>= \p -> withNumCapabilities p a
inParrallel :: Int -> IO () -> IO ()
inParrallel n action = do
streams <- replicateM n $ async action
(es, rs) <- partitionEithers <$> mapM waitCatch streams
map show es `shouldBe` []
length rs `shouldBe` n
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [[]]
combinations k xs = [y : ys | y : xs' <- tails xs, ys <- combinations (k - 1) xs']
+20 -25
View File
@@ -20,17 +20,15 @@ import Data.Int (Int64)
import Data.List (find, isSuffixOf)
import Data.Maybe (fromJust)
import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2, testDB3)
import SMPClient (xit'')
import Simplex.FileTransfer.Client (XFTPClientConfig (..))
import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, kb, mb, qrSizeLimit, pattern ValidFileDescription)
import Simplex.FileTransfer.Protocol (FileParty (..))
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg)
import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv)
import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
import qualified Simplex.Messaging.Crypto.File as CF
@@ -48,11 +46,7 @@ import XFTPClient
xftpAgentTests :: Spec
xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do
it "should send and receive file" $ withXFTPServer testXFTPAgentSendReceive
-- uncomment CPP option slow_servers and run hpack to run this test
xit "should send and receive file with slow server responses" $
withXFTPServerCfg testXFTPServerConfig {responseDelay = 500000} $
\_ -> testXFTPAgentSendReceive
it "should send and receive file" testXFTPAgentSendReceive
it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted
it "should send and receive large file with a redirect" testXFTPAgentSendReceiveRedirect
it "should send and receive small file without a redirect" testXFTPAgentSendReceiveNoRedirect
@@ -60,7 +54,7 @@ xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do
it "should resume receiving file after restart" testXFTPAgentReceiveRestore
it "should cleanup rcv tmp path after permanent error" testXFTPAgentReceiveCleanup
it "should resume sending file after restart" testXFTPAgentSendRestore
xit'' "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup
it "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup
it "should delete sent file on server" testXFTPAgentDelete
it "should resume deleting file after restart" testXFTPAgentDeleteRestore
-- TODO when server is fixed to correctly send AUTH error, this test has to be modified to expect AUTH error
@@ -106,7 +100,7 @@ checkProgress (prev, expected) (progress, total) loop
| otherwise = pure ()
testXFTPAgentSendReceive :: HasCallStack => IO ()
testXFTPAgentSendReceive = do
testXFTPAgentSendReceive = withXFTPServer $ do
filePath <- createRandomFile
-- send file, delete snd file internally
(rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
@@ -185,7 +179,7 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
FileDescriptionURI {description} <- either fail pure $ strDecode uri
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize)
@@ -229,7 +223,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
FileDescriptionURI {description} <- either fail pure $ strDecode uri
let ValidFileDescription FileDescription {redirect} = description
redirect `shouldBe` Nothing
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
-- NO extra "RFPROG 65k 65k" before switching to real file
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize)
@@ -317,7 +311,7 @@ testReceive' rcp rfd originalFilePath = testReceiveCF' rcp rfd Nothing originalF
testReceiveCF' :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> Int64 -> ExceptT AgentErrorType IO RcvFileId
testReceiveCF' rcp rfd cfArgs originalFilePath size = do
rfId <- xftpReceiveFile rcp 1 rfd cfArgs True
rfId <- xftpReceiveFile rcp 1 rfd cfArgs
rfProgress rcp size
("", rfId', RFDONE path) <- rfGet rcp
liftIO $ do
@@ -342,7 +336,7 @@ testXFTPAgentReceiveRestore = do
-- receive file - should not succeed with server down
rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
xftpStartWorkers rcp (Just recipientFiles)
rfId <- xftpReceiveFile rcp 1 rfd Nothing True
rfId <- xftpReceiveFile rcp 1 rfd Nothing
liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
pure rfId
@@ -386,7 +380,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
-- receive file - should not succeed with server down
rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
xftpStartWorkers rcp (Just recipientFiles)
rfId <- xftpReceiveFile rcp 1 rfd Nothing True
rfId <- xftpReceiveFile rcp 1 rfd Nothing
liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
pure rfId
@@ -398,7 +392,8 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
-- receive file - should fail with AUTH error
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- rfGet rcp'
("", rfId', RFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <-
rfGet rcp'
rfId' `shouldBe` rfId
-- tmp path should be removed after permanent error
@@ -477,7 +472,7 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
-- send file - should fail with AUTH error
withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <-
("", sfId', SFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <-
sfGet sndr'
sfId' `shouldBe` sfId
@@ -512,8 +507,8 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
-- receive file - should fail with AUTH error
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do
xftpStartWorkers rcp2 (Just recipientFiles)
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <-
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
("", rfId', RFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <-
rfGet rcp2
liftIO $ rfId' `shouldBe` rfId
@@ -550,8 +545,8 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
-- receive file - should fail with AUTH error
withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do
xftpStartWorkers rcp2 (Just recipientFiles)
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <-
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
("", rfId', RFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <-
rfGet rcp2
liftIO $ rfId' `shouldBe` rfId
@@ -585,8 +580,8 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $
runRight_ . void $ do
-- receive file 1 again
rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <-
rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing
("", rfId1', RFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <-
rfGet rcp
liftIO $ rfId1 `shouldBe` rfId1'
@@ -618,8 +613,8 @@ testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do
-- receive file 1 again - should fail with AUTH error
runRight $ do
rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <-
rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing
("", rfId', RFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <-
rfGet rcp
liftIO $ rfId' `shouldBe` rfId

Some files were not shown because too many files have changed in this diff Show More