Compare commits

..

58 Commits

Author SHA1 Message Date
Evgeny Poberezkin e1bdfb724f Merge branch 'ep/operators-preset-servers' into ep/operators-preset-servers-android 2024-11-14 14:24:50 +00:00
Evgeny Poberezkin 3023141907 do not strip title from conditions 2024-11-14 14:24:21 +00:00
Evgeny Poberezkin 38a1077b2b Merge branch 'ep/operators-preset-servers' into ep/operators-preset-servers-android 2024-11-14 12:47:52 +00:00
Evgeny Poberezkin fbebbae07c Merge branch 'server-operators' into ep/operators-preset-servers 2024-11-14 12:47:23 +00:00
Evgeny Poberezkin 807f698cf2 Merge branch 'master' into server-operators 2024-11-14 12:24:53 +00:00
Evgeny Poberezkin e45a96935c ci: update website build 2024-11-14 12:16:51 +00:00
Evgeny a5061f3147 docs: update privacy policy and conditions of use (#5129)
* docs: update privacy policy and conditions of use

* update

* note

* update date
2024-11-14 11:59:44 +00:00
Evgeny Poberezkin ee2c7370ec Merge branch 'ep/operators-preset-servers' into ep/operators-preset-servers-android 2024-11-14 11:57:16 +00:00
Evgeny Poberezkin 75e03fca75 remove additional pattern, update servers 2024-11-14 11:56:57 +00:00
Evgeny Poberezkin 708a1ac0f0 Merge branch 'ep/operators-preset-servers' into ep/operators-preset-servers-android 2024-11-14 09:25:07 +00:00
Evgeny Poberezkin 14050a8fc3 ghc 8.10.7 fix attempt 2024-11-14 09:24:49 +00:00
Diogo 4d82209a3a core: pagination API to load items around defined or the earliest unread item (#5100)
* core: auto increment chat item ids (#5088)

* core: auto increment chat item ids

* file name

* down name

* update schema

* ignore down migration on schema dump test

* fix testDirectMessageDelete test

* fix testNotes test

* core: initial api support for items around a given item (#5092)

* core: initial api support for items around a given item

* implementation and tests for local messages

* pass entities down

* unused

* getAllChatItems implementation and tests

* pagination for getting chat and tests

* remove unused import

* group implementation and tests

* refactor

* order by created at for local and direct chats

* core: initial landing api for chat and gaps  (#5104)

* initial work on initial param for loading chat

* support for initial

* controller parse

* fixed sqls

* refactor names

* fix ChatLandingSection serialized type

* total accuracy on landing section

* descriptive view message

* foldr

* refactor to make landingSection reusable

* refactor: use foldr everywhere

* propagate search

* Revert "propagate search"

This reverts commit 01611fd719.

* throw when search is sent for initial

* gap size wip (needs testing)

* final

* remove order by

* remove index

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* core: fix initial api latest chat items ordering (#5151)

* core: fix one item missing from latest in initial and wrong check (#5153)

* core: fix one item missing from latest in initial and wrong check

* final fixes and tests

* clearer tests

* core: remove gaps and make sure page size is always the same (#5163)

* remove gaps

* consistent pagination size

* proper fix and around fix too

* optimize

* refactor

* core: simplify pagination

* core: first unread queries (#5174)

* core: pagination nav info (#5175)

* core: pagination nav info

* wip

* rework

* rework

* group, local

* fix

* rename

* fix tests

* just

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2024-11-14 08:34:25 +00:00
Evgeny Poberezkin 061b805d6d Merge branch 'ep/operators-preset-servers' into ep/operators-preset-servers-android 2024-11-13 23:59:16 +00:00
Evgeny Poberezkin 56c53288ca pattern match for ghc 8.10.7 2024-11-13 23:58:34 +00:00
Evgeny Poberezkin 54c4787c5e add type for ghc 8.10.7 2024-11-13 22:55:01 +00:00
Evgeny Poberezkin f41191323d add type for ghc 8.10.7 2024-11-13 22:53:58 +00:00
Evgeny Poberezkin cc7f1266d3 Merge branch 'ep/operators-preset-servers' into ep/operators-preset-servers-android 2024-11-13 21:58:34 +00:00
Evgeny Poberezkin 9e54ae7295 Merge branch 'master' into master-android 2024-11-13 21:58:14 +00:00
Evgeny Poberezkin 1683b7109f fix TH in ghc 8.10.7 2024-11-13 21:56:35 +00:00
Diogo 60c37f0d1d ios: user profiles move auth to change actions, show unread counts (#5170)
* ios: user profiles move auth to change actions, show unread count per profile

* simpler approach and add profile protection

* not show muted icon

* refactor

* not needed

* fix

* simpler fix

* deadline

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2024-11-13 11:41:39 +00:00
Diogo 15bac88ec9 desktop, android: user profiles move auth to change actions, show unread counts (#5171)
* auth only on change actions for profiles

* show notification count in profiles view

* auth to hidde profile

* save authorized

* refactor and icon fix

* keep key
2024-11-13 09:27:49 +00:00
Evgeny Poberezkin b19dffad4d exclude disabled operators when receiving files 2024-11-12 21:18:13 +00:00
Evgeny Poberezkin 0ec88fd560 make servers of disabled operators "unknown", consider only enabled servers when switching profile links 2024-11-12 20:41:20 +00:00
sh 8af54539f6 docs: add control port section (#5164)
* docs: add control port section

* docs: apply suggestions
2024-11-12 10:37:12 +00:00
Evgeny Poberezkin da65474452 CLI API in progress, validateUserServers 2024-11-11 23:24:11 +00:00
Evgeny Poberezkin d0a7e14a96 make preset servers lists potentially empty in some operators, as long as the combined list is not empty 2024-11-11 16:22:19 +00:00
Evgeny Poberezkin bd4745775d update 2024-11-11 11:34:02 +00:00
Evgeny Poberezkin af144c6208 fix 2024-11-10 22:58:23 +00:00
Evgeny Poberezkin 74206a947b Merge branch 'server-operators' into ep/operators-preset-servers 2024-11-10 16:15:39 +00:00
Evgeny Poberezkin 457e12880c Merge branch 'master' into server-operators 2024-11-10 16:15:07 +00:00
Evgeny 2d588949b1 directory service: additional commands (#5159)
* directory service: additional commands

* notify superusers

* 48 hours

* replace T.elem
2024-11-10 15:21:33 +00:00
Evgeny Poberezkin 84f7f901ea remove imports 2024-11-10 12:57:57 +00:00
Evgeny Poberezkin 90ed503ee0 update (most tests pass) 2024-11-10 12:30:24 +00:00
Evgeny Poberezkin 28105038d4 preset operators and servers (compiles) 2024-11-09 23:53:18 +00:00
Evgeny Poberezkin fd60a2402a Merge branch 'server-operators' into ep/operators-preset-servers 2024-11-08 14:36:47 +00:00
spaced4ndy ef0f21a11c core: operator apis commands (#5155) 2024-11-08 14:45:00 +04:00
spaced4ndy d0e40c1f1d Merge branch 'server-operators' into ep/operators-preset-servers 2024-11-06 16:20:03 +04:00
spaced4ndy 8396e70e7b core: validate servers - find servers with duplicate hosts (#5150) 2024-11-06 16:13:08 +04:00
Evgeny Poberezkin 6128a24869 database entity IDs 2024-11-06 08:12:16 +00:00
Evgeny Poberezkin 0329a6a7d3 Merge branch 'server-operators' into ep/operators-preset-servers 2024-11-05 18:07:09 +00:00
spaced4ndy 2da89c2cf1 core: setConditionsNotified, acceptConditions, setUserServers, validateServers apis wip (#5147) 2024-11-05 21:40:33 +04:00
Evgeny Poberezkin 601ddf97ce WIP 2024-11-05 16:29:30 +00:00
Evgeny Poberezkin 128d031ced Merge branch 'server-operators' into ep/operators-preset-servers 2024-11-05 10:55:36 +00:00
spaced4ndy 3b0205b25f core: setServerOperators, getUsageConditions api wip (#5145) 2024-11-05 14:15:20 +04:00
Evgeny Poberezkin d4a47f1cce simplify 2024-11-04 20:07:28 +00:00
Evgeny Poberezkin 2998e3af3f usageConditionsToAdd 2024-11-04 19:44:45 +00:00
Evgeny Poberezkin 5ff838d63e Merge branch 'server-operators' into ep/operators-preset-servers 2024-11-04 18:19:24 +00:00
spaced4ndy bdaec30fa0 core: getServerOperators, getUserServers, getUsageConditions apis wip (#5141) 2024-11-04 21:11:03 +04:00
Evgeny Poberezkin 5a8bf9106e core: preset servers and operators (WIP) 2024-11-04 16:42:37 +00:00
Evgeny 97df069730 core: add support for server operators (#4961)
* core: add support for server operators

* migration

* update schema and queries, rfc

* add usage conditions tables

* core: server operators new apis draft

* update

* conditions

* update

* add get conditions api

* add get conditions API

* WIP

* compiles

* fix schema

* core: ui logic in types (#5139)

* update

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
2024-11-04 13:28:57 +00:00
Evgeny Poberezkin 9a1166f097 Merge branch 'master' into server-operators 2024-11-03 09:12:12 +00:00
Evgeny Poberezkin 7a741e7ac4 ios: update core library 2024-11-02 20:03:27 +00:00
Evgeny Poberezkin ddd639a86c Merge branch 'master' into master-android 2024-11-02 18:00:48 +00:00
Alexander Bondarenko 165143a111 Use simplexmq with client_library flag (#5133)
* Use simplexmq with client_library flag

* fix server config for mq master

* simplexmq

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2024-11-02 17:51:11 +00:00
Evgeny Poberezkin ab5bd911c2 Merge commit '3c8c9d8b524482903a819861f032d896e43b8024' into master-android 2024-11-02 17:11:09 +00:00
Evgeny ceb17b23b4 bumped haskell.nix (#5134)
Co-authored-by: Moritz Angermann <moritz.angermann@gmail.com>
2024-11-02 15:28:41 +00:00
Evgeny Poberezkin 3c8c9d8b52 website: update jobs page 2024-11-02 13:43:45 +00:00
spaced4ndy 37b78edb91 ios: move Network and servers settings modules to folder (#5110) 2024-10-28 18:18:26 +04:00
53 changed files with 2928 additions and 908 deletions
+1
View File
@@ -10,6 +10,7 @@ on:
- blog/**
- docs/**
- .github/workflows/web.yml
- PRIVACY.md
jobs:
build:
+106 -58
View File
@@ -3,27 +3,49 @@ layout: layouts/privacy.html
permalink: /privacy/index.html
---
# SimpleX Chat Privacy Policy and Conditions of Use
# SimpleX Chat Operators Privacy Policy and Conditions of Use
SimpleX Chat is the first communication network based on a new protocol stack that builds on the same ideas of complete openness and decentralization as email and web, with the focus on providing security and privacy of communications, and without compromising on usability.
## Summary
SimpleX Chat communication protocol is the first protocol that has no user profile IDs of any kind, not even random numbers, cryptographic keys or hashes that identify the users. SimpleX Chat apps allow their users to send messages and files via relay server infrastructure. Relay server owners and providers do not have any access to your messages, thanks to double-ratchet end-to-end encryption algorithm (also known as Signal algorithm - do not confuse with Signal protocols or platform) and additional encryption layers, and they also have no access to your profile and contacts - as they do not provide any user accounts.
[Introduction](#introduction) and [General principles](#general-principles) cover SimpleX Chat network design, the network operators, and the principles of privacy and security provided by SimpleX network.
[Privacy policy](#privacy-policy) covers:
- data stored only on your device - [your profiles](#user-profiles), delivered [messages and files](#messages-and-files). You can transfer this information to another device, and you are responsible for its preservation - if you delete the app it will be lost.
- [private message delivery](#private-message-delivery) that protects your IP address and connection graph from the destination servers.
- [undelivered messages and files](#storage-of-messages-and-files-on-the-servers) stored on the servers.
- [how users connect](#connections-with-other-users) without any user profile identifiers.
- [iOS push notifications](#ios-push-notifications) privacy limitations.
- [user support](#user-support), [SimpleX directory](#simplex-directory) and [any other data](#another-information-stored-on-the-servers) that may be stored on the servers.
- [preset server operators](#preset-server-operators) and the [information they may share](#information-preset-server-operators-may-share).
- [source code license](#source-code-license) and [updates to this document](#updates).
[Conditions of Use](#conditions-of-use-of-software-and-infrastructure) are the conditions you need to accept to use SimpleX Chat applications and the relay servers of preset operators. Their purpose is to protect the users and preset server operators.
*Please note*: this summary and any links in this document are provided for information only - they are not a part of the Privacy Policy and Conditions of Use.
## Introduction
SimpleX Chat (also referred to as SimpleX) is the first communication network based on a new protocol stack that builds on the same ideas of complete openness and decentralization as email and web, with the focus on providing security and privacy of communications, and without compromising on usability.
SimpleX messaging protocol is the first protocol that has no user profile IDs of any kind, not even random numbers, cryptographic keys or hashes that identify the users. SimpleX apps allow their users to send messages and files via relay server infrastructure. Relay server owners and operators do not have any access to your messages, thanks to double-ratchet end-to-end encryption algorithm (also known as Signal algorithm - do not confuse with Signal protocols or platform) and additional encryption layers, and they also have no access to your profile and contacts - as they do not host user accounts.
Double ratchet algorithm has such important properties as [forward secrecy](/docs/GLOSSARY.md#forward-secrecy), sender [repudiation](/docs/GLOSSARY.md#) and break-in recovery (also known as [post-compromise security](/docs/GLOSSARY.md#post-compromise-security)).
If you believe that any part of this document is not aligned with our mission or values, please raise it with us via [email](mailto:chat@simplex.chat) or [chat](https://simplex.chat/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23%2F%3Fv%3D1%26dh%3DMCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%253D%26srv%3Dbylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion).
If you believe that any part of this document is not aligned with SimpleX network mission or values, please raise it via [email](mailto:chat@simplex.chat) or [chat](https://simplex.chat/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23%2F%3Fv%3D1%26dh%3DMCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%253D%26srv%3Dbylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion).
## Privacy Policy
SimpleX Chat Ltd uses the best industry practices for security and encryption to provide client and server software for secure [end-to-end encrypted](/docs/GLOSSARY.md#end-to-end-encryption) messaging via private connections. This encryption cannot be compromised by the relays servers, even if they are modified or compromised, via [man-in-the-middle attack](/docs/GLOSSARY.md#man-in-the-middle-attack), unlike most other communication platforms, services and networks.
### General principles
SimpleX Chat software is built on top of SimpleX messaging and application protocols, based on a new message routing protocol allowing to establish private connections without having any kind of addresses or other identifiers assigned to its users - it does not use emails, phone numbers, usernames, identity keys or any other user profile identifiers to pass messages between the user applications.
SimpleX network software uses the best industry practices for security and encryption to provide client and server software for secure [end-to-end encrypted](/docs/GLOSSARY.md#end-to-end-encryption) messaging via private connections. This encryption is protected from being compromised by the relays servers, even if they are modified or compromised, via [man-in-the-middle attack](/docs/GLOSSARY.md#man-in-the-middle-attack).
SimpleX Chat software is similar in its design approach to email clients and browsers - it allows you to have full control of your data and freely choose the relay server providers, in the same way you choose which website or email provider to use, or use your own relay servers, simply by changing the configuration of the client software. The only current restriction to that is Apple push notifications - at the moment they can only be delivered via the preset servers that we operate, as explained below. We are exploring the solutions to deliver push notifications to iOS devices via other providers or users' own servers.
SimpleX software is built on top of SimpleX messaging and application protocols, based on a new message routing protocol allowing to establish private connections without having identifiers assigned to its users - it does not use emails, phone numbers, usernames, identity keys or any other user profile identifiers to pass messages between the user applications.
While SimpleX Chat Ltd is not a communication service provider, and provide public preset relays "as is", as experimental, without any guarantees of availability or data retention, we are committed to maintain a high level of availability, reliability and security of these preset relays. We will be adding alternative preset infrastructure providers to the software in the future, and you will continue to be able to use any other providers or your own servers.
SimpleX software is similar in its design approach to email clients and browsers - it allows you to have full control of your data and freely choose the relay server operators, in the same way you choose which website or email provider to use, or use your own relay servers, simply by changing the configuration of the client software. The only current restriction to that is Apple push notifications - at the moment they can only be delivered via the servers operated by SimpleX Chat Ltd, as explained below. We are exploring the solutions to deliver push notifications to iOS devices via other providers or users' own servers.
We see users and data sovereignty, and device and provider portability as critically important properties for any communication system.
SimpleX network operators are not communication service provider, and provide public relays "as is", as experimental, without any guarantees of availability or data retention. The operators of the relay servers preset in the app ("Preset Server Operators"), including SimpleX Chat Ltd, are committed to maintain a high level of availability, reliability and security. SimpleX client apps can have multiple preset relay server operators that you can opt-in or opt-out of using. You are and will continue to be able to use any other operators or your own servers.
SimpleX network design is based on the principles of users and data sovereignty, and device and operator portability.
The implementation security assessment of SimpleX cryptography and networking was done in October 2022 by [Trail of Bits](https://www.trailofbits.com/about), and most fixes were released in v4.2 see [the announcement](/blog/20221108-simplex-chat-v4.2-security-audit-new-website.md).
@@ -33,35 +55,41 @@ The cryptographic review of SimpleX protocols design was done in July 2024 by Tr
#### User profiles
Servers used by SimpleX Chat apps do not create, store or identify user profiles. The profiles you can create in the app are local to your device, and can be removed at any time via the app.
Servers used by SimpleX Chat apps do not create, store or identify user chat profiles. The profiles you can create in the app are local to your device, and can be removed at any time via the app.
When you create the local profile, no records are created on any of the relay servers, and infrastructure providers, whether SimpleX Chat Ltd or any other, have no access to any part of your information, and even to the fact that you created a profile - it is a local record stored only on your device. That means that if you delete the app, and have no backup, you will permanently lose all your data and the private connections you created with other software users.
When you create the local profile, no records are created on any of the relay servers, and infrastructure operators, whether preset in the app or any other, have no access to any part of your information, and even to the fact that you created a profile - it is a local record stored only on your device. That means that if you delete the app, and have no backup, you will permanently lose all your data and the private connections you created with other software users.
You can transfer the profile to another device by creating a backup of the app data and restoring it on the new device, but you cannot use more than one device with the copy of the same profile at the same time - it will disrupt any active conversations on either or both devices, as a security property of end-to-end encryption.
#### Messages and Files
SimpleX relay servers cannot decrypt or otherwise access the content or even the size of your messages and files you send or receive. Each message is padded to a fixed size of 16kb. Each file is sent in chunks of 64kb, 256kb, 1mb or 8mb via all or some of the configured file relay servers. Both messages and files are sent end-to-end encrypted, and the servers do not have technical means to compromise this encryption, because part of the [key exchange](/docs/GLOSSARY.md#key-exchange) happens out-of-band.
SimpleX relay servers cannot decrypt or otherwise access the content or even the size of your messages and files you send or receive. Each message is padded to a fixed size of 16kb. Each file is sent in chunks of 64kb, 256kb, 1mb or 4mb via all or some of the configured file relay servers. Both messages and files are sent end-to-end encrypted, and the servers do not have technical means to compromise this encryption, because part of the [key exchange](/docs/GLOSSARY.md#key-exchange) happens out-of-band.
Your message history is stored only on your own device and the devices of your contacts. While the recipients' devices are offline, messaging relay servers temporarily store end-to-end encrypted messages you can configure which relay servers are used to receive the messages from the new contacts, and you can manually change them for the existing contacts too.
You do not have control over which servers are used to send messages to your contacts - they are chosen by them. To send messages your client needs to connect to these servers, therefore the servers chosen by your contacts can observe your IP address. You can use VPN or some overlay network (e.g., Tor) to hide your IP address from the servers chosen by your contacts. In the near future we will add the layer in the messaging protocol that will route sent message via the relays chosen by you as well.
#### Private message delivery
The messages are permanently removed from the used relay servers as soon as they are delivered, as long as these servers used unmodified published code. Undelivered messages are deleted after the time that is configured in the messaging servers you use (21 days for preset messaging servers).
You do not have control over which servers are used to send messages to your contacts - these servers are chosen by your contacts. To send messages your client by default uses configured servers to forward messages to the destination servers, thus protecting your IP address from the servers chosen by your contacts.
In case you use preset servers of more than one operator, the app will prefer to use a server of an operator different from the operator of the destination server to forward messages, preventing destination server to correlate messages as belonging to one client.
You can additionally use VPN or some overlay network (e.g., Tor) to hide your IP address from the servers chosen by you.
*Please note*: the clients allow changing configuration to connect to the destination servers directly. It is not recommended - if you make such change, your IP address will be visible to the destination servers.
#### Storage of messages and files on the servers
The messages are removed from the relay servers as soon as all messages of the file they were stored in are delivered and saving new messages switches to another file, as long as these servers use unmodified published code. Undelivered messages are also marked as delivered after the time that is configured in the messaging servers you use (21 days for preset messaging servers).
The files are stored on file relay servers for the time configured in the relay servers you use (48 hours for preset file servers).
If a messaging servers are restarted, the encrypted message can be stored in a backup file until it is overwritten by the next restart (usually within 1 week for preset relay servers).
As this software is fully open-source and provided under AGPLv3 license, all infrastructure providers and owners, and the developers of the client and server applications who use the SimpleX Chat source code, are required to publish any changes to this software under the same AGPLv3 license - including any modifications to the provided servers.
In addition to the AGPLv3 license terms, SimpleX Chat Ltd is committed to the software users that the preset relays that we provide via the apps will always be compiled from the [published open-source code](https://github.com/simplex-chat/simplexmq), without any modifications.
The encrypted messages can be stored for some time after they are delivered or expired (because servers use append-only logs for message storage). This time varies, and may be longer in connections with fewer messages, but it is usually limited to 1 month, including any backup storage.
#### Connections with other users
When you create a connection with another user, two messaging queues (you can think about them as mailboxes) are created on messaging relay servers (chosen by you and your contact each), that can be the preset servers or the servers that you and your contact configured in the app. SimpleX messaging protocol uses separate queues for direct and response messages, and the apps prefer to create these queues on two different relay servers for increased privacy, in case you have more than one relay server configured in the app, which is the default.
When you create a connection with another user, two messaging queues (you can think about them as mailboxes) are created on messaging relay servers (chosen by you and your contact each), that can be the preset servers or the servers that you and your contact configured in the app. SimpleX messaging protocol uses separate queues for direct and response messages, and the apps prefer to create these queues on two different relay servers, or, if available, the relays of two different operators, for increased privacy, in case you have more than one relay server configured in the app, which is the default.
SimpleX relay servers do not store information about which queues are linked to your profile on the device, and they do not collect any information that would allow infrastructure owners and providers to establish that these queues are related to your device or your profile - the access to each queue is authorized by two anonymous unique cryptographic keys, different for each queue, and separate for sender and recipient of the messages.
Preset and unmodified SimpleX relay servers do not store information about which queues are linked to your profile on the device, and they do not collect any information that would allow infrastructure owners and operators to establish that these queues are related to your device or your profile - the access to each queue is authorized by two anonymous unique cryptographic keys, different for each queue, and separate for sender and recipient of the messages.
#### Connection links privacy
@@ -77,6 +105,8 @@ You can always safely replace the initial part of the link `https://simplex.chat
#### iOS Push Notifications
This section applies only to the notification servers operated by SimpleX Chat Ltd.
When you choose to use instant push notifications in SimpleX iOS app, because the design of push notifications requires storing the device token on notification server, the notifications server can observe how many messaging queues your device has notifications enabled for, and approximately how many messages are sent to each queue.
Preset notification server cannot observe the actual addresses of these queues, as a separate address is used to subscribe to the notifications. It also cannot observe who sends messages to you. Apple push notifications servers can only observe how many notifications are sent to you, but not from how many contacts, or from which messaging relays, as notifications are delivered to your device end-to-end encrypted by one of the preset notification servers - these notifications only contain end-to-end encrypted metadata, not even encrypted message content, and they look completely random to Apple push notification servers.
@@ -85,93 +115,111 @@ You can read more about the design of iOS push notifications [here](./blog/20220
#### Another information stored on the servers
Additional technical information can be stored on our servers, including randomly generated authentication tokens, keys, push tokens, and other material that is necessary to transmit messages. SimpleX Chat design limits this additional technical information to the minimum required to operate the software and servers. To prevent server overloading or attacks, the servers can temporarily store data that can link to particular users or devices, including IP addresses, geographic location, or information related to the transport sessions. This information is not stored for the absolute majority of the app users, even for those who use the servers very actively.
Additional technical information can be stored on the network servers, including randomly generated authentication tokens, keys, push tokens, and other material that is necessary to transmit messages. SimpleX network design limits this additional technical information to the minimum required to operate the software and servers. To prevent server overloading or attacks, the servers can temporarily store data that can link to particular users or devices, including IP addresses, geographic location, or information related to the transport sessions. This information is not stored for the absolute majority of the app users, even for those who use the servers very actively.
#### SimpleX Directory
This section applies only to the experimental group directory operated by SimpleX Chat Ltd.
[SimpleX Directory](/docs/DIRECTORY.md) stores: your search requests, the messages and the members profiles in the registered groups. You can connect to SimpleX Directory via [this address](https://simplex.chat/contact#/?v=1-4&smp=smp%3A%2F%2Fu2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU%3D%40smp4.simplex.im%2FeXSPwqTkKyDO3px4fLf1wx3MvPdjdLW3%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAaiv6MkMH44L2TcYrt_CsX3ZvM11WgbMEUn0hkIKTOho%253D%26srv%3Do5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion).
#### User Support
If you contact SimpleX Chat Ltd, any personal data you share with us is kept only for the purposes of researching the issue and contacting you about your case. We recommend contacting support [via chat](https://simplex.chat/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23%2F%3Fv%3D1%26dh%3DMCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%253D%26srv%3Dbylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion) when it is possible, and avoid sharing any personal information.
The app includes support contact operated by SimpleX Chat Ltd. If you contact support, any personal data you share is kept only for the purposes of researching the issue and contacting you about your case. We recommend contacting support [via chat](https://simplex.chat/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23%2F%3Fv%3D1%26dh%3DMCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%253D%26srv%3Dbylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion) when it is possible, and avoid sharing any personal information.
### Information we may share
### Preset Server Operators
SimpleX Chat Ltd operates preset relay servers using third parties. While we do not have access and cannot share any user data, these third parties may access the encrypted user messages (but NOT the actual unencrypted message content or size) as it is stored or transmitted via our servers. Hosting providers can also store IP addresses and other transport information as part of their logs.
Preset server operators will not share the information on their servers with each other, other than aggregate usage statistics.
We use a third party for email services - if you ask for support via email, your and SimpleX Chat Ltd email providers may access these emails according to their privacy policies and terms. When the request is sensitive, we recommend contacting us via SimpleX Chat or using encrypted email using PGP key published at [openpgp.org](https://keys.openpgp.org/search?q=chat%40simplex.chat).
Preset server operators will not provide general access to their servers or the data on their servers to each other.
The cases when SimpleX Chat Ltd may share the data temporarily stored on the servers:
Preset server operators will provide non-administrative access to control port of preset servers to SimpleX Chat Ltd, for the purposes of removing identified illegal content. This control port access only allows deleting known links and files, and access to aggregate statistics, but does NOT allow enumerating any information on the servers.
### Information Preset Server Operators May Share
The preset server operators use third parties. While they do not have access and cannot share any user data, these third parties may access the encrypted user messages (but NOT the actual unencrypted message content or size) as it is stored or transmitted via the servers. Hosting and network providers can also store IP addresses and other transport information as part of their logs.
SimpleX Chat Ltd uses a third party for email services - if you ask for support via email, your and SimpleX Chat Ltd email providers may access these emails according to their privacy policies and terms. When the request is sensitive, please contact us via SimpleX Chat apps or using encrypted email using PGP key published at [openpgp.org](https://keys.openpgp.org/search?q=chat%40simplex.chat).
The cases when the preset server operators may share the data temporarily stored on the servers:
- To meet any applicable law, or enforceable governmental request or court order.
- To enforce applicable terms, including investigation of potential violations.
- To detect, prevent, or otherwise address fraud, security, or technical issues.
- To protect against harm to the rights, property, or safety of software users, SimpleX Chat Ltd, or the public as required or permitted by law.
- To protect against harm to the rights, property, or safety of software users, operators of preset servers, or the public as required or permitted by law.
At the time of updating this document, we have never provided or have been requested the access to the preset relay servers or any information from the servers by any third parties. If we are ever requested to provide such access or information, we will follow the due legal process to limit any information shared with the third parties to the minimally required by law.
At the time of updating this document, the preset server operators have never provided or have been requested the access to the preset relay servers or any information from the servers by any third parties. If the preset server operators are ever requested to provide such access or information, they will follow the due legal process to limit any information shared with the third parties to the minimally required by law.
We will publish information we are legally allowed to share about such requests in the [Transparency reports](./docs/TRANSPARENCY.md).
Preset server operators will publish information they are legally allowed to share about such requests in the [Transparency reports](./docs/TRANSPARENCY.md).
### Source code license
As this software is fully open-source and provided under AGPLv3 license, all infrastructure owners and operators, and the developers of the client and server applications who use the SimpleX Chat source code, are required to publish any changes to this software under the same AGPLv3 license - including any modifications to the servers.
In addition to the AGPLv3 license terms, the preset relay server operators are committed to the software users that these servers will always be compiled from the [published open-source code](https://github.com/simplex-chat/simplexmq), without any modifications.
### Updates
We will update this Privacy Policy as needed so that it is current, accurate, and as clear as possible. Your continued use of our software applications and preset relays infrastructure confirms your acceptance of our updated Privacy Policy.
This Privacy Policy applies to SimpleX Chat Ltd and all other preset server operators you use in the app.
Please also read our Conditions of Use of Software and Infrastructure below.
This Privacy Policy may be updated as needed so that it is current, accurate, and as clear as possible. When it is updated, you will have to review and accept the changed policy within 30 days of such changes to continue using preset relay servers. Even if you fail to accept the changed policy, your continued use of SimpleX Chat software applications and preset relay servers confirms your acceptance of the updated Privacy Policy.
If you have questions about our Privacy Policy please contact us via [email](mailto:chat@simplex.chat) or [chat](https://simplex.chat/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23%2F%3Fv%3D1%26dh%3DMCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%253D%26srv%3Dbylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion).
Please also read The Conditions of Use of Software and Infrastructure below.
If you have questions about this Privacy Policy please contact SimpleX Chat Ltd via [email](mailto:chat@simplex.chat) or [chat](https://simplex.chat/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23%2F%3Fv%3D1%26dh%3DMCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%253D%26srv%3Dbylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion).
## Conditions of Use of Software and Infrastructure
You accept the Conditions of Use of Software and Infrastructure ("Conditions") by installing or using any of our software or using any of our server infrastructure (collectively referred to as "Applications"), whether preset in the software or not.
You accept the Conditions of Use of Software and Infrastructure ("Conditions") by installing or using any of SimpleX Chat software or using any of server infrastructure (collectively referred to as "Applications") operated by the Preset Server Operators, including SimpleX Chat Ltd, whether these servers are preset in the software or not.
**Minimal age**. You must be at least 13 years old to use our Applications. The minimum age to use our Applications without parental approval may be higher in your country.
**Minimal age**. You must be at least 13 years old to use SimpleX Chat Applications. The minimum age to use SimpleX Applications without parental approval may be higher in your country.
**Infrastructure**. Our Infrastructure includes preset messaging and file relay servers, and iOS push notification servers provided by SimpleX Chat Ltd for public use. Our infrastructure does not have any modifications from the [published open-source code](https://github.com/simplex-chat/simplexmq) available under AGPLv3 license. Any infrastructure provider, whether commercial or not, is required by the Affero clause (named after Affero Inc. company that pioneered the community-based Q&A sites in early 2000s) to publish any modifications under the same license. The statements in relation to Infrastructure and relay servers anywhere in this document assume no modifications to the published code, even in the cases when it is not explicitly stated.
**Infrastructure**. Infrastructure of the preset server operators includes messaging and file relay servers. SimpleX Chat Ltd also provides iOS push notification servers for public use. This infrastructure does not have any modifications from the [published open-source code](https://github.com/simplex-chat/simplexmq) available under AGPLv3 license. Any infrastructure provider, whether commercial or not, is required by the Affero clause (named after Affero Inc. company that pioneered the community-based Q&A sites in early 2000s) to publish any modifications under the same license. The statements in relation to Infrastructure and relay servers anywhere in this document assume no modifications to the published code, even in the cases when it is not explicitly stated.
**Client applications**. Our client application Software (referred to as "app" or "apps") also has no modifications compared with published open-source code, and any developers of the alternative client apps based on our code are required to publish any modifications under the same AGPLv3 license. Client applications should not include any tracking or analytics code, and do not share any information with SimpleX Chat Ltd or any other third parties. If you ever discover any tracking or analytics code, please report it to us, so we can remove it.
**Client applications**. SimpleX Chat client application Software (referred to as "app" or "apps") also has no modifications compared with published open-source code, and any developers of the alternative client apps based on SimpleX Chat code are required to publish any modifications under the same AGPLv3 license. Client applications should not include any tracking or analytics code, and do not share any tracking information with SimpleX Chat Ltd, preset server operators or any other third parties. If you ever discover any tracking or analytics code, please report it to SimpleX Chat Ltd, so it can be removed.
**Accessing the infrastructure**. For the efficiency of the network access, the client Software by default accesses all queues your app creates on any relay server within one user profile via the same network (TCP/IP) connection. At the cost of additional traffic this configuration can be changed to use different transport session for each connection. Relay servers do not collect information about which queues were created or accessed via the same connection, so the relay servers cannot establish which queues belong to the same user profile. Whoever might observe your network traffic would know which relay servers you use, and how much data you send, but not to whom it is sent - the data that leaves the servers is always different from the data they receive - there are no identifiers or ciphertext in common, even inside TLS encryption layer. Please refer to our [technical design document](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md) for more information about our privacy model and known security and privacy risks.
**Accessing the infrastructure**. For the efficiency of the network access, the client Software by default accesses all queues your app creates on any relay server within one user profile via the same network (TCP/IP) connection. At the cost of additional traffic this configuration can be changed to use different transport session for each connection. Relay servers do not collect information about which queues were created or accessed via the same connection, so the relay servers cannot establish which queues belong to the same user profile. Whoever might observe your network traffic would know which relay servers you use, and how much data you send, but not to whom it is sent - the data that leaves the servers is always different from the data they receive - there are no identifiers or ciphertext in common, even inside TLS encryption layer. Please refer to the [technical design document](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md) for more information about the privacy model and known security and privacy risks.
**Privacy of user data**. Servers do not retain any data we transmit for any longer than necessary to deliver the messages between apps. SimpleX Chat Ltd collects aggregate statistics across all its servers, as supported by published code and can be enabled by any infrastructure provider, but not any statistics per-user, or per geographic location, or per IP address, or per transport session. We do not have information about how many people use SimpleX Chat applications, we only know an approximate number of app installations and the aggregate traffic through the preset servers. In any case, we do not and will not sell or in any way monetize user data. Our future business model assumes charging for some optional Software features instead, in a transparent and fair way.
**Privacy of user data**. Servers do not retain any data you transmit for any longer than necessary to deliver the messages between apps. Preset server operators collect aggregate statistics across all their servers, as supported by published code and can be enabled by any infrastructure operator, but not any statistics per-user, or per geographic location, or per IP address, or per transport session. SimpleX Chat Ltd does not have information about how many people use SimpleX Chat applications, it only knows an approximate number of app installations and the aggregate traffic through the preset servers. In any case, preset server operators do not and will not sell or in any way monetize user data. The future business model assumes charging for some optional Software features instead, in a transparent and fair way.
**Operating our Infrastructure**. For the purpose of using our Software, if you continue using preset servers, you agree that your end-to-end encrypted messages are transferred via the preset servers in any countries where we have or use facilities and service providers or partners. The information about geographic location of the servers will be made available in the apps in the near future.
**Operating Infrastructure**. For the purpose of using SimpleX Chat Software, if you continue using preset servers, you agree that your end-to-end encrypted messages are transferred via the preset servers in any countries where preset server operators have or use facilities and service providers or partners. The information about geographic location and hosting providers of the preset messaging servers is available on server pages.
**Software**. You agree to downloading and installing updates to our Applications when they are available; they would only be automatic if you configure your devices in this way.
**Software**. You agree to downloading and installing updates to SimpleX Chat Applications when they are available; they would only be automatic if you configure your devices in this way.
**Traffic and device costs**. You are solely responsible for the traffic and device costs that you incur while using our Applications, and any associated taxes.
**Traffic and device costs**. You are solely responsible for the traffic and device costs that you incur while using SimpleX Chat Applications, and any associated taxes.
**Legal usage**. You agree to use our Applications only for legal purposes. You will not use (or assist others in using) our Applications in ways that: 1) violate or infringe the rights of Software users, SimpleX Chat Ltd, or others, including privacy, publicity, intellectual property, or other proprietary rights; 2) involve sending illegal communications, e.g. spam. While we cannot access content or identify messages or groups, in some cases the links to the illegal communications available via our Applications can be shared publicly on social media or websites. We reserve the right to remove such links from the preset servers and disrupt the conversations that send illegal content via our servers, whether they were reported by the users or discovered by our team.
**Legal usage**. You agree to use SimpleX Chat Applications only for legal purposes. You will not use (or assist others in using) the Applications in ways that: 1) violate or infringe the rights of Software users, SimpleX Chat Ltd, other preset server operators, or others, including privacy, publicity, intellectual property, or other proprietary rights; 2) involve sending illegal communications, e.g. spam. While server operators cannot access content or identify messages or groups, in some cases the links to the illegal communications can be shared publicly on social media or websites. Preset server operators reserve the right to remove such links from the preset servers and disrupt the conversations that send illegal content via their servers, whether they were reported by the users or discovered by the operators themselves.
**Damage to SimpleX Chat Ltd**. You must not (or assist others to) access, use, modify, distribute, transfer, or exploit our Applications in unauthorized manners, or in ways that harm Software users, SimpleX Chat Ltd, our Infrastructure, or any other systems. For example, you must not 1) access our Infrastructure or systems without authorization, in any way other than by using the Software; 2) disrupt the integrity or performance of our Infrastructure; 3) collect information about our users in any manner; or 4) sell, rent, or charge for our Infrastructure. This does not prohibit you from providing your own Infrastructure to others, whether free or for a fee, as long as you do not violate these Conditions and AGPLv3 license, including the requirement to publish any modifications of the relay server software.
**Damage to SimpleX Chat Ltd and Preset Server Operators**. You must not (or assist others to) access, use, modify, distribute, transfer, or exploit SimpleX Chat Applications in unauthorized manners, or in ways that harm Software users, SimpleX Chat Ltd, other preset server operators, their Infrastructure, or any other systems. For example, you must not 1) access preset operators' Infrastructure or systems without authorization, in any way other than by using the Software; 2) disrupt the integrity or performance of preset operators' Infrastructure; 3) collect information about the users in any manner; or 4) sell, rent, or charge for preset operators' Infrastructure. This does not prohibit you from providing your own Infrastructure to others, whether free or for a fee, as long as you do not violate these Conditions and AGPLv3 license, including the requirement to publish any modifications of the relay server software.
**Keeping your data secure**. SimpleX Chat is the first communication software that aims to be 100% private by design - server software neither has the ability to access your messages, nor it has information about who you communicate with. That means that you are solely responsible for keeping your device, your user profile and any data safe and secure. If you lose your phone or remove the Software from the device, you will not be able to recover the lost data, unless you made a back up. To protect the data you need to make regular backups, as using old backups may disrupt your communication with some of the contacts.
**Keeping your data secure**. SimpleX Chat is the first communication software that aims to be 100% private by design - server software neither has the ability to access your messages, nor it has information about who you communicate with. That means that you are solely responsible for keeping your device, your user profile and any data safe and secure. If you lose your phone or remove the Software from the device, you will not be able to recover the lost data, unless you made a back up. To protect the data you need to make regular backups, as using old backups may disrupt your communication with some of the contacts. SimpleX Chat Ltd and other preset server operators are not responsible for any data loss.
**Storing the messages on the device**. The messages are stored in the encrypted database on your device. Whether and how database passphrase is stored is determined by the configuration of the Software you use. The databases created prior to 2023 or in CLI (terminal) app may remain unencrypted, and it will be indicated in the app interface. In this case, if you make a backup of the data and store it unencrypted, the backup provider may be able to access the messages. Please note, that the desktop apps can be configured to store the database passphrase in the configuration file in plaintext, and unless you set the passphrase when first running the app, a random passphrase will be used and stored on the device. You can remove it from the device via the app settings.
**Storing the files on the device**. The files currently sent and received in the apps by default (except CLI app) are stored on your device encrypted using unique keys, different for each file, that are stored in the database. Once the message that the file was attached to is removed, even if the copy of the encrypted file is retained, it should be impossible to recover the key allowing to decrypt the file. This local file encryption may affect app performance, and it can be disabled via the app settings. This change will only affect the new files. If you later re-enable the encryption, it will also affect only the new files. If you make a backup of the app data and store it unencrypted, the backup provider will be able to access any unencrypted files. In any case, irrespective of the storage setting, the files are always sent by all apps end-to-end encrypted.
**No Access to Emergency Services**. Our Applications do not provide access to emergency service providers like the police, fire department, hospitals, or other public safety organizations. Make sure you can contact emergency service providers through a mobile, fixed-line telephone, or other service.
**No Access to Emergency Services**. SimpleX Chat Applications do not provide access to emergency service providers like the police, fire department, hospitals, or other public safety organizations. Make sure you can contact emergency service providers through a mobile, fixed-line telephone, or other service.
**Third-party services**. Our Applications may allow you to access, use, or interact with our or third-party websites, apps, content, and other products and services. When you use third-party services, their terms and privacy policies govern your use of those services.
**Third-party services**. SimpleX Chat Applications may allow you to access, use, or interact with the websites of SimpleX Chat Ltd, preset server operators or other third-party websites, apps, content, and other products and services. When you use third-party services, their terms and privacy policies govern your use of those services.
**Your Rights**. You own the messages and the information you transmit through our Applications. Your recipients are able to retain the messages they receive from you; there is no technical ability to delete data from their devices. While there are various app features that allow deleting messages from the recipients' devices, such as _disappearing messages_ and _full message deletion_, their functioning on your recipients' devices cannot be guaranteed or enforced, as the device may be offline or have a modified version of the Software. At the same time, repudiation property of the end-to-end encryption algorithm allows you to plausibly deny having sent the message, like you can deny what you said in a private face-to-face conversation, as the recipient cannot provide any proof to the third parties, by design.
**Your Rights**. You own the messages and the information you transmit through SimpleX Applications. Your recipients are able to retain the messages they receive from you; there is no technical ability to delete data from their devices. While there are various app features that allow deleting messages from the recipients' devices, such as _disappearing messages_ and _full message deletion_, their functioning on your recipients' devices cannot be guaranteed or enforced, as the device may be offline or have a modified version of the Software. At the same time, repudiation property of the end-to-end encryption algorithm allows you to plausibly deny having sent the message, like you can deny what you said in a private face-to-face conversation, as the recipient cannot provide any proof to the third parties, by design.
**License**. SimpleX Chat Ltd grants you a limited, revocable, non-exclusive, and non-transferable license to use our Applications in accordance with these Conditions. The source-code of Applications is available and can be used under [AGPL v3 license](https://github.com/simplex-chat/simplex-chat/blob/stable/LICENSE).
**License**. SimpleX Chat Ltd grants you a limited, revocable, non-exclusive, and non-transferable license to use SimpleX Chat Applications in accordance with these Conditions. The source-code of Applications is available and can be used under [AGPL v3 license](https://github.com/simplex-chat/simplex-chat/blob/stable/LICENSE).
**SimpleX Chat Ltd Rights**. We own all copyrights, trademarks, domains, logos, trade secrets, and other intellectual property rights associated with our Applications. You may not use our copyrights, trademarks, domains, logos, and other intellectual property rights unless you have our written permission, and unless under an open-source license distributed together with the source code. To report copyright, trademark, or other intellectual property infringement, please contact chat@simplex.chat.
**SimpleX Chat Ltd Rights**. SimpleX Chat Ltd (and, where applicable, preset server operators) owns all copyrights, trademarks, domains, logos, trade secrets, and other intellectual property rights associated with the Applications. You may not use SimpleX Chat Ltd copyrights, trademarks, domains, logos, and other intellectual property rights unless you have SimpleX Chat Ltd written permission, and unless under an open-source license distributed together with the source code. To report copyright, trademark, or other intellectual property infringement, please contact chat@simplex.chat.
**Disclaimers**. YOU USE OUR APPLICATIONS AT YOUR OWN RISK AND SUBJECT TO THE FOLLOWING DISCLAIMERS. WE PROVIDE OUR APPLICATIONS ON AN “AS IS” BASIS WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE, NON-INFRINGEMENT, AND FREEDOM FROM COMPUTER VIRUS OR OTHER HARMFUL CODE. SIMPLEX CHAT LTD DOES NOT WARRANT THAT ANY INFORMATION PROVIDED BY US IS ACCURATE, COMPLETE, OR USEFUL, THAT OUR APPLICATIONS WILL BE OPERATIONAL, ERROR-FREE, SECURE, OR SAFE, OR THAT OUR APPLICATIONS WILL FUNCTION WITHOUT DISRUPTIONS, DELAYS, OR IMPERFECTIONS. WE DO NOT CONTROL, AND ARE NOT RESPONSIBLE FOR, CONTROLLING HOW OR WHEN OUR USERS USE OUR APPLICATIONS. WE ARE NOT RESPONSIBLE FOR THE ACTIONS OR INFORMATION (INCLUDING CONTENT) OF OUR USERS OR OTHER THIRD PARTIES. YOU RELEASE US, AFFILIATES, DIRECTORS, OFFICERS, EMPLOYEES, PARTNERS, AND AGENTS ("SIMPLEX PARTIES") FROM ANY CLAIM, COMPLAINT, CAUSE OF ACTION, CONTROVERSY, OR DISPUTE (TOGETHER, "CLAIM") AND DAMAGES, KNOWN AND UNKNOWN, RELATING TO, ARISING OUT OF, OR IN ANY WAY CONNECTED WITH ANY SUCH CLAIM YOU HAVE AGAINST ANY THIRD PARTIES.
**Disclaimers**. YOU USE SIMPLEX APPLICATIONS AT YOUR OWN RISK AND SUBJECT TO THE FOLLOWING DISCLAIMERS. SIMPLEX CHAT LTD PROVIDES APPLICATIONS ON AN “AS IS” BASIS WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE, NON-INFRINGEMENT, AND FREEDOM FROM COMPUTER VIRUS OR OTHER HARMFUL CODE. SIMPLEX CHAT LTD DOES NOT WARRANT THAT ANY INFORMATION PROVIDED BY THEM IS ACCURATE, COMPLETE, OR USEFUL, THAT THEIR APPLICATIONS WILL BE OPERATIONAL, ERROR-FREE, SECURE, OR SAFE, OR THAT THEIR APPLICATIONS WILL FUNCTION WITHOUT DISRUPTIONS, DELAYS, OR IMPERFECTIONS. SIMPLEX CHAT LTD AND OTHER PRESET OPERATORS DO NOT CONTROL, AND ARE NOT RESPONSIBLE FOR, CONTROLLING HOW OR WHEN THE USERS USE APPLICATIONS. SIMPLEX CHAT LTD AND OTHER PRESET OPERATORS ARE NOT RESPONSIBLE FOR THE ACTIONS OR INFORMATION (INCLUDING CONTENT) OF THEIR USERS OR OTHER THIRD PARTIES. YOU RELEASE SIMPLEX CHAT LTD, OTHER PRESET OPERATORS, AFFILIATES, DIRECTORS, OFFICERS, EMPLOYEES, PARTNERS, AND AGENTS ("SIMPLEX PARTIES") FROM ANY CLAIM, COMPLAINT, CAUSE OF ACTION, CONTROVERSY, OR DISPUTE (TOGETHER, "CLAIM") AND DAMAGES, KNOWN AND UNKNOWN, RELATING TO, ARISING OUT OF, OR IN ANY WAY CONNECTED WITH ANY SUCH CLAIM YOU HAVE AGAINST ANY THIRD PARTIES.
**Limitation of liability**. THE SIMPLEX PARTIES WILL NOT BE LIABLE TO YOU FOR ANY LOST PROFITS OR CONSEQUENTIAL, SPECIAL, PUNITIVE, INDIRECT, OR INCIDENTAL DAMAGES RELATING TO, ARISING OUT OF, OR IN ANY WAY IN CONNECTION WITH OUR CONDITIONS, US, OR OUR APPLICATIONS, EVEN IF THE SIMPLEX PARTIES HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. OUR AGGREGATE LIABILITY RELATING TO, ARISING OUT OF, OR IN ANY WAY IN CONNECTION WITH OUR CONDITIONS, US, OR OUR APPLICATIONS WILL NOT EXCEED ONE DOLLAR ($1). THE FOREGOING DISCLAIMER OF CERTAIN DAMAGES AND LIMITATION OF LIABILITY WILL APPLY TO THE MAXIMUM EXTENT PERMITTED BY APPLICABLE LAW. THE LAWS OF SOME JURISDICTIONS MAY NOT ALLOW THE EXCLUSION OR LIMITATION OF CERTAIN DAMAGES, SO SOME OR ALL OF THE EXCLUSIONS AND LIMITATIONS SET FORTH ABOVE MAY NOT APPLY TO YOU. NOTWITHSTANDING ANYTHING TO THE CONTRARY IN OUR CONDITIONS, IN SUCH CASES, THE LIABILITY OF THE SIMPLEX PARTIES WILL BE LIMITED TO THE EXTENT PERMITTED BY APPLICABLE LAW.
**Limitation of liability**. THE SIMPLEX PARTIES WILL NOT BE LIABLE TO YOU FOR ANY LOST PROFITS OR CONSEQUENTIAL, SPECIAL, PUNITIVE, INDIRECT, OR INCIDENTAL DAMAGES RELATING TO, ARISING OUT OF, OR IN ANY WAY IN CONNECTION WITH OUR CONDITIONS, US, OR SIMPLEX APPLICATIONS, EVEN IF THE SIMPLEX PARTIES HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. THE AGGREGATE LIABILITY OF THE SIMPLEX PARTIES RELATING TO, ARISING OUT OF, OR IN ANY WAY IN CONNECTION WITH THESE CONDITIONS, THE SIMPLEX PARTIES, OR THE APPLICATIONS WILL NOT EXCEED ONE DOLLAR ($1). THE FOREGOING DISCLAIMER OF CERTAIN DAMAGES AND LIMITATION OF LIABILITY WILL APPLY TO THE MAXIMUM EXTENT PERMITTED BY APPLICABLE LAW. THE LAWS OF SOME JURISDICTIONS MAY NOT ALLOW THE EXCLUSION OR LIMITATION OF CERTAIN DAMAGES, SO SOME OR ALL OF THE EXCLUSIONS AND LIMITATIONS SET FORTH ABOVE MAY NOT APPLY TO YOU. NOTWITHSTANDING ANYTHING TO THE CONTRARY IN THE CONDITIONS, IN SUCH CASES, THE LIABILITY OF THE SIMPLEX PARTIES WILL BE LIMITED TO THE EXTENT PERMITTED BY APPLICABLE LAW.
**Availability**. Our Applications may be disrupted, including for maintenance, upgrades, or network or equipment failures. We may discontinue some or all of our Applications, including certain features and the support for certain devices and platforms, at any time.
**Availability**. The Applications may be disrupted, including for maintenance, upgrades, or network or equipment failures. SimpleX Chat Ltd may discontinue some or all of their Applications, including certain features and the support for certain devices and platforms, at any time. Preset server operators may discontinue providing the servers, at any time.
**Resolving disputes**. You agree to resolve any Claim you have with us relating to or arising from our Conditions, us, or our Applications in the courts of England and Wales. You also agree to submit to the personal jurisdiction of such courts for the purpose of resolving all such disputes. The laws of England govern our Conditions, as well as any disputes, whether in court or arbitration, which might arise between SimpleX Chat Ltd and you, without regard to conflict of law provisions.
**Resolving disputes**. You agree to resolve any Claim you have with SimpleX Chat Ltd and/or preset server operators relating to or arising from these Conditions, them, or the Applications in the courts of England and Wales. You also agree to submit to the personal jurisdiction of such courts for the purpose of resolving all such disputes. The laws of England govern these Conditions, as well as any disputes, whether in court or arbitration, which might arise between SimpleX Chat Ltd (or preset server operators) and you, without regard to conflict of law provisions.
**Changes to the conditions**. SimpleX Chat Ltd may update the Conditions from time to time. Your continued use of our Applications confirms your acceptance of our updated Conditions and supersedes any prior Conditions. You will comply with all applicable export control and trade sanctions laws. Our Conditions cover the entire agreement between you and SimpleX Chat Ltd regarding our Applications. If you do not agree with our Conditions, you should stop using our Applications.
**Changes to the conditions**. SimpleX Chat Ltd may update the Conditions from time to time. The updated conditions have to be accepted within 30 days. Even if you fail to accept updated conditions, your continued use of SimpleX Chat Applications confirms your acceptance of the updated Conditions and supersedes any prior Conditions. You will comply with all applicable export control and trade sanctions laws. These Conditions cover the entire agreement between you and SimpleX Chat Ltd, and any preset server operators where applicable, regarding SimpleX Chat Applications. If you do not agree with these Conditions, you should stop using the Applications.
**Enforcing the conditions**. If we fail to enforce any of our Conditions, that does not mean we waive the right to enforce them. If any provision of the Conditions is deemed unlawful, void, or unenforceable, that provision shall be deemed severable from our Conditions and shall not affect the enforceability of the remaining provisions. Our Applications are not intended for distribution to or use in any country where such distribution or use would violate local law or would subject us to any regulations in another country. We reserve the right to limit our Applications in any country. If you have specific questions about these Conditions, please contact us at chat@simplex.chat.
**Enforcing the conditions**. If SimpleX Chat Ltd or preset server operators fail to enforce any of these Conditions, that does not mean they waive the right to enforce them. If any provision of the Conditions is deemed unlawful, void, or unenforceable, that provision shall be deemed severable from the Conditions and shall not affect the enforceability of the remaining provisions. The Applications are not intended for distribution to or use in any country where such distribution or use would violate local law or would subject SimpleX Chat Ltd to any regulations in another country. SimpleX Chat Ltd reserve the right to limit the access to the Applications in any country. Preset operators reserve the right to limit access to their servers in any country. If you have specific questions about these Conditions, please contact SimpleX Chat Ltd at chat@simplex.chat.
**Ending these conditions**. You may end these Conditions with SimpleX Chat Ltd at any time by deleting our Applications from your devices and discontinuing use of our Infrastructure. The provisions related to Licenses, Disclaimers, Limitation of Liability, Resolving dispute, Availability, Changes to the conditions, Enforcing the conditions, and Ending these conditions will survive termination of your relationship with SimpleX Chat Ltd.
**Ending these conditions**. You may end these Conditions with SimpleX Chat Ltd and preset server operators at any time by deleting the Applications from your devices and discontinuing use of the Infrastructure of SimpleX Chat Ltd and preset server operators. The provisions related to Licenses, Disclaimers, Limitation of Liability, Resolving dispute, Availability, Changes to the conditions, Enforcing the conditions, and Ending these conditions will survive termination of your relationship with SimpleX Chat Ltd and/or preset server operators.
Updated October 14, 2024
Updated November 14, 2024
@@ -124,7 +124,7 @@ struct UserPicker: View {
ZStack(alignment: .topTrailing) {
ProfileImage(imageStr: u.user.image, size: size, color: Color(uiColor: .tertiarySystemGroupedBackground))
if (u.unreadCount > 0) {
unreadBadge(u).offset(x: 4, y: -4)
UnreadBadge(userInfo: u).offset(x: 4, y: -4)
}
}
.padding(.trailing, 6)
@@ -169,15 +169,21 @@ struct UserPicker: View {
}
}
}
private func unreadBadge(_ u: UserInfo) -> some View {
}
struct UnreadBadge: View {
var userInfo: UserInfo
@EnvironmentObject var theme: AppTheme
@Environment(\.dynamicTypeSize) private var userFont: DynamicTypeSize
var body: some View {
let size = dynamicSize(userFont).chatInfoSize
return unreadCountText(u.unreadCount)
.font(userFont <= .xxxLarge ? .caption : .caption2)
unreadCountText(userInfo.unreadCount)
.font(userFont <= .xxxLarge ? .caption : .caption2)
.foregroundColor(.white)
.padding(.horizontal, dynamicSize(userFont).unreadPadding)
.frame(minWidth: size, minHeight: size)
.background(u.user.showNtfs ? theme.colors.primary : theme.colors.secondary)
.background(userInfo.user.showNtfs ? theme.colors.primary : theme.colors.secondary)
.cornerRadius(dynamicSize(userFont).unreadCorner)
}
}
@@ -21,6 +21,7 @@ struct UserProfilesView: View {
@State private var profileHidden = false
@State private var profileAction: UserProfileAction?
@State private var actionPassword = ""
@State private var navigateToProfileCreate = false
var trimmedSearchTextOrPassword: String { searchTextOrPassword.trimmingCharacters(in: .whitespaces)}
@@ -55,17 +56,6 @@ struct UserProfilesView: View {
}
var body: some View {
if authorized {
userProfilesView()
} else {
Button(action: runAuth) { Label("Unlock", systemImage: "lock") }
.onAppear(perform: runAuth)
}
}
private func runAuth() { authorize(NSLocalizedString("Open user profiles", comment: "authentication reason"), $authorized) }
private func userProfilesView() -> some View {
List {
if profileHidden {
Button {
@@ -77,12 +67,14 @@ struct UserProfilesView: View {
Section {
let users = filteredUsers()
let v = ForEach(users) { u in
userView(u.user)
userView(u)
}
if #available(iOS 16, *) {
v.onDelete { indexSet in
if let i = indexSet.first {
confirmDeleteUser(users[i].user)
withAuth {
confirmDeleteUser(users[i].user)
}
}
}
} else {
@@ -90,12 +82,22 @@ struct UserProfilesView: View {
}
if trimmedSearchTextOrPassword == "" {
NavigationLink {
CreateProfile()
} label: {
NavigationLink(
destination: CreateProfile(),
isActive: $navigateToProfileCreate
) {
Label("Add profile", systemImage: "plus")
.frame(maxWidth: .infinity, alignment: .leading)
.frame(height: 38)
.padding(.leading, 16).padding(.vertical, 8).padding(.trailing, 32)
.contentShape(Rectangle())
.onTapGesture {
withAuth {
self.navigateToProfileCreate = true
}
}
.padding(.leading, -16).padding(.vertical, -8).padding(.trailing, -32)
}
.frame(height: 38)
}
} footer: {
Text("Tap to activate profile.")
@@ -189,7 +191,25 @@ struct UserProfilesView: View {
private var visibleUsersCount: Int {
m.users.filter({ u in !u.user.hidden }).count
}
private func withAuth(_ action: @escaping () -> Void) {
if authorized {
action()
} else {
authenticate(
reason: NSLocalizedString("Change user profiles", comment: "authentication reason")
) { laResult in
switch laResult {
case .success, .unavailable:
authorized = true
AppSheetState.shared.scenePhaseActive = true
DispatchQueue.main.asyncAfter(deadline: .now() + 0.5, execute: action)
case .failed: authorized = false
}
}
}
}
private func correctPassword(_ user: User, _ pwd: String) -> Bool {
if let ph = user.viewPwdHash {
return pwd != "" && chatPasswordHash(pwd, ph.salt) == ph.hash
@@ -213,8 +233,10 @@ struct UserProfilesView: View {
passwordField
settingsRow("trash", color: theme.colors.secondary) {
Button("Delete chat profile", role: .destructive) {
profileAction = nil
Task { await removeUser(user, delSMPQueues, viewPwd: actionPassword) }
withAuth {
profileAction = nil
Task { await removeUser(user, delSMPQueues, viewPwd: actionPassword) }
}
}
.disabled(!actionEnabled(user))
}
@@ -231,8 +253,10 @@ struct UserProfilesView: View {
passwordField
settingsRow("lock.open", color: theme.colors.secondary) {
Button("Unhide chat profile") {
profileAction = nil
setUserPrivacy(user) { try await apiUnhideUser(user.userId, viewPwd: actionPassword) }
withAuth{
profileAction = nil
setUserPrivacy(user) { try await apiUnhideUser(user.userId, viewPwd: actionPassword) }
}
}
.disabled(!actionEnabled(user))
}
@@ -255,11 +279,13 @@ struct UserProfilesView: View {
private func deleteModeButton(_ title: LocalizedStringKey, _ delSMPQueues: Bool) -> some View {
Button(title, role: .destructive) {
if let user = userToDelete {
if passwordEntryRequired(user) {
profileAction = .deleteUser(user: user, delSMPQueues: delSMPQueues)
} else {
alert = .deleteUser(user: user, delSMPQueues: delSMPQueues)
withAuth {
if let user = userToDelete {
if passwordEntryRequired(user) {
profileAction = .deleteUser(user: user, delSMPQueues: delSMPQueues)
} else {
alert = .deleteUser(user: user, delSMPQueues: delSMPQueues)
}
}
}
}
@@ -301,7 +327,8 @@ struct UserProfilesView: View {
}
}
@ViewBuilder private func userView(_ user: User) -> some View {
@ViewBuilder private func userView(_ userInfo: UserInfo) -> some View {
let user = userInfo.user
let v = Button {
Task {
do {
@@ -319,12 +346,19 @@ struct UserProfilesView: View {
Spacer()
if user.activeUser {
Image(systemName: "checkmark").foregroundColor(theme.colors.onBackground)
} else if user.hidden {
Image(systemName: "lock").foregroundColor(theme.colors.secondary)
} else if !user.showNtfs {
Image(systemName: "speaker.slash").foregroundColor(theme.colors.secondary)
} else {
Image(systemName: "checkmark").foregroundColor(.clear)
if userInfo.unreadCount > 0 {
UnreadBadge(userInfo: userInfo)
}
if user.hidden {
Image(systemName: "lock").foregroundColor(theme.colors.secondary)
} else if userInfo.unreadCount == 0 {
if !user.showNtfs {
Image(systemName: "speaker.slash").foregroundColor(theme.colors.secondary)
} else {
Image(systemName: "checkmark").foregroundColor(.clear)
}
}
}
}
}
@@ -332,30 +366,38 @@ struct UserProfilesView: View {
.swipeActions(edge: .leading, allowsFullSwipe: true) {
if user.hidden {
Button("Unhide") {
if passwordEntryRequired(user) {
profileAction = .unhideUser(user: user)
} else {
setUserPrivacy(user) { try await apiUnhideUser(user.userId, viewPwd: trimmedSearchTextOrPassword) }
withAuth {
if passwordEntryRequired(user) {
profileAction = .unhideUser(user: user)
} else {
setUserPrivacy(user) { try await apiUnhideUser(user.userId, viewPwd: trimmedSearchTextOrPassword) }
}
}
}
.tint(.green)
} else {
if visibleUsersCount > 1 {
Button("Hide") {
selectedUser = user
withAuth {
selectedUser = user
}
}
.tint(.gray)
}
Group {
if user.showNtfs {
Button("Mute") {
setUserPrivacy(user, successAlert: showMuteProfileAlert ? .muteProfileAlert : nil) {
try await apiMuteUser(user.userId)
withAuth {
setUserPrivacy(user, successAlert: showMuteProfileAlert ? .muteProfileAlert : nil) {
try await apiMuteUser(user.userId)
}
}
}
} else {
Button("Unmute") {
setUserPrivacy(user) { try await apiUnmuteUser(user.userId) }
withAuth {
setUserPrivacy(user) { try await apiUnmuteUser(user.userId) }
}
}
}
}
@@ -367,7 +409,9 @@ struct UserProfilesView: View {
} else {
v.swipeActions(edge: .trailing, allowsFullSwipe: true) {
Button("Delete", role: .destructive) {
confirmDeleteUser(user)
withAuth {
confirmDeleteUser(user)
}
}
}
}
+21 -13
View File
@@ -149,9 +149,9 @@
6419EC582AB97507004A607A /* CIMemberCreatedContactView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 6419EC572AB97507004A607A /* CIMemberCreatedContactView.swift */; };
6432857C2925443C00FBE5C8 /* GroupPreferencesView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 6432857B2925443C00FBE5C8 /* GroupPreferencesView.swift */; };
643B3B452CCBEB080083A2CF /* libgmpxx.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B402CCBEB080083A2CF /* libgmpxx.a */; };
643B3B462CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a */; };
643B3B462CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a */; };
643B3B472CCBEB080083A2CF /* libffi.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B422CCBEB080083A2CF /* libffi.a */; };
643B3B482CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a */; };
643B3B482CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a */; };
643B3B492CCBEB080083A2CF /* libgmp.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B442CCBEB080083A2CF /* libgmp.a */; };
6440CA00288857A10062C672 /* CIEventView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 6440C9FF288857A10062C672 /* CIEventView.swift */; };
6440CA03288AECA70062C672 /* AddGroupMembersView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 6440CA02288AECA70062C672 /* AddGroupMembersView.swift */; };
@@ -497,9 +497,9 @@
6419EC572AB97507004A607A /* CIMemberCreatedContactView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = CIMemberCreatedContactView.swift; sourceTree = "<group>"; };
6432857B2925443C00FBE5C8 /* GroupPreferencesView.swift */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.swift; path = GroupPreferencesView.swift; sourceTree = "<group>"; };
643B3B402CCBEB080083A2CF /* libgmpxx.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = libgmpxx.a; path = Libraries/libgmpxx.a; sourceTree = "<group>"; };
643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = "libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a"; path = "Libraries/libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a"; sourceTree = "<group>"; };
643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = "libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a"; path = "Libraries/libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a"; sourceTree = "<group>"; };
643B3B422CCBEB080083A2CF /* libffi.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = libffi.a; path = Libraries/libffi.a; sourceTree = "<group>"; };
643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = "libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a"; path = "Libraries/libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a"; sourceTree = "<group>"; };
643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = "libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a"; path = "Libraries/libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a"; sourceTree = "<group>"; };
643B3B442CCBEB080083A2CF /* libgmp.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = libgmp.a; path = Libraries/libgmp.a; sourceTree = "<group>"; };
6440C9FF288857A10062C672 /* CIEventView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = CIEventView.swift; sourceTree = "<group>"; };
6440CA02288AECA70062C672 /* AddGroupMembersView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = AddGroupMembersView.swift; sourceTree = "<group>"; };
@@ -673,8 +673,8 @@
5CE2BA93284534B000EC33A6 /* libiconv.tbd in Frameworks */,
5CE2BA94284534BB00EC33A6 /* libz.tbd in Frameworks */,
CE38A29C2C3FCD72005ED185 /* SwiftyGif in Frameworks */,
643B3B482CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a in Frameworks */,
643B3B462CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a in Frameworks */,
643B3B482CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a in Frameworks */,
643B3B462CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a in Frameworks */,
);
runOnlyForDeploymentPostprocessing = 0;
};
@@ -825,8 +825,8 @@
643B3B422CCBEB080083A2CF /* libffi.a */,
643B3B442CCBEB080083A2CF /* libgmp.a */,
643B3B402CCBEB080083A2CF /* libgmpxx.a */,
643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a */,
643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a */,
643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a */,
643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a */,
5CA059C2279559F40002BEB4 /* Shared */,
5CDCAD462818589900503DA2 /* SimpleX NSE */,
CEE723A82C3BD3D70009AE93 /* SimpleX SE */,
@@ -922,10 +922,9 @@
5CB924DF27A8678B00ACCCDD /* UserSettings */ = {
isa = PBXGroup;
children = (
643B3B4C2CCFD34B0083A2CF /* NetworkAndServers */,
5CB924D627A8563F00ACCCDD /* SettingsView.swift */,
5CB346E62868D76D001FD2EF /* NotificationsView.swift */,
5C9C2DA6289957AE00CC63B1 /* AdvancedNetworkSettings.swift */,
5C9C2DA82899DA6F00CC63B1 /* NetworkAndServers.swift */,
5CADE79929211BB900072E13 /* PreferencesView.swift */,
5C5DB70D289ABDD200730FFF /* AppearanceSettings.swift */,
5C05DF522840AA1D00C683F9 /* CallSettings.swift */,
@@ -933,9 +932,6 @@
5CC036DF29C488D500C0EF20 /* HiddenProfileView.swift */,
5C577F7C27C83AA10006112D /* MarkdownHelp.swift */,
5C3F1D57284363C400EC8A82 /* PrivacySettings.swift */,
5C93292E29239A170090FFF9 /* ProtocolServersView.swift */,
5C93293029239BED0090FFF9 /* ProtocolServerView.swift */,
5C9329402929248A0090FFF9 /* ScanProtocolServer.swift */,
5CB2084E28DA4B4800D024EC /* RTCServers.swift */,
64F1CC3A28B39D8600CD1FB1 /* IncognitoHelp.swift */,
18415845648CA4F5A8BCA272 /* UserProfilesView.swift */,
@@ -1066,6 +1062,18 @@
path = Database;
sourceTree = "<group>";
};
643B3B4C2CCFD34B0083A2CF /* NetworkAndServers */ = {
isa = PBXGroup;
children = (
5C9329402929248A0090FFF9 /* ScanProtocolServer.swift */,
5C93293029239BED0090FFF9 /* ProtocolServerView.swift */,
5C93292E29239A170090FFF9 /* ProtocolServersView.swift */,
5C9C2DA6289957AE00CC63B1 /* AdvancedNetworkSettings.swift */,
5C9C2DA82899DA6F00CC63B1 /* NetworkAndServers.swift */,
);
path = NetworkAndServers;
sourceTree = "<group>";
};
6440CA01288AEC770062C672 /* Group */ = {
isa = PBXGroup;
children = (
@@ -268,22 +268,32 @@ fun UserPicker(
painterResource(MR.images.ic_manage_accounts),
stringResource(MR.strings.your_chat_profiles),
{
doWithAuth(
generalGetString(MR.strings.auth_open_chat_profiles),
generalGetString(MR.strings.auth_log_in_using_credential)
) {
ModalManager.start.showCustomModal(keyboardCoversBar = false) { close ->
val search = rememberSaveable { mutableStateOf("") }
val profileHidden = rememberSaveable { mutableStateOf(false) }
ModalView(
{ close() },
showSearch = true,
searchAlwaysVisible = true,
onSearchValueChanged = {
search.value = it
},
content = { UserProfilesView(chatModel, search, profileHidden) })
}
ModalManager.start.showCustomModal(keyboardCoversBar = false) { close ->
val search = rememberSaveable { mutableStateOf("") }
val profileHidden = rememberSaveable { mutableStateOf(false) }
val authorized = remember { stateGetOrPut("authorized") { false } }
ModalView(
{ close() },
showSearch = true,
searchAlwaysVisible = true,
onSearchValueChanged = {
search.value = it
},
content = {
UserProfilesView(chatModel, search, profileHidden) { block ->
if (authorized.value) {
block()
} else {
doWithAuth(
generalGetString(MR.strings.auth_open_chat_profiles),
generalGetString(MR.strings.auth_log_in_using_credential)
) {
authorized.value = true
block()
}
}
}
})
}
},
disabled = stopped
@@ -412,26 +422,35 @@ fun UserProfilePickerItem(
UserProfileRow(u, enabled)
if (u.activeUser) {
Icon(painterResource(MR.images.ic_done_filled), null, Modifier.size(20.dp), tint = MaterialTheme.colors.onBackground)
} else if (u.hidden) {
Icon(painterResource(MR.images.ic_lock), null, Modifier.size(20.dp), tint = MaterialTheme.colors.secondary)
} else if (unreadCount > 0) {
Box(
contentAlignment = Alignment.Center
) {
Text(
unreadCountStr(unreadCount),
color = Color.White,
fontSize = 10.sp,
modifier = Modifier
.background(MaterialTheme.colors.primaryVariant, shape = CircleShape)
.padding(2.dp)
.badgeLayout()
)
}
} else if (!u.showNtfs) {
Icon(painterResource(MR.images.ic_notifications_off), null, Modifier.size(20.dp), tint = MaterialTheme.colors.secondary)
} else {
Box(Modifier.size(20.dp))
Row(verticalAlignment = Alignment.CenterVertically) {
if (unreadCount > 0) {
Box(
contentAlignment = Alignment.Center,
) {
Text(
unreadCountStr(unreadCount),
color = Color.White,
fontSize = 10.sp,
modifier = Modifier
.background(if (u.showNtfs) MaterialTheme.colors.primaryVariant else MaterialTheme.colors.secondary, shape = CircleShape)
.padding(2.dp)
.badgeLayout()
)
}
if (u.hidden) {
Spacer(Modifier.width(8.dp))
Icon(painterResource(MR.images.ic_lock), null, Modifier.size(20.dp), tint = MaterialTheme.colors.secondary)
}
} else if (u.hidden) {
Icon(painterResource(MR.images.ic_lock), null, Modifier.size(20.dp), tint = MaterialTheme.colors.secondary)
} else if (!u.showNtfs) {
Icon(painterResource(MR.images.ic_notifications_off), null, Modifier.size(20.dp), tint = MaterialTheme.colors.secondary)
} else {
Box(Modifier.size(20.dp))
}
}
}
}
}
@@ -36,7 +36,7 @@ import dev.icerock.moko.resources.StringResource
import kotlinx.coroutines.*
@Composable
fun UserProfilesView(m: ChatModel, search: MutableState<String>, profileHidden: MutableState<Boolean>) {
fun UserProfilesView(m: ChatModel, search: MutableState<String>, profileHidden: MutableState<Boolean>, withAuth: (block: () -> Unit) -> Unit) {
val searchTextOrPassword = rememberSaveable { search }
val users by remember { derivedStateOf { m.users.map { it.user } } }
val filteredUsers by remember { derivedStateOf { filteredUsers(m, searchTextOrPassword.value) } }
@@ -48,8 +48,10 @@ fun UserProfilesView(m: ChatModel, search: MutableState<String>, profileHidden:
showHiddenProfilesNotice = m.controller.appPrefs.showHiddenProfilesNotice,
visibleUsersCount = visibleUsersCount(m),
addUser = {
ModalManager.center.showModalCloseable { close ->
CreateProfile(m, close)
withAuth {
ModalManager.center.showModalCloseable { close ->
CreateProfile(m, close)
}
}
},
activateUser = { user ->
@@ -64,68 +66,78 @@ fun UserProfilesView(m: ChatModel, search: MutableState<String>, profileHidden:
}
},
removeUser = { user ->
val text = buildAnnotatedString {
append(generalGetString(MR.strings.users_delete_all_chats_deleted) + "\n\n" + generalGetString(MR.strings.users_delete_profile_for) + " ")
withStyle(SpanStyle(fontWeight = FontWeight.Bold)) {
append(user.displayName)
withAuth {
val text = buildAnnotatedString {
append(generalGetString(MR.strings.users_delete_all_chats_deleted) + "\n\n" + generalGetString(MR.strings.users_delete_profile_for) + " ")
withStyle(SpanStyle(fontWeight = FontWeight.Bold)) {
append(user.displayName)
}
append(":")
}
append(":")
}
AlertManager.shared.showAlertDialogButtonsColumn(
title = generalGetString(MR.strings.users_delete_question),
text = text,
buttons = {
Column {
SectionItemView({
AlertManager.shared.hideAlert()
removeUser(m, user, users, true, searchTextOrPassword.value.trim())
}) {
Text(stringResource(MR.strings.users_delete_with_connections), Modifier.fillMaxWidth(), textAlign = TextAlign.Center, color = Color.Red)
}
SectionItemView({
AlertManager.shared.hideAlert()
removeUser(m, user, users, false, searchTextOrPassword.value.trim())
}
) {
Text(stringResource(MR.strings.users_delete_data_only), Modifier.fillMaxWidth(), textAlign = TextAlign.Center, color = Color.Red)
AlertManager.shared.showAlertDialogButtonsColumn(
title = generalGetString(MR.strings.users_delete_question),
text = text,
buttons = {
Column {
SectionItemView({
AlertManager.shared.hideAlert()
removeUser(m, user, users, true, searchTextOrPassword.value.trim())
}) {
Text(stringResource(MR.strings.users_delete_with_connections), Modifier.fillMaxWidth(), textAlign = TextAlign.Center, color = Color.Red)
}
SectionItemView({
AlertManager.shared.hideAlert()
removeUser(m, user, users, false, searchTextOrPassword.value.trim())
}
) {
Text(stringResource(MR.strings.users_delete_data_only), Modifier.fillMaxWidth(), textAlign = TextAlign.Center, color = Color.Red)
}
}
}
}
)
)
}
},
unhideUser = { user ->
if (passwordEntryRequired(user, searchTextOrPassword.value)) {
ModalManager.start.showModalCloseable(true) { close ->
ProfileActionView(UserProfileAction.UNHIDE, user) { pwd ->
withBGApi {
setUserPrivacy(m) { m.controller.apiUnhideUser(user, pwd) }
close()
withAuth {
if (passwordEntryRequired(user, searchTextOrPassword.value)) {
ModalManager.start.showModalCloseable(true) { close ->
ProfileActionView(UserProfileAction.UNHIDE, user) { pwd ->
withBGApi {
setUserPrivacy(m) { m.controller.apiUnhideUser(user, pwd) }
close()
}
}
}
} else {
withBGApi { setUserPrivacy(m) { m.controller.apiUnhideUser(user, searchTextOrPassword.value.trim()) } }
}
} else {
withBGApi { setUserPrivacy(m) { m.controller.apiUnhideUser(user, searchTextOrPassword.value.trim()) } }
}
},
muteUser = { user ->
withBGApi {
setUserPrivacy(m, onSuccess = {
if (m.controller.appPrefs.showMuteProfileAlert.get()) showMuteProfileAlert(m.controller.appPrefs.showMuteProfileAlert)
}) { m.controller.apiMuteUser(user) }
withAuth {
withBGApi {
setUserPrivacy(m, onSuccess = {
if (m.controller.appPrefs.showMuteProfileAlert.get()) showMuteProfileAlert(m.controller.appPrefs.showMuteProfileAlert)
}) { m.controller.apiMuteUser(user) }
}
}
},
unmuteUser = { user ->
withBGApi { setUserPrivacy(m) { m.controller.apiUnmuteUser(user) } }
withAuth {
withBGApi { setUserPrivacy(m) { m.controller.apiUnmuteUser(user) } }
}
},
showHiddenProfile = { user ->
ModalManager.start.showModalCloseable(true) { close ->
HiddenProfileView(m, user) {
profileHidden.value = true
withBGApi {
delay(10_000)
profileHidden.value = false
withAuth {
ModalManager.start.showModalCloseable(true) { close ->
HiddenProfileView(m, user) {
profileHidden.value = true
withBGApi {
delay(10_000)
profileHidden.value = false
}
close()
}
close()
}
}
}
@@ -138,7 +150,7 @@ fun UserProfilesView(m: ChatModel, search: MutableState<String>, profileHidden:
@Composable
private fun UserProfilesLayout(
users: List<User>,
filteredUsers: List<User>,
filteredUsers: List<UserInfo>,
searchTextOrPassword: MutableState<String>,
profileHidden: MutableState<Boolean>,
visibleUsersCount: Int,
@@ -195,7 +207,7 @@ private fun UserProfilesLayout(
@Composable
private fun UserView(
user: User,
userInfo: UserInfo,
visibleUsersCount: Int,
activateUser: (User) -> Unit,
removeUser: (User) -> Unit,
@@ -205,7 +217,8 @@ private fun UserView(
showHiddenProfile: (User) -> Unit,
) {
val showMenu = remember { mutableStateOf(false) }
UserProfilePickerItem(user, onLongClick = { showMenu.value = true }) {
val user = userInfo.user
UserProfilePickerItem(user, onLongClick = { showMenu.value = true }, unreadCount = userInfo.unreadCount) {
activateUser(user)
}
Box(Modifier.padding(horizontal = DEFAULT_PADDING)) {
@@ -290,7 +303,7 @@ private fun ProfileActionView(action: UserProfileAction, user: User, doAction: (
}
}
fun filteredUsers(m: ChatModel, searchTextOrPassword: String): List<User> {
fun filteredUsers(m: ChatModel, searchTextOrPassword: String): List<UserInfo> {
val s = searchTextOrPassword.trim()
val lower = s.lowercase()
return m.users.filter { u ->
@@ -299,7 +312,7 @@ fun filteredUsers(m: ChatModel, searchTextOrPassword: String): List<User> {
} else {
correctPassword(u.user, s)
}
}.map { it.user }
}
}
private fun visibleUsersCount(m: ChatModel): Int = m.users.filter { u -> !u.user.hidden }.size
@@ -267,7 +267,7 @@
<string name="auth_device_authentication_is_disabled_turning_off">Device authentication is disabled. Turning off SimpleX Lock.</string>
<string name="auth_stop_chat">Stop chat</string>
<string name="auth_open_chat_console">Open chat console</string>
<string name="auth_open_chat_profiles">Open chat profiles</string>
<string name="auth_open_chat_profiles">Change chat profiles</string>
<string name="auth_open_migration_to_another_device">Open migration screen</string>
<string name="lock_not_enabled">SimpleX Lock not enabled!</string>
<string name="you_can_turn_on_lock">You can turn on SimpleX Lock via Settings.</string>
+6 -4
View File
@@ -9,6 +9,7 @@ module Main where
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Chat.Bot
import Simplex.Chat.Controller
@@ -18,6 +19,7 @@ import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Options
import Simplex.Chat.Terminal (terminalChatConfig)
import Simplex.Chat.Types
import Simplex.Messaging.Util (tshow)
import System.Directory (getAppUserDataDirectory)
import Text.Read
@@ -34,7 +36,7 @@ welcomeGetOpts = do
putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
pure opts
welcomeMessage :: String
welcomeMessage :: Text
welcomeMessage = "Hello! I am a simple squaring bot.\nIf you send me a number, I will calculate its square"
mySquaringBot :: User -> ChatController -> IO ()
@@ -47,10 +49,10 @@ mySquaringBot _user cc = do
contactConnected contact
sendMessage cc contact welcomeMessage
CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) : _} -> do
let msg = T.unpack $ ciContentToText mc
number_ = readMaybe msg :: Maybe Integer
let msg = ciContentToText mc
number_ = readMaybe (T.unpack msg) :: Maybe Integer
sendMessage cc contact $ case number_ of
Just n -> msg <> " * " <> msg <> " = " <> show (n * n)
Just n -> msg <> " * " <> msg <> " = " <> tshow (n * n)
_ -> "\"" <> msg <> "\" is not a number"
_ -> pure ()
where
@@ -21,6 +21,7 @@ import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Types
import Simplex.Messaging.Util (tshow)
import System.Directory (getAppUserDataDirectory)
welcomeGetOpts :: IO BroadcastBotOpts
@@ -48,14 +49,14 @@ broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _u
CRContactsList _ cts -> void . forkIO $ do
let cts' = filter broadcastTo cts
forM_ cts' $ \ct' -> sendComposedMessage cc ct' Nothing mc
sendReply $ "Forwarded to " <> show (length cts') <> " contact(s)"
sendReply $ "Forwarded to " <> tshow (length cts') <> " contact(s)"
r -> putStrLn $ "Error getting contacts list: " <> show r
else sendReply "!1 Message is not supported!"
| otherwise -> do
sendReply prohibitedMessage
deleteMessage cc ct $ chatItemId' ci
where
sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . textMsgContent
sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . MCText
publisher = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
allowContent = \case
MCText _ -> True
@@ -7,6 +7,7 @@
module Broadcast.Options where
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Options.Applicative
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
@@ -15,14 +16,14 @@ import Simplex.Chat.Options (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, coreC
data BroadcastBotOpts = BroadcastBotOpts
{ coreOptions :: CoreChatOpts,
publishers :: [KnownContact],
welcomeMessage :: String,
prohibitedMessage :: String
welcomeMessage :: Text,
prohibitedMessage :: Text
}
defaultWelcomeMessage :: [KnownContact] -> String
defaultWelcomeMessage :: [KnownContact] -> Text
defaultWelcomeMessage ps = "Hello! I am a broadcast bot.\nI broadcast messages to all connected users from " <> knownContactNames ps <> "."
defaultProhibitedMessage :: [KnownContact] -> String
defaultProhibitedMessage :: [KnownContact] -> Text
defaultProhibitedMessage ps = "Sorry, only these users can broadcast messages: " <> knownContactNames ps <> ". Your message is deleted."
broadcastBotOpts :: FilePath -> FilePath -> Parser BroadcastBotOpts
@@ -89,10 +89,11 @@ crDirectoryEvent = \case
CRChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors)
_ -> Nothing
data DirectoryRole = DRUser | DRSuperUser
data DirectoryRole = DRUser | DRAdmin | DRSuperUser
data SDirectoryRole (r :: DirectoryRole) where
SDRUser :: SDirectoryRole 'DRUser
SDRAdmin :: SDirectoryRole 'DRAdmin
SDRSuperUser :: SDirectoryRole 'DRSuperUser
deriving instance Show (SDirectoryRole r)
@@ -107,12 +108,14 @@ data DirectoryCmdTag (r :: DirectoryRole) where
DCListUserGroups_ :: DirectoryCmdTag 'DRUser
DCDeleteGroup_ :: DirectoryCmdTag 'DRUser
DCSetRole_ :: DirectoryCmdTag 'DRUser
DCApproveGroup_ :: DirectoryCmdTag 'DRSuperUser
DCRejectGroup_ :: DirectoryCmdTag 'DRSuperUser
DCSuspendGroup_ :: DirectoryCmdTag 'DRSuperUser
DCResumeGroup_ :: DirectoryCmdTag 'DRSuperUser
DCListLastGroups_ :: DirectoryCmdTag 'DRSuperUser
DCListPendingGroups_ :: DirectoryCmdTag 'DRSuperUser
DCApproveGroup_ :: DirectoryCmdTag 'DRAdmin
DCRejectGroup_ :: DirectoryCmdTag 'DRAdmin
DCSuspendGroup_ :: DirectoryCmdTag 'DRAdmin
DCResumeGroup_ :: DirectoryCmdTag 'DRAdmin
DCListLastGroups_ :: DirectoryCmdTag 'DRAdmin
DCListPendingGroups_ :: DirectoryCmdTag 'DRAdmin
DCShowGroupLink_ :: DirectoryCmdTag 'DRAdmin
DCSendToGroupOwner_ :: DirectoryCmdTag 'DRAdmin
DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser
deriving instance Show (DirectoryCmdTag r)
@@ -130,12 +133,14 @@ data DirectoryCmd (r :: DirectoryRole) where
DCListUserGroups :: DirectoryCmd 'DRUser
DCDeleteGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
DCSetRole :: GroupId -> GroupName -> GroupMemberRole -> DirectoryCmd 'DRUser
DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRSuperUser
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCListLastGroups :: Int -> DirectoryCmd 'DRSuperUser
DCListPendingGroups :: Int -> DirectoryCmd 'DRSuperUser
DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRAdmin
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCListLastGroups :: Int -> DirectoryCmd 'DRAdmin
DCListPendingGroups :: Int -> DirectoryCmd 'DRAdmin
DCShowGroupLink :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCSendToGroupOwner :: GroupId -> GroupName -> Text -> DirectoryCmd 'DRAdmin
DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser
DCUnknownCommand :: DirectoryCmd 'DRUser
DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
@@ -168,17 +173,20 @@ directoryCmdP =
"ls" -> u DCListUserGroups_
"delete" -> u DCDeleteGroup_
"role" -> u DCSetRole_
"approve" -> su DCApproveGroup_
"reject" -> su DCRejectGroup_
"suspend" -> su DCSuspendGroup_
"resume" -> su DCResumeGroup_
"last" -> su DCListLastGroups_
"pending" -> su DCListPendingGroups_
"approve" -> au DCApproveGroup_
"reject" -> au DCRejectGroup_
"suspend" -> au DCSuspendGroup_
"resume" -> au DCResumeGroup_
"last" -> au DCListLastGroups_
"pending" -> au DCListPendingGroups_
"link" -> au DCShowGroupLink_
"owner" -> au DCSendToGroupOwner_
"exec" -> su DCExecuteCommand_
"x" -> su DCExecuteCommand_
_ -> fail "bad command tag"
where
u = pure . ADCT SDRUser
au = pure . ADCT SDRAdmin
su = pure . ADCT SDRSuperUser
cmdP :: DirectoryCmdTag r -> Parser (DirectoryCmd r)
cmdP = \case
@@ -203,6 +211,11 @@ directoryCmdP =
DCResumeGroup_ -> gc DCResumeGroup
DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10)
DCListPendingGroups_ -> DCListPendingGroups <$> (A.space *> A.decimal <|> pure 10)
DCShowGroupLink_ -> gc DCShowGroupLink
DCSendToGroupOwner_ -> do
(groupId, displayName) <- gc (,)
msg <- A.space *> A.takeText
pure $ DCSendToGroupOwner groupId displayName msg
DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText)
where
gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> displayNameP
@@ -213,8 +226,8 @@ directoryCmdP =
quoted c = A.char c *> takeNameTill (== c) <* A.char c
refChar c = c > ' ' && c /= '#' && c /= '@'
viewName :: String -> String
viewName n = if ' ' `elem` n then "'" <> n <> "'" else n
viewName :: Text -> Text
viewName n = if any (== ' ') (T.unpack n) then "'" <> n <> "'" else n
directoryCmdTag :: DirectoryCmd r -> Text
directoryCmdTag = \case
@@ -234,6 +247,8 @@ directoryCmdTag = \case
DCResumeGroup {} -> "resume"
DCListLastGroups _ -> "last"
DCListPendingGroups _ -> "pending"
DCShowGroupLink {} -> "link"
DCSendToGroupOwner {} -> "owner"
DCExecuteCommand _ -> "exec"
DCUnknownCommand -> "unknown"
DCCommandError _ -> "error"
@@ -11,6 +11,7 @@ module Directory.Options
)
where
import qualified Data.Text as T
import Options.Applicative
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
@@ -18,9 +19,10 @@ import Simplex.Chat.Options (ChatOpts (..), ChatCmdLog (..), CoreChatOpts, coreC
data DirectoryOpts = DirectoryOpts
{ coreOptions :: CoreChatOpts,
adminUsers :: [KnownContact],
superUsers :: [KnownContact],
directoryLog :: Maybe FilePath,
serviceName :: String,
serviceName :: T.Text,
searchResults :: Int,
testing :: Bool
}
@@ -28,6 +30,13 @@ data DirectoryOpts = DirectoryOpts
directoryOpts :: FilePath -> FilePath -> Parser DirectoryOpts
directoryOpts appDir defaultDbFileName = do
coreOptions <- coreChatOptsP appDir defaultDbFileName
adminUsers <-
option
parseKnownContacts
( long "admin-users"
<> metavar "ADMIN_USERS"
<> help "Comma-separated list of admin-users in the format CONTACT_ID:DISPLAY_NAME who will be allowed to manage the directory"
)
superUsers <-
option
parseKnownContacts
@@ -52,9 +61,10 @@ directoryOpts appDir defaultDbFileName = do
pure
DirectoryOpts
{ coreOptions,
adminUsers,
superUsers,
directoryLog,
serviceName,
serviceName = T.pack serviceName,
searchResults = 10,
testing = False
}
@@ -17,13 +17,11 @@ import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Logger.Simple
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromMaybe, maybeToList)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Directory.Events
@@ -37,6 +35,7 @@ import Simplex.Chat.Core
import Simplex.Chat.Messages
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Store.Shared (StoreError (..))
import Simplex.Chat.Types
import Simplex.Chat.Types.Shared
import Simplex.Chat.View (serializeChatResponse, simplexChatContact, viewContactName, viewGroupName)
@@ -79,7 +78,7 @@ welcomeGetOpts = do
pure opts
directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> IO ()
directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testing} user@User {userId} cc = do
directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchResults, testing} user@User {userId} cc = do
initializeBotAddress' (not testing) cc
env <- newServiceState
race_ (forever $ void getLine) . forever $ do
@@ -102,6 +101,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
logInfo $ "command received " <> directoryCmdTag cmd
case sUser of
SDRUser -> deUserCommand env ct ciId cmd
SDRAdmin -> deAdminCommand ct ciId cmd
SDRSuperUser -> deSuperUserCommand ct ciId cmd
DELogChatResponse r -> logInfo r
where
@@ -118,9 +118,9 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
userGroupReference gr GroupInfo {groupProfile = GroupProfile {displayName}} = userGroupReference' gr displayName
userGroupReference' GroupReg {userGroupRegId} displayName = groupReference' userGroupRegId displayName
groupReference GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = groupReference' groupId displayName
groupReference' groupId displayName = "ID " <> show groupId <> " (" <> T.unpack displayName <> ")"
groupReference' groupId displayName = "ID " <> tshow groupId <> " (" <> displayName <> ")"
groupAlreadyListed GroupInfo {groupProfile = GroupProfile {displayName, fullName}} =
T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already listed in the directory, please choose another name."
"The group " <> displayName <> " (" <> fullName <> ") is already listed in the directory, please choose another name."
getGroups :: Text -> IO (Maybe [(GroupInfo, GroupSummary)])
getGroups = getGroups_ . Just
@@ -151,7 +151,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = do
void $ addGroupReg st ct g GRSProposed
r <- sendChatCmd cc $ APIJoinGroup groupId
sendMessage cc ct $ T.unpack $ case r of
sendMessage cc ct $ case r of
CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> ""
_ -> "Error joining group " <> displayName <> ", please re-send the invitation!"
@@ -179,10 +179,10 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
where
askConfirmation = do
ugrId <- addGroupReg st ct g GRSPendingConfirmation
sendMessage cc ct $ T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already submitted to the directory.\nTo confirm the registration, please send:"
sendMessage cc ct $ "/confirm " <> show ugrId <> ":" <> viewName (T.unpack displayName)
sendMessage cc ct $ "The group " <> displayName <> " (" <> fullName <> ") is already submitted to the directory.\nTo confirm the registration, please send:"
sendMessage cc ct $ "/confirm " <> tshow ugrId <> ":" <> viewName displayName
badRolesMsg :: GroupRolesStatus -> Maybe String
badRolesMsg :: GroupRolesStatus -> Maybe Text
badRolesMsg = \case
GRSOk -> Nothing
GRSServiceNotAdmin -> Just "You must grant directory service *admin* role to register the group"
@@ -218,7 +218,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
when (ctId `isOwner` gr) $ do
setGroupRegOwner st gr owner
let GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = g
notifyOwner gr $ T.unpack $ "Joined the group " <> displayName <> ", creating the link…"
notifyOwner gr $ "Joined the group " <> displayName <> ", creating the link…"
sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case
CRGroupLinkCreated {connReqContact} -> do
setGroupStatus st gr GRSPendingUpdate
@@ -227,7 +227,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
"Created the public link to join the group via this directory service that is always online.\n\n\
\Please add it to the group welcome message.\n\
\For example, add:"
notifyOwner gr $ "Link to join the group " <> T.unpack displayName <> ": " <> B.unpack (strEncode $ simplexChatContact connReqContact)
notifyOwner gr $ "Link to join the group " <> displayName <> ": " <> strEncodeTxt (simplexChatContact connReqContact)
CRChatCmdError _ (ChatError e) -> case e of
CEGroupUserRole {} -> notifyOwner gr "Failed creating group link, as service is no longer an admin."
CEGroupMemberUserRemoved -> notifyOwner gr "Failed creating group link, as service is removed from the group."
@@ -256,7 +256,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
GPHasServiceLink -> when (ctId `isOwner` gr) $ groupLinkAdded gr
GPServiceLinkError -> do
when (ctId `isOwner` gr) $ notifyOwner gr $ "Error: " <> serviceName <> " has no group link for " <> userGroupRef <> ". Please report the error to the developers."
logError $ "Error: no group link for " <> T.pack userGroupRef
logError $ "Error: no group link for " <> userGroupRef
GRSPendingApproval n -> processProfileChange gr $ n + 1
GRSActive -> processProfileChange gr 1
GRSSuspended -> processProfileChange gr 1
@@ -277,7 +277,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
_ -> do
let gaId = 1
setGroupStatus st gr $ GRSPendingApproval gaId
notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 24 hours."
notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 48 hours."
checkRolesSendToApprove gr gaId
processProfileChange gr n' = do
setGroupStatus st gr GRSPendingUpdate
@@ -299,13 +299,13 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
notifyOwner gr $ "The group " <> userGroupRef <> " is updated!\nIt is hidden from the directory until approved."
notifySuperUsers $ "The group " <> groupRef <> " is updated."
checkRolesSendToApprove gr n'
GPServiceLinkError -> logError $ "Error: no group link for " <> T.pack groupRef <> " pending approval."
GPServiceLinkError -> logError $ "Error: no group link for " <> groupRef <> " pending approval."
groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId)
where
profileUpdate = \case
CRGroupLink {connReqContact} ->
let groupLink1 = safeDecodeUtf8 $ strEncode connReqContact
groupLink2 = safeDecodeUtf8 $ strEncode $ simplexChatContact connReqContact
let groupLink1 = strEncodeTxt connReqContact
groupLink2 = strEncodeTxt $ simplexChatContact connReqContact
hadLinkBefore = groupLink1 `isInfix` description p || groupLink2 `isInfix` description p
hasLinkNow = groupLink1 `isInfix` description p' || groupLink2 `isInfix` description p'
in if
@@ -331,7 +331,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
msg = maybe (MCText text) (\image -> MCImage {text, image}) image'
withSuperUsers $ \cId -> do
sendComposedMessage' cc cId Nothing msg
sendMessage' cc cId $ "/approve " <> show dbGroupId <> ":" <> viewName (T.unpack displayName) <> " " <> show gaId
sendMessage' cc cId $ "/approve " <> tshow dbGroupId <> ":" <> viewName displayName <> " " <> tshow gaId
deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO ()
deContactRoleChanged g@GroupInfo {membership = GroupMember {memberRole = serviceRole}} ctId contactRole = do
@@ -356,7 +356,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
where
rStatus = groupRolesStatus contactRole serviceRole
groupRef = groupReference g
ctRole = "*" <> B.unpack (strEncode contactRole) <> "*"
ctRole = "*" <> strEncodeTxt contactRole <> "*"
suCtRole = "(user role is set to " <> ctRole <> ")."
deServiceRoleChanged :: GroupInfo -> GroupMemberRole -> IO ()
@@ -382,7 +382,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
_ -> pure ()
where
groupRef = groupReference g
srvRole = "*" <> B.unpack (strEncode serviceRole) <> "*"
srvRole = "*" <> strEncodeTxt serviceRole <> "*"
suSrvRole = "(" <> serviceName <> " role is changed to " <> srvRole <> ")."
whenContactIsOwner gr action =
getGroupMember gr
@@ -426,7 +426,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
<> serviceName
<> " bot will create a public group link for the new members to join even when you are offline.\n\
\3. You will then need to add this link to the group welcome message.\n\
\4. Once the link is added, service admins will approve the group (it can take up to 24 hours), and everybody will be able to find it in directory.\n\n\
\4. Once the link is added, service admins will approve the group (it can take up to 48 hours), and everybody will be able to find it in directory.\n\n\
\Start from inviting the bot to your group as admin - it will guide you through the process"
DCSearchGroup s -> withFoundListedGroups (Just s) $ sendSearchResults s
DCSearchNext ->
@@ -448,44 +448,47 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
DCRecentGroups -> withFoundListedGroups Nothing $ sendAllGroups takeRecent "the most recent" STRecent
DCSubmitGroup _link -> pure ()
DCConfirmDuplicateGroup ugrId gName ->
withUserGroupReg ugrId gName $ \gr g@GroupInfo {groupProfile = GroupProfile {displayName}} ->
withUserGroupReg ugrId gName $ \g@GroupInfo {groupProfile = GroupProfile {displayName}} gr ->
readTVarIO (groupRegStatus gr) >>= \case
GRSPendingConfirmation ->
getDuplicateGroup g >>= \case
Nothing -> sendMessage cc ct "Error: getDuplicateGroup. Please notify the developers."
Just DGReserved -> sendMessage cc ct $ groupAlreadyListed g
_ -> processInvitation ct g
_ -> sendReply $ "Error: the group ID " <> show ugrId <> " (" <> T.unpack displayName <> ") is not pending confirmation."
_ -> sendReply $ "Error: the group ID " <> tshow ugrId <> " (" <> displayName <> ") is not pending confirmation."
DCListUserGroups ->
atomically (getUserGroupRegs st $ contactId' ct) >>= \grs -> do
sendReply $ show (length grs) <> " registered group(s)"
sendReply $ tshow (length grs) <> " registered group(s)"
void . forkIO $ forM_ (reverse grs) $ \gr@GroupReg {userGroupRegId} ->
sendGroupInfo ct gr userGroupRegId Nothing
DCDeleteGroup ugrId gName ->
withUserGroupReg ugrId gName $ \gr GroupInfo {groupProfile = GroupProfile {displayName}} -> do
withUserGroupReg ugrId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} gr -> do
delGroupReg st gr
sendReply $ T.unpack $ "Your group " <> displayName <> " is deleted from the directory"
DCSetRole ugrId gName mRole ->
withUserGroupReg ugrId gName $ \_gr GroupInfo {groupId, groupProfile = GroupProfile {displayName}} -> do
gLink_ <- setGroupLinkRole cc groupId mRole
sendReply $ T.unpack $ case gLink_ of
Nothing -> "Error: the initial member role for the group " <> displayName <> " was NOT upgated"
Just gLink ->
("The initial member role for the group " <> displayName <> " is set to *" <> decodeLatin1 (strEncode mRole) <> "*\n\n")
<> ("*Please note*: it applies only to members joining via this link: " <> safeDecodeUtf8 (strEncode $ simplexChatContact gLink))
sendReply $ "Your group " <> displayName <> " is deleted from the directory"
DCSetRole gId gName mRole ->
(if isAdmin then withGroupAndReg sendReply else withUserGroupReg) gId gName $
\GroupInfo {groupId, groupProfile = GroupProfile {displayName}} _gr -> do
gLink_ <- setGroupLinkRole cc groupId mRole
sendReply $ case gLink_ of
Nothing -> "Error: the initial member role for the group " <> displayName <> " was NOT upgated"
Just gLink ->
("The initial member role for the group " <> displayName <> " is set to *" <> strEncodeTxt mRole <> "*\n\n")
<> ("*Please note*: it applies only to members joining via this link: " <> strEncodeTxt (simplexChatContact gLink))
DCUnknownCommand -> sendReply "Unknown command"
DCCommandError tag -> sendReply $ "Command error: " <> show tag
DCCommandError tag -> sendReply $ "Command error: " <> tshow tag
where
knownCt = knownContact ct
isAdmin = knownCt `elem` adminUsers || knownCt `elem` superUsers
withUserGroupReg ugrId gName action =
atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case
Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found"
Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found"
Just gr@GroupReg {dbGroupId} -> do
getGroup cc dbGroupId >>= \case
Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found"
Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found"
Just g@GroupInfo {groupProfile = GroupProfile {displayName}}
| displayName == gName -> action gr g
| otherwise -> sendReply $ "Group ID " <> show ugrId <> " has the display name " <> T.unpack displayName
sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent
| displayName == gName -> action g gr
| otherwise -> sendReply $ "Group ID " <> tshow ugrId <> " has the display name " <> displayName
sendReply = mkSendReply ct ciId
withFoundListedGroups s_ action =
getGroups_ s_ >>= \case
Just groups -> atomically (filterListedGroups st groups) >>= action
@@ -495,8 +498,8 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
gs -> do
let gs' = takeTop searchResults gs
moreGroups = length gs - length gs'
more = if moreGroups > 0 then ", sending top " <> show (length gs') else ""
sendReply $ "Found " <> show (length gs) <> " group(s)" <> more <> "."
more = if moreGroups > 0 then ", sending top " <> tshow (length gs') else ""
sendReply $ "Found " <> tshow (length gs) <> " group(s)" <> more <> "."
updateSearchRequest (STSearch s) $ groupIds gs'
sendFoundGroups gs' moreGroups
sendAllGroups takeFirst sortName searchType = \case
@@ -504,8 +507,8 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
gs -> do
let gs' = takeFirst searchResults gs
moreGroups = length gs - length gs'
more = if moreGroups > 0 then ", sending " <> sortName <> " " <> show (length gs') else ""
sendReply $ show (length gs) <> " group(s) listed" <> more <> "."
more = if moreGroups > 0 then ", sending " <> sortName <> " " <> tshow (length gs') else ""
sendReply $ tshow (length gs) <> " group(s) listed" <> more <> "."
updateSearchRequest searchType $ groupIds gs'
sendFoundGroups gs' moreGroups
sendNextSearchResults takeFirst SearchRequest {searchType, sentGroups} = \case
@@ -516,7 +519,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
let gs' = takeFirst searchResults $ filterNotSent sentGroups gs
sentGroups' = sentGroups <> groupIds gs'
moreGroups = length gs - S.size sentGroups'
sendReply $ "Sending " <> show (length gs') <> " more group(s)."
sendReply $ "Sending " <> tshow (length gs') <> " more group(s)."
updateSearchRequest searchType sentGroups'
sendFoundGroups gs' moreGroups
updateSearchRequest :: SearchType -> Set GroupId -> IO ()
@@ -527,9 +530,10 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
sendFoundGroups gs moreGroups =
void . forkIO $ do
forM_ gs $
\(GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do
\(GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do
let membersStr = "_" <> tshow currentMembers <> " members_"
text = groupInfoText p <> "\n" <> membersStr
showId = if isAdmin then tshow groupId <> ". " else ""
text = showId <> groupInfoText p <> "\n" <> membersStr
msg = maybe (MCText text) (\image -> MCImage {text, image}) image_
sendComposedMessage cc ct Nothing msg
when (moreGroups > 0) $
@@ -537,92 +541,134 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
MCText $
"Send */next* or just *.* for " <> tshow moreGroups <> " more result(s)."
deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO ()
deSuperUserCommand ct ciId cmd
| superUser `elem` superUsers = case cmd of
deAdminCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRAdmin -> IO ()
deAdminCommand ct ciId cmd
| knownCt `elem` adminUsers || knownCt `elem` superUsers = case cmd of
DCApproveGroup {groupId, displayName = n, groupApprovalId} ->
getGroupAndReg groupId n >>= \case
Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)."
Just (g, gr) ->
readTVarIO (groupRegStatus gr) >>= \case
GRSPendingApproval gaId
| gaId == groupApprovalId -> do
getDuplicateGroup g >>= \case
Nothing -> sendReply "Error: getDuplicateGroup. Please notify the developers."
Just DGReserved -> sendReply $ "The group " <> groupRef <> " is already listed in the directory."
_ -> do
getGroupRolesStatus g gr >>= \case
Just GRSOk -> do
setGroupStatus st gr GRSActive
sendReply "Group approved!"
notifyOwner gr $ "The group " <> userGroupReference' gr n <> " is approved and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved."
Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin
Just GRSContactNotOwner -> replyNotApproved "user is not an owner."
Just GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin
Nothing -> sendReply "Error: getGroupRolesStatus. Please notify the developers."
where
replyNotApproved reason = sendReply $ "Group is not approved: " <> reason
serviceNotAdmin = serviceName <> " is not an admin."
| otherwise -> sendReply "Incorrect approval code"
_ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval."
withGroupAndReg sendReply groupId n $ \g gr ->
readTVarIO (groupRegStatus gr) >>= \case
GRSPendingApproval gaId
| gaId == groupApprovalId -> do
getDuplicateGroup g >>= \case
Nothing -> sendReply "Error: getDuplicateGroup. Please notify the developers."
Just DGReserved -> sendReply $ "The group " <> groupRef <> " is already listed in the directory."
_ -> do
getGroupRolesStatus g gr >>= \case
Just GRSOk -> do
setGroupStatus st gr GRSActive
let approved = "The group " <> userGroupReference' gr n <> " is approved"
notifyOwner gr $ approved <> " and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved."
sendReply "Group approved!"
notifyOtherSuperUsers $ approved <> " by " <> viewName (localDisplayName' ct)
Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin
Just GRSContactNotOwner -> replyNotApproved "user is not an owner."
Just GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin
Nothing -> sendReply "Error: getGroupRolesStatus. Please notify the developers."
where
replyNotApproved reason = sendReply $ "Group is not approved: " <> reason
serviceNotAdmin = serviceName <> " is not an admin."
| otherwise -> sendReply "Incorrect approval code"
_ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval."
where
groupRef = groupReference' groupId n
DCRejectGroup _gaId _gName -> pure ()
DCSuspendGroup groupId gName -> do
let groupRef = groupReference' groupId gName
getGroupAndReg groupId gName >>= \case
Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)."
Just (_, gr) ->
readTVarIO (groupRegStatus gr) >>= \case
GRSActive -> do
setGroupStatus st gr GRSSuspended
notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is suspended and hidden from directory. Please contact the administrators."
sendReply "Group suspended!"
_ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended."
withGroupAndReg sendReply groupId gName $ \_ gr ->
readTVarIO (groupRegStatus gr) >>= \case
GRSActive -> do
setGroupStatus st gr GRSSuspended
let suspended = "The group " <> userGroupReference' gr gName <> " is suspended"
notifyOwner gr $ suspended <> " and hidden from directory. Please contact the administrators."
sendReply "Group suspended!"
notifyOtherSuperUsers $ suspended <> " by " <> viewName (localDisplayName' ct)
_ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended."
DCResumeGroup groupId gName -> do
let groupRef = groupReference' groupId gName
getGroupAndReg groupId gName >>= \case
Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)."
Just (_, gr) ->
readTVarIO (groupRegStatus gr) >>= \case
GRSSuspended -> do
setGroupStatus st gr GRSActive
notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is listed in the directory again!"
sendReply "Group listing resumed!"
_ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed."
withGroupAndReg sendReply groupId gName $ \_ gr ->
readTVarIO (groupRegStatus gr) >>= \case
GRSSuspended -> do
setGroupStatus st gr GRSActive
let groupStr = "The group " <> userGroupReference' gr gName
notifyOwner gr $ groupStr <> " is listed in the directory again!"
sendReply "Group listing resumed!"
notifyOtherSuperUsers $ groupStr <> " listing resumed by " <> viewName (localDisplayName' ct)
_ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed."
DCListLastGroups count -> listGroups count False
DCListPendingGroups count -> listGroups count True
DCExecuteCommand cmdStr ->
sendChatCmdStr cc cmdStr >>= \r -> do
ts <- getCurrentTime
tz <- getCurrentTimeZone
sendReply $ serializeChatResponse (Nothing, Just user) ts tz Nothing r
DCCommandError tag -> sendReply $ "Command error: " <> show tag
DCShowGroupLink groupId gName -> do
let groupRef = groupReference' groupId gName
withGroupAndReg sendReply groupId gName $ \_ _ ->
sendChatCmd cc (APIGetGroupLink groupId) >>= \case
CRGroupLink {connReqContact, memberRole} ->
sendReply $ T.unlines
[ "The link to join the group " <> groupRef <> ":",
strEncodeTxt $ simplexChatContact connReqContact,
"New member role: " <> strEncodeTxt memberRole
]
CRChatCmdError _ (ChatErrorStore (SEGroupLinkNotFound _)) ->
sendReply $ "The group " <> groupRef <> " has no public link."
r -> do
ts <- getCurrentTime
tz <- getCurrentTimeZone
let resp = T.pack $ serializeChatResponse (Nothing, Just user) ts tz Nothing r
sendReply $ "Unexpected error:\n" <> resp
DCSendToGroupOwner groupId gName msg -> do
let groupRef = groupReference' groupId gName
withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {dbContactId} -> do
notifyOwner gr msg
owner_ <- getContact cc dbContactId
let ownerInfo = "the owner of the group " <> groupRef
ownerName ct' = "@" <> viewName (localDisplayName' ct') <> ", "
sendReply $ "Forwarded to " <> maybe "" ownerName owner_ <> ownerInfo
DCCommandError tag -> sendReply $ "Command error: " <> tshow tag
| otherwise = sendReply "You are not allowed to use this command"
where
superUser = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent
knownCt = knownContact ct
sendReply = mkSendReply ct ciId
notifyOtherSuperUsers s = withSuperUsers $ \ctId -> unless (ctId == contactId' ct) $ sendMessage' cc ctId s
listGroups count pending =
readTVarIO (groupRegs st) >>= \groups -> do
grs <-
if pending
if pending
then filterM (fmap pendingApproval . readTVarIO . groupRegStatus) groups
else pure groups
sendReply $ show (length grs) <> " registered group(s)" <> (if length grs > count then ", showing the last " <> show count else "")
sendReply $ tshow (length grs) <> " registered group(s)" <> (if length grs > count then ", showing the last " <> tshow count else "")
void . forkIO $ forM_ (reverse $ take count grs) $ \gr@GroupReg {dbGroupId, dbContactId} -> do
ct_ <- getContact cc dbContactId
let ownerStr = "Owner: " <> maybe "getContact error" localDisplayName' ct_
sendGroupInfo ct gr dbGroupId $ Just ownerStr
getGroupAndReg :: GroupId -> GroupName -> IO (Maybe (GroupInfo, GroupReg))
getGroupAndReg gId gName =
getGroup cc gId
$>>= \g@GroupInfo {groupProfile = GroupProfile {displayName}} ->
if displayName == gName
then
atomically (getGroupReg st gId)
$>>= \gr -> pure $ Just (g, gr)
else pure Nothing
deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO ()
deSuperUserCommand ct ciId cmd
| knownContact ct `elem` superUsers = case cmd of
DCExecuteCommand cmdStr ->
sendChatCmdStr cc cmdStr >>= \r -> do
ts <- getCurrentTime
tz <- getCurrentTimeZone
sendReply $ T.pack $ serializeChatResponse (Nothing, Just user) ts tz Nothing r
DCCommandError tag -> sendReply $ "Command error: " <> tshow tag
| otherwise = sendReply "You are not allowed to use this command"
where
sendReply = mkSendReply ct ciId
knownContact :: Contact -> KnownContact
knownContact ct = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
mkSendReply :: Contact -> ChatItemId -> Text -> IO ()
mkSendReply ct ciId = sendComposedMessage cc ct (Just ciId) . MCText
withGroupAndReg :: (Text -> IO ()) -> GroupId -> GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO ()
withGroupAndReg sendReply gId gName action =
getGroup cc gId >>= \case
Nothing -> sendReply $ "Group ID " <> tshow gId <> " not found (getGroup)"
Just g@GroupInfo {groupProfile = GroupProfile {displayName}}
| displayName == gName ->
atomically (getGroupReg st gId) >>= \case
Nothing -> sendReply $ "Registration for group ID " <> tshow gId <> " not found (getGroupReg)"
Just gr -> action g gr
| otherwise ->
sendReply $ "Group ID " <> tshow gId <> " has the display name " <> displayName
sendGroupInfo :: Contact -> GroupReg -> GroupId -> Maybe Text -> IO ()
sendGroupInfo ct gr@GroupReg {dbGroupId} useGroupId ownerStr_ = do
@@ -643,7 +689,7 @@ getContact cc ctId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTDirect ctId)
where
resp :: ChatResponse -> Maybe Contact
resp = \case
CRApiChat _ (AChat SCTDirect Chat {chatInfo = DirectChat ct}) -> Just ct
CRApiChat _ (AChat SCTDirect Chat {chatInfo = DirectChat ct}) _ -> Just ct
_ -> Nothing
getGroup :: ChatController -> GroupId -> IO (Maybe GroupInfo)
@@ -668,5 +714,8 @@ setGroupLinkRole cc gId mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole
CRGroupLink _ _ gLink _ -> Just gLink
_ -> Nothing
unexpectedError :: String -> String
unexpectedError :: Text -> Text
unexpectedError err = "Unexpected error: " <> err <> ", please notify the developers."
strEncodeTxt :: StrEncoding a => a -> Text
strEncodeTxt = safeDecodeUtf8 . strEncode
+1 -1
View File
@@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: 8a9d4f2af768d5d6a2b60c00d507529242f9b984
tag: 93f30c8edf9243ad2291dd6427d87328e282560a
source-repository-package
type: git
+15 -17
View File
@@ -8,25 +8,23 @@ layout: layouts/jobs.html
SimpleX Chat Ltd is a seed stage startup with a lot of user growth in 2022-2023, and a lot of exciting technical and product problems to solve to grow faster.
We currently have 4 full-time people in the team - all engineers, including the founder.
We want to add up to 3 people to the team.
We currently have 6 full-time people in the team.
We want to add 2 people to the team.
## Who we are looking for
### Product/UI designer
### Web designer & developer for a website contract
You will be designing the user experience and the interface of both the app and the website in collaboration with the team.
You will work with the founder and a product marketing expert to convert the stories we want to tell our current and prospective users into interactive experiences.
The current focus of the app is privacy and security, but we hope to have the design that would support the feeling of psychological safety, enabling people to achieve the results in the smallest amount of time.
You are an expert in creating interactive web experiences:
- 15+ years of web development and design experience.
- Passionate about communications, privacy and data ownership.
- Competent using PhotoShop, 3D modelling, etc.
- Competent in Web tech, including JavaScript, animations, etc.
You are an experienced and innovative product designer with:
- 8+ years of user experience and visual design.
- Expertise in typography and high sensitivity to colors.
- Exceptional precision and attention to details.
- Strong opinions (weakly held).
- A strong empathy.
We will NOT consider agencies or groups it must be one person working on the project.
### Application Haskell engineer
@@ -34,13 +32,12 @@ You will work with the Haskell core of the client applications and with the netw
You are an expert in language models, databases and Haskell:
- expert knowledge of SQL.
- Haskell exception handling, concurrency, STM, type systems.
- 8y+ of software engineering experience in complex projects,
- Haskell strictness, exceptions, [concurrency](https://simonmar.github.io/pages/pcph.html), STM, [type systems](https://thinkingwithtypes.com).
- 15y+ of software engineering experience in complex projects.
- deep understanding of the common programming principles:
- data structures, bits and bytes, text encoding.
- software design and algorithms.
- concurrency.
- networking.
- [functional software design](https://mitp-content-server.mit.edu/books/content/sectbyfn/books_pres_0/6515/sicp.zip/index.html) and algorithms.
- protocols and networking.
## About you
@@ -48,6 +45,7 @@ You are an expert in language models, databases and Haskell:
- already use SimpleX Chat to communicate with friends/family or participate in public SimpleX Chat groups.
- passionate about privacy, security and communications.
- interested to make contributions to SimpleX Chat open-source project in your free time before we hire you, as an extended test.
- you founded (and probably failed) at least one startup, or spent more time working for yourself than being employed.
- **Exceptionally pragmatic, very fast and customer-focussed**:
- care about the customers (aka users) and about the product we build much more than about the code quality, technology stack, etc.
+78 -3
View File
@@ -28,7 +28,8 @@ revision: 12.10.2024
- [Documentation](#documentation)
- [SMP server address](#smp-server-address)
- [Systemd commands](#systemd-commands)
- [Monitoring](#monitoring)
- [Control port](#control-port)
- [Daily statistics](#daily-statistics)
- [Updating your SMP server](#updating-your-smp-server)
- [Configuring the app to use the server](#configuring-the-app-to-use-the-server)
@@ -1079,7 +1080,81 @@ Nov 23 19:23:21 5588ab759e80 smp-server[30878]: not expiring inactive clients
Nov 23 19:23:21 5588ab759e80 smp-server[30878]: creating new queues requires password
```
#### Monitoring
#### Control port
Enabling control port in the configuration allows administrator to see information about the smp-server in real-time. Additionally, it allows to delete queues for content moderation and see the debug info about the clients, sockets, etc. Enabling the control port requires setting the `admin` and `user` passwords.
1. Generate two passwords for each user:
```sh
tr -dc A-Za-z0-9 </dev/urandom | head -c 20; echo
```
2. Open the configuration file:
```sh
vim /etc/opt/simplex/smp-server.ini
```
2. Configure the control port and replace the passwords:
```ini
[AUTH]
control_port_admin_password: <your_randomly_generated_admin_password>
control_port_user_password: <your_randomly_generated_user_password>
[TRANSPORT]
control_port: 5224
```
3. Restart the server:
```sh
systemctl restart smp-server
```
To access the control port, use:
```sh
nc 127.0.0.1 5224
```
or:
```sh
telnet 127.0.0.1 5224
```
Upon connecting, the control port should print:
```sh
SMP server control port
'help' for supported commands
```
To authenticate, type the following and hit enter. Change the `my_generated_password` with the `user` or `admin` password from the configuration:
```sh
auth my_generated_password
```
Here's the full list of commands, their descriptions and who can access them.
| Command | Description | Requires `admin` role |
| ---------------- | ------------------------------------------------------------------------------- | -------------------------- |
| `stats` | Real-time statistics. Fields described in [Daily statistics](#daily-statistics) | - |
| `stats-rts` | GHC/Haskell statistics. Can be enabled with `+RTS -T -RTS` option | - |
| `clients` | Clients information. Useful for debugging. | yes |
| `sockets` | General sockets information. | - |
| `socket-threads` | Thread infomation per socket. Useful for debugging. | yes |
| `threads` | Threads information. Useful for debugging. | yes |
| `server-info` | Aggregated server infomation. | - |
| `delete` | Delete known queue. Useful for content moderation. | - |
| `save` | Save queues/messages from memory. | yes |
| `help` | Help menu. | - |
| `quit` | Exit the control port. | - |
#### Daily statistics
You can enable `smp-server` statistics for `Grafana` dashboard by setting value `on` in `/etc/opt/simplex/smp-server.ini`, under `[STORE_LOG]` section in `log_stats:` field.
@@ -1089,7 +1164,7 @@ Logs will be stored as `csv` file in `/var/opt/simplex/smp-server-stats.daily.lo
fromTime,qCreated,qSecured,qDeleted,msgSent,msgRecv,dayMsgQueues,weekMsgQueues,monthMsgQueues,msgSentNtf,msgRecvNtf,dayCountNtf,weekCountNtf,monthCountNtf,qCount,msgCount,msgExpired,qDeletedNew,qDeletedSecured,pRelays_pRequests,pRelays_pSuccesses,pRelays_pErrorsConnect,pRelays_pErrorsCompat,pRelays_pErrorsOther,pRelaysOwn_pRequests,pRelaysOwn_pSuccesses,pRelaysOwn_pErrorsConnect,pRelaysOwn_pErrorsCompat,pRelaysOwn_pErrorsOther,pMsgFwds_pRequests,pMsgFwds_pSuccesses,pMsgFwds_pErrorsConnect,pMsgFwds_pErrorsCompat,pMsgFwds_pErrorsOther,pMsgFwdsOwn_pRequests,pMsgFwdsOwn_pSuccesses,pMsgFwdsOwn_pErrorsConnect,pMsgFwdsOwn_pErrorsCompat,pMsgFwdsOwn_pErrorsOther,pMsgFwdsRecv,qSub,qSubAuth,qSubDuplicate,qSubProhibited,msgSentAuth,msgSentQuota,msgSentLarge,msgNtfs,msgNtfNoSub,msgNtfLost,qSubNoMsg,msgRecvGet,msgGet,msgGetNoMsg,msgGetAuth,msgGetDuplicate,msgGetProhibited,psSubDaily,psSubWeekly,psSubMonthly,qCount2,ntfCreated,ntfDeleted,ntfSub,ntfSubAuth,ntfSubDuplicate,ntfCount,qDeletedAllB,qSubAllB,qSubEnd,qSubEndB,ntfDeletedB,ntfSubB,msgNtfsB,msgNtfExpired
```
#### Fields description
**Fields description**
| Field number | Field name | Field Description |
| ------------- | ---------------------------- | -------------------------- |
+68 -1
View File
@@ -361,7 +361,74 @@ Feb 27 19:21:11 localhost xftp-server[2350]: Listening on port 443...
Feb 27 19:21:11 localhost xftp-server[2350]: [INFO 2023-02-27 19:21:11 +0000 src/Simplex/FileTransfer/Server/Env.hs:85] Total / available storage: 64424509440 / 64424509440
````
### Monitoring
### Control port
Enabling control port in the configuration allows administrator to see information about the smp-server in real-time. Additionally, it allows to delete file chunks for content moderation and see the debug info about the clients, sockets, etc. Enabling the control port requires setting the `admin` and `user` passwords.
1. Generate two passwords for each user:
```sh
tr -dc A-Za-z0-9 </dev/urandom | head -c 20; echo
```
2. Open the configuration file:
```sh
vim /etc/opt/simplex-xftp/file-server.ini
```
2. Configure the control port and replace the passwords:
```ini
[AUTH]
control_port_admin_password: <your_randomly_generated_admin_password>
control_port_user_password: <your_randomly_generated_user_password>
[TRANSPORT]
control_port: 5224
```
3. Restart the server:
```sh
systemctl restart xftp-server
```
To access the control port, use:
```sh
nc 127.0.0.1 5224
```
or:
```sh
telnet 127.0.0.1 5224
```
Upon connecting, the control port should print:
```sh
XFTP server control port
'help' for supported commands
```
To authenticate, type the following and hit enter. Change the `my_generated_password` with the `user` or `admin` password from the configuration:
```sh
auth my_generated_password
```
Here's the full list of commands, their descriptions and who can access them.
| Command | Description | Requires `admin` role |
| ---------------- | ------------------------------------------------------------------------------- | -------------------------- |
| `stats-rts` | GHC/Haskell statistics. Can be enabled with `+RTS -T -RTS` option | - |
| `delete` | Delete known file chunk. Useful for content moderation. | - |
| `help` | Help menu. | - |
| `quit` | Exit the control port. | - |
### Daily statistics
You can enable `xftp-server` statistics for `Grafana` dashboard by setting value `on` in `/etc/opt/simplex-xftp/file-server.ini`, under `[STORE_LOG]` section in `log_stats:` field.
+24
View File
@@ -0,0 +1,24 @@
# Server operators
## Problem
All preconfigured servers operated by a single company create a risk that user connections can be analysed by aggregating transport information from these servers.
The solution is to have more than one operator servers pre-configured in the app.
For operators to be protected from any violations of rights of other users or third parties by the users who use servers of these operators, the users have to explicitely accept conditions of use with the operator, in the same way they accept conditions of use with SimpleX Chat Ltd by downloading the app.
## Solution
Allow to assign operators to servers, both with preconfigured operators and servers, and with user-defined operators. Agent added support for server roles, chat app could:
- allow assigning server roles only on the operator level.
- only on server level.
- on both, with server roles overriding operator roles (that would require a different type for server for chat app).
For simplicity of both UX and logic it is probably better to allow assigning roles only on operators' level, and servers without set operators can be used for both roles.
For agreements, it is sufficient to record the signatures of these agreements on users' devices, together with the copy of signed agreement (or its hash and version) in a separate table. The terms themselves could be:
- included in the app - either in code or in migration.
- referenced with a stable link to a particular commit.
The first solution seems better, as it avoids any third party dependency, and the agreement size is relatively small (~31kb), to reduce size we can store it compressed.
+3 -1
View File
@@ -29,6 +29,7 @@ dependencies:
- email-validate == 2.3.*
- exceptions == 0.10.*
- filepath == 1.4.*
- file-embed == 0.0.15.*
- http-types == 0.12.*
- http2 >= 4.2.2 && < 4.3
- memory == 0.18.*
@@ -38,6 +39,7 @@ dependencies:
- optparse-applicative >= 0.15 && < 0.17
- random >= 1.1 && < 1.3
- record-hasfield == 1.0.*
- scientific ==0.3.7.*
- simple-logger == 0.1.*
- simplexmq >= 5.0
- socks == 0.6.*
@@ -72,7 +74,7 @@ when:
- bytestring == 0.10.*
- process >= 1.6 && < 1.6.18
- template-haskell == 2.16.*
- text >= 1.2.3.0 && < 1.3
- text >= 1.2.4.0 && < 1.3
library:
source-dirs: src
+1 -1
View File
@@ -1,5 +1,5 @@
{
"https://github.com/simplex-chat/simplexmq.git"."8a9d4f2af768d5d6a2b60c00d507529242f9b984" = "0kb8hq37fc5g198wq7dswnlwjzk67q8rrzil2dii5lc6xfr47jbs";
"https://github.com/simplex-chat/simplexmq.git"."93f30c8edf9243ad2291dd6427d87328e282560a" = "1zf0sp9dy6kz4zvyz6mdgmhydps7khcq84n30irp983w1xh7gzs7";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
+25 -7
View File
@@ -150,10 +150,14 @@ library
Simplex.Chat.Migrations.M20240920_user_order
Simplex.Chat.Migrations.M20241008_indexes
Simplex.Chat.Migrations.M20241010_contact_requests_contact_id
Simplex.Chat.Migrations.M20241023_chat_item_autoincrement_id
Simplex.Chat.Migrations.M20241027_server_operators
Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared
Simplex.Chat.Mobile.WebRTC
Simplex.Chat.Operators
Simplex.Chat.Operators.Conditions
Simplex.Chat.Options
Simplex.Chat.ProfileGenerator
Simplex.Chat.Protocol
@@ -213,6 +217,7 @@ library
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -223,6 +228,7 @@ library
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplexmq >=5.0
, socks ==0.6.*
@@ -249,7 +255,7 @@ library
bytestring ==0.10.*
, process >=1.6 && <1.6.18
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3
, text >=1.2.4.0 && <1.3
executable simplex-bot
main-is: Main.hs
@@ -276,6 +282,7 @@ executable simplex-bot
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -286,6 +293,7 @@ executable simplex-bot
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
@@ -313,7 +321,7 @@ executable simplex-bot
bytestring ==0.10.*
, process >=1.6 && <1.6.18
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3
, text >=1.2.4.0 && <1.3
executable simplex-bot-advanced
main-is: Main.hs
@@ -340,6 +348,7 @@ executable simplex-bot-advanced
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -350,6 +359,7 @@ executable simplex-bot-advanced
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
@@ -377,7 +387,7 @@ executable simplex-bot-advanced
bytestring ==0.10.*
, process >=1.6 && <1.6.18
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3
, text >=1.2.4.0 && <1.3
executable simplex-broadcast-bot
main-is: Main.hs
@@ -407,6 +417,7 @@ executable simplex-broadcast-bot
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -417,6 +428,7 @@ executable simplex-broadcast-bot
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
@@ -444,7 +456,7 @@ executable simplex-broadcast-bot
bytestring ==0.10.*
, process >=1.6 && <1.6.18
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3
, text >=1.2.4.0 && <1.3
executable simplex-chat
main-is: Main.hs
@@ -472,6 +484,7 @@ executable simplex-chat
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -482,6 +495,7 @@ executable simplex-chat
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
@@ -510,7 +524,7 @@ executable simplex-chat
bytestring ==0.10.*
, process >=1.6 && <1.6.18
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3
, text >=1.2.4.0 && <1.3
executable simplex-directory-service
main-is: Main.hs
@@ -543,6 +557,7 @@ executable simplex-directory-service
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -553,6 +568,7 @@ executable simplex-directory-service
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
@@ -580,7 +596,7 @@ executable simplex-directory-service
bytestring ==0.10.*
, process >=1.6 && <1.6.18
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3
, text >=1.2.4.0 && <1.3
test-suite simplex-chat-test
type: exitcode-stdio-1.0
@@ -642,6 +658,7 @@ test-suite simplex-chat-test
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, generic-random ==1.5.*
, http-types ==0.12.*
@@ -653,6 +670,7 @@ test-suite simplex-chat-test
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, silently ==1.2.*
, simple-logger ==0.1.*
, simplex-chat
@@ -681,7 +699,7 @@ test-suite simplex-chat-test
bytestring ==0.10.*
, process >=1.6 && <1.6.18
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3
, text >=1.2.4.0 && <1.3
if impl(ghc >= 9.6.2)
build-depends:
hspec ==2.11.*
+306 -147
View File
@@ -6,6 +6,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
@@ -43,7 +44,7 @@ import Data.Functor (($>))
import Data.Functor.Identity
import Data.Int (Int64)
import Data.List (find, foldl', isSuffixOf, mapAccumL, partition, sortOn, zipWith4)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, (<|))
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
@@ -54,6 +55,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay, nominalDiffTimeToSeconds)
import Data.Type.Equality
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as V4
import Data.Word (Word32)
@@ -67,6 +69,7 @@ import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (MsgBatch (..), batchMessages)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.Operators
import Simplex.Chat.Options
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
import Simplex.Chat.Protocol
@@ -97,7 +100,7 @@ import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId)
import Simplex.Messaging.Agent as Agent
import Simplex.Messaging.Agent.Client (SubInfo (..), agentClientStore, getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary, getFastNetworkConfig, ipAddressProtected, withLockMap)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), ServerCfg (..), createAgentStore, defaultAgentConfig, enabledServerCfg, presetServerCfg)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), ServerCfg (..), ServerRoles (..), allRoles, createAgentStore, defaultAgentConfig)
import Simplex.Messaging.Agent.Lock (withLock)
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
@@ -137,6 +140,32 @@ import qualified UnliftIO.Exception as E
import UnliftIO.IO (hClose, hSeek, hTell, openFile)
import UnliftIO.STM
operatorSimpleXChat :: NewServerOperator
operatorSimpleXChat =
ServerOperator
{ operatorId = DBNewEntity,
operatorTag = Just OTSimplex,
tradeName = "SimpleX Chat",
legalName = Just "SimpleX Chat Ltd",
serverDomains = ["simplex.im"],
conditionsAcceptance = CARequired Nothing,
enabled = True,
roles = allRoles
}
operatorFlux :: NewServerOperator
operatorFlux =
ServerOperator
{ operatorId = DBNewEntity,
operatorTag = Just OTFlux,
tradeName = "Flux",
legalName = Just "InFlux Technologies Limited",
serverDomains = ["simplexonflux.com"],
conditionsAcceptance = CARequired Nothing,
enabled = False,
roles = ServerRoles {storage = False, proxy = True}
}
defaultChatConfig :: ChatConfig
defaultChatConfig =
ChatConfig
@@ -147,13 +176,25 @@ defaultChatConfig =
},
chatVRange = supportedChatVRange,
confirmMigrations = MCConsole,
defaultServers =
DefaultAgentServers
{ smp = _defaultSMPServers,
useSMP = 4,
presetServers =
PresetServers
{ operators =
[ PresetOperator
{ operator = Just operatorSimpleXChat,
smp = simplexChatSMPServers,
useSMP = 4,
xftp = map (presetServer True) $ L.toList defaultXFTPServers,
useXFTP = 3
},
PresetOperator
{ operator = Just operatorFlux,
smp = fluxSMPServers,
useSMP = 3,
xftp = fluxXFTPServers,
useXFTP = 3
}
],
ntf = _defaultNtfServers,
xftp = L.map (presetServerCfg True) defaultXFTPServers,
useXFTP = L.length defaultXFTPServers,
netCfg = defaultNetworkConfig
},
tbqSize = 1024,
@@ -177,29 +218,52 @@ defaultChatConfig =
chatHooks = defaultChatHooks
}
_defaultSMPServers :: NonEmpty (ServerCfg 'PSMP)
_defaultSMPServers =
L.fromList $
map
(presetServerCfg True)
[ "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion",
"smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion",
"smp://6iIcWT_dF2zN_w5xzZEY7HI2Prbh3ldP07YTyDexPjE=@smp10.simplex.im,rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion",
"smp://1OwYGt-yqOfe2IyVHhxz3ohqo3aCCMjtB-8wn4X_aoY=@smp11.simplex.im,6ioorbm6i3yxmuoezrhjk6f6qgkc4syabh7m3so74xunb5nzr4pwgfqd.onion",
"smp://UkMFNAXLXeAAe0beCa4w6X_zp18PwxSaSjY17BKUGXQ=@smp12.simplex.im,ie42b5weq7zdkghocs3mgxdjeuycheeqqmksntj57rmejagmg4eor5yd.onion",
"smp://enEkec4hlR3UtKx2NMpOUK_K4ZuDxjWBO1d9Y4YXVaA=@smp14.simplex.im,aspkyu2sopsnizbyfabtsicikr2s4r3ti35jogbcekhm3fsoeyjvgrid.onion",
"smp://h--vW7ZSkXPeOUpfxlFGgauQmXNFOzGoizak7Ult7cw=@smp15.simplex.im,oauu4bgijybyhczbnxtlggo6hiubahmeutaqineuyy23aojpih3dajad.onion",
"smp://hejn2gVIqNU6xjtGM3OwQeuk8ZEbDXVJXAlnSBJBWUA=@smp16.simplex.im,p3ktngodzi6qrf7w64mmde3syuzrv57y55hxabqcq3l5p6oi7yzze6qd.onion",
"smp://ZKe4uxF4Z_aLJJOEsC-Y6hSkXgQS5-oc442JQGkyP8M=@smp17.simplex.im,ogtwfxyi3h2h5weftjjpjmxclhb5ugufa5rcyrmg7j4xlch7qsr5nuqd.onion",
"smp://PtsqghzQKU83kYTlQ1VKg996dW4Cw4x_bvpKmiv8uns=@smp18.simplex.im,lyqpnwbs2zqfr45jqkncwpywpbtq7jrhxnib5qddtr6npjyezuwd3nqd.onion",
"smp://N_McQS3F9TGoh4ER0QstUf55kGnNSd-wXfNPZ7HukcM=@smp19.simplex.im,i53bbtoqhlc365k6kxzwdp5w3cdt433s7bwh3y32rcbml2vztiyyz5id.onion"
simplexChatSMPServers :: [NewUserServer 'PSMP]
simplexChatSMPServers =
map
(presetServer True)
[ "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion",
"smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion",
"smp://6iIcWT_dF2zN_w5xzZEY7HI2Prbh3ldP07YTyDexPjE=@smp10.simplex.im,rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion",
"smp://1OwYGt-yqOfe2IyVHhxz3ohqo3aCCMjtB-8wn4X_aoY=@smp11.simplex.im,6ioorbm6i3yxmuoezrhjk6f6qgkc4syabh7m3so74xunb5nzr4pwgfqd.onion",
"smp://UkMFNAXLXeAAe0beCa4w6X_zp18PwxSaSjY17BKUGXQ=@smp12.simplex.im,ie42b5weq7zdkghocs3mgxdjeuycheeqqmksntj57rmejagmg4eor5yd.onion",
"smp://enEkec4hlR3UtKx2NMpOUK_K4ZuDxjWBO1d9Y4YXVaA=@smp14.simplex.im,aspkyu2sopsnizbyfabtsicikr2s4r3ti35jogbcekhm3fsoeyjvgrid.onion",
"smp://h--vW7ZSkXPeOUpfxlFGgauQmXNFOzGoizak7Ult7cw=@smp15.simplex.im,oauu4bgijybyhczbnxtlggo6hiubahmeutaqineuyy23aojpih3dajad.onion",
"smp://hejn2gVIqNU6xjtGM3OwQeuk8ZEbDXVJXAlnSBJBWUA=@smp16.simplex.im,p3ktngodzi6qrf7w64mmde3syuzrv57y55hxabqcq3l5p6oi7yzze6qd.onion",
"smp://ZKe4uxF4Z_aLJJOEsC-Y6hSkXgQS5-oc442JQGkyP8M=@smp17.simplex.im,ogtwfxyi3h2h5weftjjpjmxclhb5ugufa5rcyrmg7j4xlch7qsr5nuqd.onion",
"smp://PtsqghzQKU83kYTlQ1VKg996dW4Cw4x_bvpKmiv8uns=@smp18.simplex.im,lyqpnwbs2zqfr45jqkncwpywpbtq7jrhxnib5qddtr6npjyezuwd3nqd.onion",
"smp://N_McQS3F9TGoh4ER0QstUf55kGnNSd-wXfNPZ7HukcM=@smp19.simplex.im,i53bbtoqhlc365k6kxzwdp5w3cdt433s7bwh3y32rcbml2vztiyyz5id.onion"
]
<> map
(presetServer False)
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
]
<> map
(presetServerCfg False)
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
]
fluxSMPServers :: [NewUserServer 'PSMP]
fluxSMPServers =
map
(presetServer True)
[ "smp://xQW_ufMkGE20UrTlBl8QqceG1tbuylXhr9VOLPyRJmw=@smp1.simplexonflux.com,qb4yoanyl4p7o33yrknv4rs6qo7ugeb2tu2zo66sbebezs4cpyosarid.onion",
"smp://LDnWZVlAUInmjmdpQQoIo6FUinRXGe0q3zi5okXDE4s=@smp2.simplexonflux.com,yiqtuh3q4x7hgovkomafsod52wvfjucdljqbbipg5sdssnklgongxbqd.onion",
"smp://1jne379u7IDJSxAvXbWb_JgoE7iabcslX0LBF22Rej0=@smp3.simplexonflux.com,a5lm4k7ufei66cdck6fy63r4lmkqy3dekmmb7jkfdm5ivi6kfaojshad.onion",
"smp://xmAmqj75I9mWrUihLUlI0ZuNLXlIwFIlHRq5Pb6cHAU=@smp4.simplexonflux.com,qpcz2axyy66u26hfdd2e23uohcf3y6c36mn7dcuilcgnwjasnrvnxjqd.onion",
"smp://rWvBYyTamuRCBYb_KAn-nsejg879ndhiTg5Sq3k0xWA=@smp5.simplexonflux.com,4ao347qwiuluyd45xunmii4skjigzuuox53hpdsgbwxqafd4yrticead.onion",
"smp://PN7-uqLBToqlf1NxHEaiL35lV2vBpXq8Nj8BW11bU48=@smp6.simplexonflux.com,hury6ot3ymebbr2535mlp7gcxzrjpc6oujhtfxcfh2m4fal4xw5fq6qd.onion"
]
fluxXFTPServers :: [NewUserServer 'PXFTP]
fluxXFTPServers =
map
(presetServer True)
[ "xftp://92Sctlc09vHl_nAqF2min88zKyjdYJ9mgxRCJns5K2U=@xftp1.simplexonflux.com,apl3pumq3emwqtrztykyyoomdx4dg6ysql5zek2bi3rgznz7ai3odkid.onion",
"xftp://YBXy4f5zU1CEhnbbCzVWTNVNsaETcAGmYqGNxHntiE8=@xftp2.simplexonflux.com,c5jjecisncnngysah3cz2mppediutfelco4asx65mi75d44njvua3xid.onion",
"xftp://ARQO74ZSvv2OrulRF3CdgwPz_AMy27r0phtLSq5b664=@xftp3.simplexonflux.com,dc4mohiubvbnsdfqqn7xhlhpqs5u4tjzp7xpz6v6corwvzvqjtaqqiqd.onion",
"xftp://ub2jmAa9U0uQCy90O-fSUNaYCj6sdhl49Jh3VpNXP58=@xftp4.simplexonflux.com,4qq5pzier3i4yhpuhcrhfbl6j25udc4czoyascrj4yswhodhfwev3nyd.onion",
"xftp://Rh19D5e4Eez37DEE9hAlXDB3gZa1BdFYJTPgJWPO9OI=@xftp5.simplexonflux.com,q7itltdn32hjmgcqwhow4tay5ijetng3ur32bolssw32fvc5jrwvozad.onion",
"xftp://0AznwoyfX8Od9T_acp1QeeKtxUi676IBIiQjXVwbdyU=@xftp6.simplexonflux.com,upvzf23ou6nrmaf3qgnhd6cn3d74tvivlmz3p7wdfwq6fhthjrjiiqid.onion "
]
_defaultNtfServers :: [NtfServer]
_defaultNtfServers =
@@ -236,16 +300,19 @@ newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Boo
newChatController
ChatDatabase {chatStore, agentStore}
user
cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, deviceNameForRemote, confirmMigrations}
cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations}
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable, yesToUpMigrations}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
backgroundMode = do
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
confirmMigrations' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
firstTime = dbNew chatStore
currentUser <- newTVarIO user
randomSMP <- randomPresetServers SPSMP presetServers'
randomXFTP <- randomPresetServers SPXFTP presetServers'
let randomServers = RandomServers {smpServers = randomSMP, xftpServers = randomXFTP}
currentRemoteHost <- newTVarIO Nothing
servers <- agentServers config
servers <- withTransaction chatStore $ \db -> agentServers db config randomServers
smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode
agentAsync <- newTVarIO Nothing
random <- liftIO C.newRandom
@@ -281,6 +348,7 @@ newChatController
ChatController
{ firstTime,
currentUser,
randomServers,
currentRemoteHost,
smpAgent,
agentAsync,
@@ -318,28 +386,41 @@ newChatController
contactMergeEnabled
}
where
configServers :: DefaultAgentServers
configServers =
let DefaultAgentServers {smp = defSmp, xftp = defXftp, netCfg} = defaultServers
smp' = maybe defSmp (L.map enabledServerCfg) (nonEmpty smpServers)
xftp' = maybe defXftp (L.map enabledServerCfg) (nonEmpty xftpServers)
in defaultServers {smp = smp', xftp = xftp', netCfg = updateNetworkConfig netCfg simpleNetCfg}
agentServers :: ChatConfig -> IO InitialAgentServers
agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do
users <- withTransaction chatStore getUsers
smp' <- getUserServers users SPSMP
xftp' <- getUserServers users SPXFTP
presetServers' :: PresetServers
presetServers' = presetServers {operators = operators', netCfg = netCfg'}
where
PresetServers {operators, netCfg} = presetServers
netCfg' = updateNetworkConfig netCfg simpleNetCfg
operators' = case (smpServers, xftpServers) of
([], []) -> operators
(smpSrvs, []) -> L.map disableSMP operators <> [custom smpSrvs []]
([], xftpSrvs) -> L.map disableXFTP operators <> [custom [] xftpSrvs]
(smpSrvs, xftpSrvs) -> [custom smpSrvs xftpSrvs]
disableSMP op@PresetOperator {smp} = (op :: PresetOperator) {smp = map disableSrv smp}
disableXFTP op@PresetOperator {xftp} = (op :: PresetOperator) {xftp = map disableSrv xftp}
disableSrv :: forall p. NewUserServer p -> NewUserServer p
disableSrv srv = (srv :: NewUserServer p) {enabled = False}
custom smpSrvs xftpSrvs =
PresetOperator
{ operator = Nothing,
smp = map newUserServer smpSrvs,
useSMP = 0,
xftp = map newUserServer xftpSrvs,
useXFTP = 0
}
agentServers :: DB.Connection -> ChatConfig -> RandomServers -> IO InitialAgentServers
agentServers db ChatConfig {presetServers = PresetServers {operators = presetOps, ntf, netCfg}} rs = do
users <- getUsers db
opDomains <- operatorDomains <$> getUpdateServerOperators db presetOps (null users)
smp' <- getServers SPSMP users opDomains
xftp' <- getServers SPXFTP users opDomains
pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg}
where
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ServerCfg p)))
getUserServers users protocol = case users of
[] -> pure $ M.fromList [(1, cfgServers protocol defServers)]
_ -> M.fromList <$> initialServers
where
initialServers :: IO [(UserId, NonEmpty (ServerCfg p))]
initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users
userServers :: User -> IO (NonEmpty (ServerCfg p))
userServers user' = useServers config protocol <$> withTransaction chatStore (`getProtocolServers` user')
getServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [User] -> [(Text, ServerOperator)] -> IO (Map UserId (NonEmpty (ServerCfg p)))
getServers p users opDomains = do
let rs' = rndServers p rs
fmap M.fromList $ forM users $ \u ->
(aUserId u,) . agentServerCfgs opDomains rs' <$> getUpdateUserServers db p presetOps rs' u
updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig
updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} =
@@ -382,33 +463,37 @@ withFileLock :: String -> Int64 -> CM a -> CM a
withFileLock name = withEntityLock name . CLFile
{-# INLINE withFileLock #-}
useServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ServerCfg p)
useServers ChatConfig {defaultServers} p = fromMaybe (cfgServers p defaultServers) . nonEmpty
serverCfg :: ProtoServerWithAuth p -> ServerCfg p
serverCfg server = ServerCfg {server, operator = Nothing, enabled = True, roles = allRoles}
randomServers :: forall p. UserProtocol p => SProtocolType p -> ChatConfig -> IO (NonEmpty (ServerCfg p), [ServerCfg p])
randomServers p ChatConfig {defaultServers} = do
let srvs = cfgServers p defaultServers
(enbldSrvs, dsbldSrvs) = L.partition (\ServerCfg {enabled} -> enabled) srvs
toUse = cfgServersToUse p defaultServers
if length enbldSrvs <= toUse
then pure (srvs, [])
else do
(enbldSrvs', srvsToDisable) <- splitAt toUse <$> shuffle enbldSrvs
let dsbldSrvs' = map (\srv -> (srv :: ServerCfg p) {enabled = False}) srvsToDisable
srvs' = sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs
pure (fromMaybe srvs $ L.nonEmpty srvs', srvs')
useServers :: forall p. UserProtocol p => SProtocolType p -> RandomServers -> [UserServer p] -> NonEmpty (NewUserServer p)
useServers p rs servers = case L.nonEmpty servers of
Nothing -> rndServers p rs
Just srvs -> L.map (\srv -> (srv :: UserServer p) {serverId = DBNewEntity}) srvs
rndServers :: UserProtocol p => SProtocolType p -> RandomServers -> NonEmpty (NewUserServer p)
rndServers p RandomServers {smpServers, xftpServers} = case p of
SPSMP -> smpServers
SPXFTP -> xftpServers
randomPresetServers :: forall p. UserProtocol p => SProtocolType p -> PresetServers -> IO (NonEmpty (NewUserServer p))
randomPresetServers p PresetServers {operators} = toJust . L.nonEmpty . concat =<< mapM opSrvs operators
where
server' ServerCfg {server = ProtoServerWithAuth srv _} = srv
cfgServers :: UserProtocol p => SProtocolType p -> DefaultAgentServers -> NonEmpty (ServerCfg p)
cfgServers p DefaultAgentServers {smp, xftp} = case p of
SPSMP -> smp
SPXFTP -> xftp
cfgServersToUse :: UserProtocol p => SProtocolType p -> DefaultAgentServers -> Int
cfgServersToUse p DefaultAgentServers {useSMP, useXFTP} = case p of
SPSMP -> useSMP
SPXFTP -> useXFTP
toJust = \case
Just a -> pure a
Nothing -> E.throwIO $ userError "no preset servers"
opSrvs :: PresetOperator -> IO [NewUserServer p]
opSrvs op = do
let srvs = operatorServers p op
toUse = operatorServersToUse p op
(enbldSrvs, dsbldSrvs) = partition (\UserServer {enabled} -> enabled) srvs
if toUse <= 0 || toUse >= length enbldSrvs
then pure srvs
else do
(enbldSrvs', srvsToDisable) <- splitAt toUse <$> shuffle enbldSrvs
let dsbldSrvs' = map (\srv -> (srv :: NewUserServer p) {enabled = False}) srvsToDisable
pure $ sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs
server' UserServer {server = ProtoServerWithAuth srv _} = srv
-- enableSndFiles has no effect when mainApp is True
startChatController :: Bool -> Bool -> CM' (Async ())
@@ -552,19 +637,24 @@ processChatCommand' vr = \case
forM_ profile $ \Profile {displayName} -> checkValidName displayName
p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile
u <- asks currentUser
(smp, smpServers) <- chooseServers SPSMP
(xftp, xftpServers) <- chooseServers SPXFTP
smpServers <- chooseServers SPSMP
xftpServers <- chooseServers SPXFTP
users <- withFastStore' getUsers
forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash} ->
when (n == displayName) . throwChatError $
if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""}
opDomains <- operatorDomains . fst <$> withFastStore getServerOperators
rs <- asks randomServers
let smp = agentServerCfgs opDomains (rndServers SPSMP rs) smpServers
xftp = agentServerCfgs opDomains (rndServers SPXFTP rs) xftpServers
auId <- withAgent (\a -> createUser a smp xftp)
ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure
user <- withFastStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts
createPresetContactCards user `catchChatError` \_ -> pure ()
withFastStore $ \db -> createNoteFolder db user
storeServers user smpServers
storeServers user xftpServers
withFastStore $ \db -> do
createNoteFolder db user
liftIO $ mapM_ (insertProtocolServer db SPSMP user ts) $ useServers SPSMP rs smpServers
liftIO $ mapM_ (insertProtocolServer db SPXFTP user ts) $ useServers SPXFTP rs xftpServers
atomically . writeTVar u $ Just user
pure $ CRActiveUser user
where
@@ -573,18 +663,10 @@ processChatCommand' vr = \case
withFastStore $ \db -> do
createContact db user simplexStatusContactProfile
createContact db user simplexTeamContactProfile
chooseServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> CM (NonEmpty (ServerCfg p), [ServerCfg p])
chooseServers protocol =
asks currentUser >>= readTVarIO >>= \case
Nothing -> asks config >>= liftIO . randomServers protocol
Just user -> chosenServers =<< withFastStore' (`getProtocolServers` user)
where
chosenServers servers = do
cfg <- asks config
pure (useServers cfg protocol servers, servers)
storeServers user servers =
unless (null servers) . withFastStore $
\db -> overwriteProtocolServers db user servers
chooseServers :: forall p. ProtocolTypeI p => SProtocolType p -> CM [UserServer p]
chooseServers p = do
srvs <- chatReadVar currentUser >>= mapM (\user -> withFastStore' $ \db -> getProtocolServers db p user)
pure $ fromMaybe [] srvs
coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day)
day = 86400
ListUsers -> CRUsersList <$> withFastStore' getUsersInfo
@@ -735,14 +817,14 @@ processChatCommand' vr = \case
APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of
-- TODO optimize queries calculating ChatStats, currently they're disabled
CTDirect -> do
directChat <- withFastStore (\db -> getDirectChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTDirect directChat)
(directChat, navInfo) <- withFastStore (\db -> getDirectChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTDirect directChat) navInfo
CTGroup -> do
groupChat <- withFastStore (\db -> getGroupChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTGroup groupChat)
(groupChat, navInfo) <- withFastStore (\db -> getGroupChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTGroup groupChat) navInfo
CTLocal -> do
localChat <- withFastStore (\db -> getLocalChat db user cId pagination search)
pure $ CRApiChat user (AChat SCTLocal localChat)
(localChat, navInfo) <- withFastStore (\db -> getLocalChat db user cId pagination search)
pure $ CRApiChat user (AChat SCTLocal localChat) navInfo
CTContactRequest -> pure $ chatCmdError (Just user) "not implemented"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIGetChatItems pagination search -> withUser $ \user -> do
@@ -1482,25 +1564,83 @@ processChatCommand' vr = \case
msgs <- lift $ withAgent' $ \a -> getConnectionMessages a acIds
let ntfMsgs = L.map (\msg -> receivedMsgInfo <$> msg) msgs
pure $ CRConnNtfMessages ntfMsgs
APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
cfg@ChatConfig {defaultServers} <- asks config
servers <- withFastStore' (`getProtocolServers` user)
pure $ CRUserProtoServers user $ AUPS $ UserProtoServers p (useServers cfg p servers) (cfgServers p defaultServers)
GetUserProtoServers aProtocol -> withUser $ \User {userId} ->
processChatCommand $ APIGetUserProtoServers userId aProtocol
APISetUserProtoServers userId (APSC p (ProtoServersConfig servers))
| null servers || any (\ServerCfg {enabled} -> enabled) servers -> withUserId userId $ \user -> withServerProtocol p $ do
withFastStore $ \db -> overwriteProtocolServers db user servers
cfg <- asks config
lift $ withAgent' $ \a -> setProtocolServers a (aUserId user) $ useServers cfg p servers
ok user
| otherwise -> withUserId userId $ \user -> pure $ chatCmdError (Just user) "all servers are disabled"
SetUserProtoServers serversConfig -> withUser $ \User {userId} ->
processChatCommand $ APISetUserProtoServers userId serversConfig
GetUserProtoServers (AProtocolType p) -> withUser $ \user -> withServerProtocol p $ do
srvs <- withFastStore (`getUserServers` user)
CRUserServers user <$> liftIO (groupedServers srvs p)
where
groupedServers :: UserProtocol p => ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> SProtocolType p -> IO [UserOperatorServers]
groupedServers (operators, smpServers, xftpServers) = \case
SPSMP -> groupByOperator (operators, smpServers, [])
SPXFTP -> groupByOperator (operators, [], xftpServers)
SetUserProtoServers (AProtocolType (p :: SProtocolType p)) srvs -> withUser $ \user@User {userId} -> withServerProtocol p $ do
srvs' <- mapM aUserServer srvs
userServers_ <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user)
case L.nonEmpty userServers_ of
Nothing -> throwChatError $ CECommandError "no servers"
Just userServers -> case srvs of
[] -> throwChatError $ CECommandError "no servers"
_ -> processChatCommand $ APISetUserServers userId $ L.map (updatedSrvs p) userServers
where
-- disable preset and replace custom servers (groupByOperator always adds custom)
updatedSrvs :: UserProtocol p => SProtocolType p -> UserOperatorServers -> UpdatedUserOperatorServers
updatedSrvs p' UserOperatorServers {operator, smpServers, xftpServers} = case p' of
SPSMP -> u (updateSrvs smpServers, map (AUS SDBStored) xftpServers)
SPXFTP -> u (map (AUS SDBStored) smpServers, updateSrvs xftpServers)
where
u = uncurry $ UpdatedUserOperatorServers operator
updateSrvs :: [UserServer p] -> [AUserServer p]
updateSrvs pSrvs = map disableSrv pSrvs <> maybe srvs' (const []) operator
disableSrv srv@UserServer {preset} =
AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True}
where
aUserServer :: AProtoServerWithAuth -> CM (AUserServer p)
aUserServer (AProtoServerWithAuth p' srv) = case testEquality p p' of
Just Refl -> pure $ AUS SDBNew $ newUserServer srv
Nothing -> throwChatError $ CECommandError $ "incorrect server protocol: " <> B.unpack (strEncode srv)
APITestProtoServer userId srv@(AProtoServerWithAuth _ server) -> withUserId userId $ \user ->
lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server)
TestProtoServer srv -> withUser $ \User {userId} ->
processChatCommand $ APITestProtoServer userId srv
APIGetServerOperators -> uncurry CRServerOperators <$> withFastStore getServerOperators
APISetServerOperators operatorsEnabled -> withFastStore $ \db -> do
liftIO $ setServerOperators db operatorsEnabled
uncurry CRServerOperators <$> getServerOperators db
APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db ->
CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user)
APISetUserServers userId userServers -> withUserId userId $ \user -> do
let errors = validateUserServers userServers
unless (null errors) $ throwChatError (CECommandError $ "user servers validation error(s): " <> show errors)
(operators, smpServers, xftpServers) <- withFastStore $ \db -> do
setUserServers db user userServers
getUserServers db user
let opDomains = operatorDomains operators
rs <- asks randomServers
lift $ withAgent' $ \a -> do
let auId = aUserId user
setProtocolServers a auId $ agentServerCfgs opDomains (rndServers SPSMP rs) smpServers
setProtocolServers a auId $ agentServerCfgs opDomains (rndServers SPXFTP rs) xftpServers
ok_
APIValidateServers userServers -> pure $ CRUserServersValidation $ validateUserServers userServers
APIGetUsageConditions -> do
(usageConditions, acceptedConditions) <- withFastStore $ \db -> do
usageConditions <- getCurrentUsageConditions db
acceptedConditions <- liftIO $ getLatestAcceptedConditions db
pure (usageConditions, acceptedConditions)
-- TODO if db commit is different from source commit, conditionsText should be nothing in response
pure
CRUsageConditions
{ usageConditions,
conditionsText = usageConditionsText,
acceptedConditions
}
APISetConditionsNotified condId -> do
currentTs <- liftIO getCurrentTime
withFastStore' $ \db -> setConditionsNotified db condId currentTs
ok_
APIAcceptConditions condId opIds -> withFastStore $ \db -> do
currentTs <- liftIO getCurrentTime
acceptConditions db condId opIds currentTs
uncurry CRServerOperators <$> getServerOperators db
APISetChatItemTTL userId newTTL_ -> withUserId userId $ \user ->
checkStoreNotChanged $
withChatLock "setChatItemTTL" $ do
@@ -1753,8 +1893,9 @@ processChatCommand' vr = \case
canKeepLink (CRInvitationUri crData _) newUser = do
let ConnReqUriData {crSmpQueues = q :| _} = crData
SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q
cfg <- asks config
newUserServers <- L.map (\ServerCfg {server} -> protoServer server) . useServers cfg SPSMP <$> withFastStore' (`getProtocolServers` newUser)
newUserServers <-
map protoServer' . filter (\ServerCfg {enabled} -> enabled)
<$> getKnownAgentServers SPSMP newUser
pure $ smpServer `elem` newUserServers
updateConnRecord user@User {userId} conn@PendingContactConnection {customUserProfileId} newUser = do
withAgent $ \a -> changeConnectionUser a (aUserId user) (aConnId' conn) (aUserId newUser)
@@ -2088,7 +2229,7 @@ processChatCommand' vr = \case
where
changeMemberRole user gInfo members m gEvent = do
let GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberContactId, localDisplayName = cName} = m
assertUserGroupRole gInfo $ maximum [GRAdmin, mRole, memRole]
assertUserGroupRole gInfo $ maximum ([GRAdmin, mRole, memRole] :: [GroupMemberRole])
withGroupLock "memberRole" groupId . procCmd $ do
unless (mRole == memRole) $ do
withFastStore' $ \db -> updateGroupMemberRole db user m memRole
@@ -2486,14 +2627,15 @@ processChatCommand' vr = \case
pure $ CRAgentSubsTotal user subsTotal hasSession
GetAgentServersSummary userId -> withUserId userId $ \user -> do
agentServersSummary <- lift $ withAgent' getAgentServersSummary
cfg <- asks config
(users, smpServers, xftpServers) <-
withStore' $ \db -> (,,) <$> getUsers db <*> getServers db cfg user SPSMP <*> getServers db cfg user SPXFTP
let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers _defaultNtfServers
pure $ CRAgentServersSummary user presentedServersSummary
withStore' $ \db -> do
users <- getUsers db
smpServers <- getServers db user SPSMP
xftpServers <- getServers db user SPXFTP
let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers _defaultNtfServers
pure $ CRAgentServersSummary user presentedServersSummary
where
getServers :: (ProtocolTypeI p, UserProtocol p) => DB.Connection -> ChatConfig -> User -> SProtocolType p -> IO (NonEmpty (ProtocolServer p))
getServers db cfg user p = L.map (\ServerCfg {server} -> protoServer server) . useServers cfg p <$> getProtocolServers db user
getServers :: ProtocolTypeI p => DB.Connection -> User -> SProtocolType p -> IO [ProtocolServer p]
getServers db user p = map (\UserServer {server} -> protoServer server) <$> getProtocolServers db p user
ResetAgentServersStats -> withAgent resetAgentServersStats >> ok_
GetAgentWorkers -> lift $ CRAgentWorkersSummary <$> withAgent' getAgentWorkersSummary
GetAgentWorkersDetails -> lift $ CRAgentWorkersDetails <$> withAgent' getAgentWorkersDetails
@@ -3611,8 +3753,7 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
S.toList $ S.fromList $ concatMap (\FD.FileChunk {replicas} -> map (\FD.FileChunkReplica {server} -> server) replicas) chunks
getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer]
getUnknownSrvs srvs = do
cfg <- asks config
knownSrvs <- L.map (\ServerCfg {server} -> protoServer server) . useServers cfg SPXFTP <$> withStore' (`getProtocolServers` user)
knownSrvs <- map protoServer' <$> getKnownAgentServers SPXFTP user
pure $ filter (`notElem` knownSrvs) srvs
ipProtectedForSrvs :: [XFTPServer] -> CM Bool
ipProtectedForSrvs srvs = do
@@ -3626,6 +3767,17 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
toView $ CRChatItemUpdated user aci
throwChatError $ CEFileNotApproved fileId unknownSrvs
getKnownAgentServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> User -> CM [ServerCfg p]
getKnownAgentServers p user = do
rs <- asks randomServers
withStore $ \db -> do
opDomains <- operatorDomains . fst <$> getServerOperators db
srvs <- liftIO $ getProtocolServers db p user
pure $ L.toList $ agentServerCfgs opDomains (rndServers p rs) srvs
protoServer' :: ServerCfg p -> ProtocolServer p
protoServer' ServerCfg {server} = protoServer server
getNetworkConfig :: CM' NetworkConfig
getNetworkConfig = withAgent' $ liftIO . getFastNetworkConfig
@@ -3824,7 +3976,7 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do
(sftConns, sfts) <- getSndFileTransferConns
(rftConns, rfts) <- getRcvFileTransferConns
(pcConns, pcs) <- getPendingContactConns
let conns = concat [ctConns, ucConns, mConns, sftConns, rftConns, pcConns]
let conns = concat ([ctConns, ucConns, mConns, sftConns, rftConns, pcConns] :: [[ConnId]])
pure (conns, cts, ucs, gs, ms, sfts, rfts, pcs)
-- subscribe using batched commands
rs <- withAgent $ \a -> agentBatchSubscribe a conns
@@ -4632,7 +4784,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct)
SWITCH qd phase cStats -> do
toView $ CRContactSwitch user ct (SwitchProgress qd phase cStats)
when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
when (phase == SPStarted || phase == SPCompleted) $ case qd of
QDRcv -> createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCESwitchQueue phase Nothing) Nothing
QDSnd -> createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
RSYNC rss cryptoErr_ cStats ->
@@ -4917,7 +5069,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(Just fileDescrText, Just msgId) -> do
partSize <- asks $ xftpDescrPartSize . config
let parts = splitFileDescr partSize fileDescrText
pure . toList $ L.map (XMsgFileDescr msgId) parts
pure . L.toList $ L.map (XMsgFileDescr msgId) parts
_ -> pure []
let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents
GroupMember {memberId} = sender
@@ -5043,7 +5195,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
when continued $ sendPendingGroupMessages user m conn
SWITCH qd phase cStats -> do
toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats)
when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
when (phase == SPStarted || phase == SPCompleted) $ case qd of
QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing
QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
RSYNC rss cryptoErr_ cStats ->
@@ -6607,15 +6759,17 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
messageWarning "x.grp.mem.con: neither member is invitee"
where
inviteeXGrpMemCon :: GroupMemberIntro -> CM ()
inviteeXGrpMemCon GroupMemberIntro {introId, introStatus}
| introStatus == GMIntroReConnected = updateStatus introId GMIntroConnected
| introStatus `elem` [GMIntroToConnected, GMIntroConnected] = pure ()
| otherwise = updateStatus introId GMIntroToConnected
inviteeXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of
GMIntroReConnected -> updateStatus introId GMIntroConnected
GMIntroToConnected -> pure ()
GMIntroConnected -> pure ()
_ -> updateStatus introId GMIntroToConnected
forwardMemberXGrpMemCon :: GroupMemberIntro -> CM ()
forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus}
| introStatus == GMIntroToConnected = updateStatus introId GMIntroConnected
| introStatus `elem` [GMIntroReConnected, GMIntroConnected] = pure ()
| otherwise = updateStatus introId GMIntroReConnected
forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of
GMIntroToConnected -> updateStatus introId GMIntroConnected
GMIntroReConnected -> pure ()
GMIntroConnected -> pure ()
_ -> updateStatus introId GMIntroReConnected
updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> CM ()
@@ -8080,14 +8234,18 @@ chatCommandP =
"/smp test " *> (TestProtoServer . AProtoServerWithAuth SPSMP <$> strP),
"/xftp test " *> (TestProtoServer . AProtoServerWithAuth SPXFTP <$> strP),
"/ntf test " *> (TestProtoServer . AProtoServerWithAuth SPNTF <$> strP),
"/_servers " *> (APISetUserProtoServers <$> A.decimal <* A.space <*> srvCfgP),
"/smp " *> (SetUserProtoServers . APSC SPSMP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP),
"/smp default" $> SetUserProtoServers (APSC SPSMP $ ProtoServersConfig []),
"/xftp " *> (SetUserProtoServers . APSC SPXFTP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP),
"/xftp default" $> SetUserProtoServers (APSC SPXFTP $ ProtoServersConfig []),
"/_servers " *> (APIGetUserProtoServers <$> A.decimal <* A.space <*> strP),
"/smp " *> (SetUserProtoServers (AProtocolType SPSMP) . map (AProtoServerWithAuth SPSMP) <$> protocolServersP),
"/xftp " *> (SetUserProtoServers (AProtocolType SPXFTP) . map (AProtoServerWithAuth SPXFTP) <$> protocolServersP),
"/smp" $> GetUserProtoServers (AProtocolType SPSMP),
"/xftp" $> GetUserProtoServers (AProtocolType SPXFTP),
"/_operators" $> APIGetServerOperators,
"/_operators " *> (APISetServerOperators <$> jsonP),
"/_servers " *> (APIGetUserServers <$> A.decimal),
"/_servers " *> (APISetUserServers <$> A.decimal <* A.space <*> jsonP),
"/_validate_servers " *> (APIValidateServers <$> jsonP),
"/_conditions" $> APIGetUsageConditions,
"/_conditions_notified " *> (APISetConditionsNotified <$> A.decimal),
"/_accept_conditions " *> (APIAcceptConditions <$> A.decimal <*> _strP),
"/_ttl " *> (APISetChatItemTTL <$> A.decimal <* A.space <*> ciTTLDecimal),
"/ttl " *> (SetChatItemTTL <$> ciTTL),
"/_ttl " *> (APIGetChatItemTTL <$> A.decimal),
@@ -8301,6 +8459,8 @@ chatCommandP =
(CPLast <$ "count=" <*> A.decimal)
<|> (CPAfter <$ "after=" <*> A.decimal <* A.space <* "count=" <*> A.decimal)
<|> (CPBefore <$ "before=" <*> A.decimal <* A.space <* "count=" <*> A.decimal)
<|> (CPAround <$ "around=" <*> A.decimal <* A.space <* "count=" <*> A.decimal)
<|> (CPInitial <$ "initial=" <*> A.decimal)
paginationByTimeP =
(PTLast <$ "count=" <*> A.decimal)
<|> (PTAfter <$ "after=" <*> strP <* A.space <* "count=" <*> A.decimal)
@@ -8429,7 +8589,6 @@ chatCommandP =
onOffP
(Just <$> (AutoAccept <$> (" incognito=" *> onOffP <|> pure False) <*> optional (A.space *> msgContentP)))
(pure Nothing)
srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP)
rcCtrlAddressP = RCCtrlAddress <$> ("addr=" *> strP) <*> (" iface=" *> (jsonP <|> text1P))
text1P = safeDecodeUtf8 <$> A.takeTill (== ' ')
char_ = optional . A.char
+7 -9
View File
@@ -12,6 +12,7 @@ import Control.Concurrent.STM
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Chat.Controller
import Simplex.Chat.Core
@@ -31,10 +32,10 @@ chatBotRepl welcome answer _user cc = do
case resp of
CRContactConnected _ contact _ -> do
contactConnected contact
void $ sendMessage cc contact welcome
void $ sendMessage cc contact $ T.pack welcome
CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) : _} -> do
let msg = T.unpack $ ciContentToText mc
void $ sendMessage cc contact =<< answer contact msg
void $ sendMessage cc contact . T.pack =<< answer contact msg
_ -> pure ()
where
contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"
@@ -57,11 +58,11 @@ initializeBotAddress' logAddress cc = do
when logAddress $ putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri)
void $ sendChatCmd cc $ AddressAutoAccept $ Just AutoAccept {acceptIncognito = False, autoReply = Nothing}
sendMessage :: ChatController -> Contact -> String -> IO ()
sendMessage cc ct = sendComposedMessage cc ct Nothing . textMsgContent
sendMessage :: ChatController -> Contact -> Text -> IO ()
sendMessage cc ct = sendComposedMessage cc ct Nothing . MCText
sendMessage' :: ChatController -> ContactId -> String -> IO ()
sendMessage' cc ctId = sendComposedMessage' cc ctId Nothing . textMsgContent
sendMessage' :: ChatController -> ContactId -> Text -> IO ()
sendMessage' cc ctId = sendComposedMessage' cc ctId Nothing . MCText
sendComposedMessage :: ChatController -> Contact -> Maybe ChatItemId -> MsgContent -> IO ()
sendComposedMessage cc = sendComposedMessage' cc . contactId'
@@ -83,9 +84,6 @@ deleteMessage cc ct chatItemId = do
contactRef :: Contact -> ChatRef
contactRef = ChatRef CTDirect . contactId'
textMsgContent :: String -> MsgContent
textMsgContent = MCText . T.pack
printLog :: ChatController -> ChatLogLevel -> String -> IO ()
printLog cc level s
| logLevel (config cc) <= level = putStrLn s
+2 -2
View File
@@ -18,8 +18,8 @@ data KnownContact = KnownContact
}
deriving (Eq)
knownContactNames :: [KnownContact] -> String
knownContactNames = T.unpack . T.intercalate ", " . map (("@" <>) . localDisplayName)
knownContactNames :: [KnownContact] -> Text
knownContactNames = T.intercalate ", " . map (("@" <>) . localDisplayName)
parseKnownContacts :: ReadM [KnownContact]
parseKnownContacts = eitherReader $ parseAll knownContactsP . encodeUtf8 . T.pack
+59 -44
View File
@@ -35,7 +35,6 @@ import qualified Data.ByteArray as BA
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (ord)
import Data.Constraint (Dict (..))
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
@@ -57,6 +56,7 @@ import Simplex.Chat.Call
import Simplex.Chat.Markdown (MarkdownList)
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Operators
import Simplex.Chat.Protocol
import Simplex.Chat.Remote.AppVersion
import Simplex.Chat.Remote.Types
@@ -70,7 +70,7 @@ import Simplex.Chat.Util (liftIOEither)
import Simplex.FileTransfer.Description (FileDescriptionURI)
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction, withTransactionPriority)
@@ -84,7 +84,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), ProtocolTypeI, QueueId, SMPMsgMeta (..), SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol)
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), QueueId, SMPMsgMeta (..), SubscriptionMode (..), XFTPServer)
import Simplex.Messaging.TMap (TMap)
import Simplex.Messaging.Transport (TLS, simplexMQVersion)
import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost)
@@ -132,7 +132,7 @@ data ChatConfig = ChatConfig
{ agentConfig :: AgentConfig,
chatVRange :: VersionRangeChat,
confirmMigrations :: MigrationConfirmation,
defaultServers :: DefaultAgentServers,
presetServers :: PresetServers,
tbqSize :: Natural,
fileChunkSize :: Integer,
xftpDescrPartSize :: Int,
@@ -154,6 +154,12 @@ data ChatConfig = ChatConfig
chatHooks :: ChatHooks
}
data RandomServers = RandomServers
{ smpServers :: NonEmpty (NewUserServer 'PSMP),
xftpServers :: NonEmpty (NewUserServer 'PXFTP)
}
deriving (Show)
-- The hooks can be used to extend or customize chat core in mobile or CLI clients.
data ChatHooks = ChatHooks
{ -- preCmdHook can be used to process or modify the commands before they are processed.
@@ -172,12 +178,9 @@ defaultChatHooks =
eventHook = \_ -> pure
}
data DefaultAgentServers = DefaultAgentServers
{ smp :: NonEmpty (ServerCfg 'PSMP),
useSMP :: Int,
data PresetServers = PresetServers
{ operators :: NonEmpty PresetOperator,
ntf :: [NtfServer],
xftp :: NonEmpty (ServerCfg 'PXFTP),
useXFTP :: Int,
netCfg :: NetworkConfig
}
@@ -203,6 +206,7 @@ data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLite
data ChatController = ChatController
{ currentUser :: TVar (Maybe User),
randomServers :: RandomServers,
currentRemoteHost :: TVar (Maybe RemoteHostId),
firstTime :: Bool,
smpAgent :: AgentClient,
@@ -346,12 +350,18 @@ data ChatCommand
| APIGetGroupLink GroupId
| APICreateMemberContact GroupId GroupMemberId
| APISendMemberContactInvitation {contactId :: ContactId, msgContent_ :: Maybe MsgContent}
| APIGetUserProtoServers UserId AProtocolType
| GetUserProtoServers AProtocolType
| APISetUserProtoServers UserId AProtoServersConfig
| SetUserProtoServers AProtoServersConfig
| SetUserProtoServers AProtocolType [AProtoServerWithAuth]
| APITestProtoServer UserId AProtoServerWithAuth
| TestProtoServer AProtoServerWithAuth
| APIGetServerOperators
| APISetServerOperators (NonEmpty ServerOperator)
| APIGetUserServers UserId
| APISetUserServers UserId (NonEmpty UpdatedUserOperatorServers)
| APIValidateServers (NonEmpty UpdatedUserOperatorServers) -- response is CRUserServersValidation
| APIGetUsageConditions
| APISetConditionsNotified Int64
| APIAcceptConditions Int64 (NonEmpty Int64)
| APISetChatItemTTL UserId (Maybe Int64)
| SetChatItemTTL (Maybe Int64)
| APIGetChatItemTTL UserId
@@ -572,13 +582,16 @@ data ChatResponse
| CRChatSuspended
| CRApiChats {user :: User, chats :: [AChat]}
| CRChats {chats :: [AChat]}
| CRApiChat {user :: User, chat :: AChat}
| CRApiChat {user :: User, chat :: AChat, navInfo :: Maybe NavigationInfo}
| CRChatItems {user :: User, chatName_ :: Maybe ChatName, chatItems :: [AChatItem]}
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
| CRChatItemId User (Maybe ChatItemId)
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
| CRUserProtoServers {user :: User, servers :: AUserProtoServers}
| CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
| CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction}
| CRUserServers {user :: User, userServers :: [UserOperatorServers]}
| CRUserServersValidation {serverErrors :: [UserServersError]}
| CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions}
| CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}
| CRNetworkConfig {networkConfig :: NetworkConfig}
| CRContactInfo {user :: User, contact :: Contact, connectionStats_ :: Maybe ConnectionStats, customUserProfile :: Maybe Profile}
@@ -839,6 +852,8 @@ data ChatPagination
= CPLast Int
| CPAfter ChatItemId Int
| CPBefore ChatItemId Int
| CPAround ChatItemId Int
| CPInitial Int
deriving (Show)
data PaginationByTime
@@ -941,23 +956,23 @@ instance ToJSON AgentQueueId where
toJSON = strToJSON
toEncoding = strToJEncoding
data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
deriving (Show)
-- data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
-- deriving (Show)
data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
-- data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
deriving instance Show AProtoServersConfig
-- deriving instance Show AProtoServersConfig
data UserProtoServers p = UserProtoServers
{ serverProtocol :: SProtocolType p,
protoServers :: NonEmpty (ServerCfg p),
presetServers :: NonEmpty (ServerCfg p)
}
deriving (Show)
-- data UserProtoServers p = UserProtoServers
-- { serverProtocol :: SProtocolType p,
-- protoServers :: NonEmpty (ServerCfg p),
-- presetServers :: NonEmpty (ServerCfg p)
-- }
-- deriving (Show)
data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
-- data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
deriving instance Show AUserProtoServers
-- deriving instance Show AUserProtoServers
data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool, parentTempDirectory :: Maybe FilePath}
deriving (Show)
@@ -1560,28 +1575,28 @@ $(JQ.deriveJSON defaultJSON ''CoreVersionInfo)
$(JQ.deriveJSON defaultJSON ''SlowSQLQuery)
instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
-- instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
-- parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
-- instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
-- parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
-- instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
-- toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
-- toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
instance FromJSON AUserProtoServers where
parseJSON v = J.withObject "AUserProtoServers" parse v
where
parse o = do
AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
case userProtocol p of
Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
-- instance FromJSON AUserProtoServers where
-- parseJSON v = J.withObject "AUserProtoServers" parse v
-- where
-- parse o = do
-- AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
-- case userProtocol p of
-- Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
-- Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
instance ToJSON AUserProtoServers where
toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
-- instance ToJSON AUserProtoServers where
-- toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
-- toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCS") ''RemoteCtrlSessionState)
+16 -2
View File
@@ -227,8 +227,8 @@ data CChatItem c = forall d. MsgDirectionI d => CChatItem (SMsgDirection d) (Cha
deriving instance Show (CChatItem c)
cchatItemId :: CChatItem c -> ChatItemId
cchatItemId (CChatItem _ ci) = chatItemId' ci
cChatItemId :: CChatItem c -> ChatItemId
cChatItemId (CChatItem _ ci) = chatItemId' ci
chatItemId' :: ChatItem c d -> ChatItemId
chatItemId' ChatItem {meta = CIMeta {itemId}} = itemId
@@ -239,6 +239,12 @@ chatItemTs (CChatItem _ ci) = chatItemTs' ci
chatItemTs' :: ChatItem c d -> UTCTime
chatItemTs' ChatItem {meta = CIMeta {itemTs}} = itemTs
ciCreatedAt :: CChatItem c -> UTCTime
ciCreatedAt (CChatItem _ ci) = ciCreatedAt' ci
ciCreatedAt' :: ChatItem c d -> UTCTime
ciCreatedAt' ChatItem {meta = CIMeta {createdAt}} = createdAt
chatItemTimed :: ChatItem c d -> Maybe CITimed
chatItemTimed ChatItem {meta = CIMeta {itemTimed}} = itemTimed
@@ -318,6 +324,12 @@ data ChatStats = ChatStats
}
deriving (Show)
data NavigationInfo = NavigationInfo
{ afterUnread :: Int,
afterTotal :: Int
}
deriving (Show)
-- | type to show a mix of messages from multiple chats
data AChatItem = forall c d. (ChatTypeI c, MsgDirectionI d) => AChatItem (SChatType c) (SMsgDirection d) (ChatInfo c) (ChatItem c d)
@@ -1408,6 +1420,8 @@ $(JQ.deriveJSON defaultJSON ''ChatItemInfo)
$(JQ.deriveJSON defaultJSON ''ChatStats)
$(JQ.deriveJSON defaultJSON ''NavigationInfo)
instance ChatTypeI c => ToJSON (Chat c) where
toJSON = $(JQ.mkToJSON defaultJSON ''Chat)
toEncoding = $(JQ.mkToEncoding defaultJSON ''Chat)
@@ -0,0 +1,34 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20241023_chat_item_autoincrement_id where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20241023_chat_item_autoincrement_id :: Query
m20241023_chat_item_autoincrement_id =
[sql|
INSERT INTO sqlite_sequence (name, seq)
SELECT 'chat_items', MAX(ROWID) FROM chat_items;
PRAGMA writable_schema=1;
UPDATE sqlite_master SET sql = replace(sql, 'INTEGER PRIMARY KEY', 'INTEGER PRIMARY KEY AUTOINCREMENT')
WHERE name = 'chat_items' AND type = 'table';
PRAGMA writable_schema=0;
|]
down_m20241023_chat_item_autoincrement_id :: Query
down_m20241023_chat_item_autoincrement_id =
[sql|
DELETE FROM sqlite_sequence WHERE name = 'chat_items';
PRAGMA writable_schema=1;
UPDATE sqlite_master
SET sql = replace(sql, 'INTEGER PRIMARY KEY AUTOINCREMENT', 'INTEGER PRIMARY KEY')
WHERE name = 'chat_items' AND type = 'table';
PRAGMA writable_schema=0;
|]
@@ -0,0 +1,54 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20241027_server_operators where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20241027_server_operators :: Query
m20241027_server_operators =
[sql|
CREATE TABLE server_operators (
server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
server_operator_tag TEXT,
trade_name TEXT NOT NULL,
legal_name TEXT,
server_domains TEXT,
enabled INTEGER NOT NULL DEFAULT 1,
role_storage INTEGER NOT NULL DEFAULT 1,
role_proxy INTEGER NOT NULL DEFAULT 1,
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
);
CREATE TABLE usage_conditions (
usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
conditions_commit TEXT NOT NULL UNIQUE,
notified_at TEXT,
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
);
CREATE TABLE operator_usage_conditions (
operator_usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
server_operator_id INTEGER REFERENCES server_operators (server_operator_id) ON DELETE SET NULL ON UPDATE CASCADE,
server_operator_tag TEXT,
conditions_commit TEXT NOT NULL,
accepted_at TEXT,
created_at TEXT NOT NULL DEFAULT (datetime('now'))
);
CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(server_operator_id);
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(conditions_commit, server_operator_id);
|]
down_m20241027_server_operators :: Query
down_m20241027_server_operators =
[sql|
DROP INDEX idx_operator_usage_conditions_conditions_commit;
DROP INDEX idx_operator_usage_conditions_server_operator_id;
DROP TABLE operator_usage_conditions;
DROP TABLE usage_conditions;
DROP TABLE server_operators;
|]
+36 -2
View File
@@ -360,7 +360,7 @@ CREATE TABLE pending_group_messages(
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE chat_items(
chat_item_id INTEGER PRIMARY KEY,
chat_item_id INTEGER PRIMARY KEY AUTOINCREMENT,
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
contact_id INTEGER REFERENCES contacts ON DELETE CASCADE,
group_id INTEGER REFERENCES groups ON DELETE CASCADE,
@@ -399,6 +399,7 @@ CREATE TABLE chat_items(
fwd_from_chat_item_id INTEGER REFERENCES chat_items ON DELETE SET NULL,
via_proxy INTEGER
);
CREATE TABLE sqlite_sequence(name,seq);
CREATE TABLE chat_item_messages(
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
message_id INTEGER NOT NULL UNIQUE REFERENCES messages ON DELETE CASCADE,
@@ -429,7 +430,6 @@ CREATE TABLE commands(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE sqlite_sequence(name,seq);
CREATE TABLE settings(
settings_id INTEGER PRIMARY KEY,
chat_item_ttl INTEGER,
@@ -589,6 +589,33 @@ CREATE TABLE note_folders(
unread_chat INTEGER NOT NULL DEFAULT 0
);
CREATE TABLE app_settings(app_settings TEXT NOT NULL);
CREATE TABLE server_operators(
server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
server_operator_tag TEXT,
trade_name TEXT NOT NULL,
legal_name TEXT,
server_domains TEXT,
enabled INTEGER NOT NULL DEFAULT 1,
role_storage INTEGER NOT NULL DEFAULT 1,
role_proxy INTEGER NOT NULL DEFAULT 1,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE usage_conditions(
usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
conditions_commit TEXT NOT NULL UNIQUE,
notified_at TEXT,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE operator_usage_conditions(
operator_usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
server_operator_id INTEGER REFERENCES server_operators(server_operator_id) ON DELETE SET NULL ON UPDATE CASCADE,
server_operator_tag TEXT,
conditions_commit TEXT NOT NULL,
accepted_at TEXT,
created_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE INDEX contact_profiles_index ON contact_profiles(
display_name,
full_name
@@ -890,3 +917,10 @@ CREATE INDEX idx_received_probes_group_member_id on received_probes(
group_member_id
);
CREATE INDEX idx_contact_requests_contact_id ON contact_requests(contact_id);
CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(
server_operator_id
);
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(
conditions_commit,
server_operator_id
);
+438
View File
@@ -0,0 +1,438 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Operators where
import Control.Applicative ((<|>))
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.TH as JQ
import Data.FileEmbed
import Data.Foldable (foldMap')
import Data.IORef
import Data.Int (Int64)
import Data.List (find, foldl')
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
import Data.Scientific (floatingOrInteger)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (addUTCTime)
import Data.Time.Clock (UTCTime, nominalDay)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import Language.Haskell.TH.Syntax (lift)
import Simplex.Chat.Operators.Conditions
import Simplex.Chat.Types.Util (textParseJSON)
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON)
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..), UserProtocol)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Util (atomicModifyIORef'_, safeDecodeUtf8)
usageConditionsCommit :: Text
usageConditionsCommit = "a5061f3147165a05979d6ace33960aced2d6ac03"
previousConditionsCommit :: Text
previousConditionsCommit = "11a44dc1fd461a93079f897048b46998db55da5c"
usageConditionsText :: Text
usageConditionsText =
$( let s = $(embedFile =<< makeRelativeToProject "PRIVACY.md")
in [|stripFrontMatter $(lift (safeDecodeUtf8 s))|]
)
data DBStored = DBStored | DBNew
data SDBStored (s :: DBStored) where
SDBStored :: SDBStored 'DBStored
SDBNew :: SDBStored 'DBNew
deriving instance Show (SDBStored s)
class DBStoredI s where sdbStored :: SDBStored s
instance DBStoredI 'DBStored where sdbStored = SDBStored
instance DBStoredI 'DBNew where sdbStored = SDBNew
data DBEntityId' (s :: DBStored) where
DBEntityId :: Int64 -> DBEntityId' 'DBStored
DBNewEntity :: DBEntityId' 'DBNew
deriving instance Show (DBEntityId' s)
type DBEntityId = DBEntityId' 'DBStored
type DBNewEntity = DBEntityId' 'DBNew
data OperatorTag = OTSimplex | OTFlux
deriving (Eq, Ord, Show)
instance FromField OperatorTag where fromField = fromTextField_ textDecode
instance ToField OperatorTag where toField = toField . textEncode
instance FromJSON OperatorTag where
parseJSON = textParseJSON "OperatorTag"
instance ToJSON OperatorTag where
toJSON = J.String . textEncode
toEncoding = JE.text . textEncode
instance TextEncoding OperatorTag where
textDecode = \case
"simplex" -> Just OTSimplex
"flux" -> Just OTFlux
_ -> Nothing
textEncode = \case
OTSimplex -> "simplex"
OTFlux -> "flux"
-- this and other types only define instances of serialization for known DB IDs only,
-- entities without IDs cannot be serialized to JSON
instance FromField DBEntityId where fromField f = DBEntityId <$> fromField f
instance ToField DBEntityId where toField (DBEntityId i) = toField i
data UsageConditions = UsageConditions
{ conditionsId :: Int64,
conditionsCommit :: Text,
notifiedAt :: Maybe UTCTime,
createdAt :: UTCTime
}
deriving (Show)
data UsageConditionsAction
= UCAReview {operators :: [ServerOperator], deadline :: Maybe UTCTime, showNotice :: Bool}
| UCAAccepted {operators :: [ServerOperator]}
deriving (Show)
usageConditionsAction :: [ServerOperator] -> UsageConditions -> UTCTime -> Maybe UsageConditionsAction
usageConditionsAction operators UsageConditions {createdAt, notifiedAt} now = do
let enabledOperators = filter (\ServerOperator {enabled} -> enabled) operators
if
| null enabledOperators -> Nothing
| all conditionsAccepted enabledOperators ->
let acceptedForOperators = filter conditionsAccepted operators
in Just $ UCAAccepted acceptedForOperators
| otherwise ->
let acceptForOperators = filter (not . conditionsAccepted) enabledOperators
deadline = conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
showNotice = isNothing notifiedAt
in Just $ UCAReview acceptForOperators deadline showNotice
conditionsRequiredOrDeadline :: UTCTime -> UTCTime -> Maybe UTCTime
conditionsRequiredOrDeadline createdAt notifiedAtOrNow =
if notifiedAtOrNow < addUTCTime (14 * nominalDay) createdAt
then Just $ conditionsDeadline notifiedAtOrNow
else Nothing -- required
where
conditionsDeadline :: UTCTime -> UTCTime
conditionsDeadline = addUTCTime (31 * nominalDay)
data ConditionsAcceptance
= CAAccepted {acceptedAt :: Maybe UTCTime}
| CARequired {deadline :: Maybe UTCTime}
deriving (Show)
type ServerOperator = ServerOperator' 'DBStored
type NewServerOperator = ServerOperator' 'DBNew
data AServerOperator = forall s. ASO (SDBStored s) (ServerOperator' s)
deriving instance Show AServerOperator
data ServerOperator' s = ServerOperator
{ operatorId :: DBEntityId' s,
operatorTag :: Maybe OperatorTag,
tradeName :: Text,
legalName :: Maybe Text,
serverDomains :: [Text],
conditionsAcceptance :: ConditionsAcceptance,
enabled :: Bool,
roles :: ServerRoles
}
deriving (Show)
conditionsAccepted :: ServerOperator -> Bool
conditionsAccepted ServerOperator {conditionsAcceptance} = case conditionsAcceptance of
CAAccepted {} -> True
_ -> False
data UserOperatorServers = UserOperatorServers
{ operator :: Maybe ServerOperator,
smpServers :: [UserServer 'PSMP],
xftpServers :: [UserServer 'PXFTP]
}
deriving (Show)
data UpdatedUserOperatorServers = UpdatedUserOperatorServers
{ operator :: Maybe ServerOperator,
smpServers :: [AUserServer 'PSMP],
xftpServers :: [AUserServer 'PXFTP]
}
deriving (Show)
updatedServers :: UserProtocol p => UpdatedUserOperatorServers -> SProtocolType p -> [AUserServer p]
updatedServers UpdatedUserOperatorServers {smpServers, xftpServers} = \case
SPSMP -> smpServers
SPXFTP -> xftpServers
type UserServer p = UserServer' 'DBStored p
type NewUserServer p = UserServer' 'DBNew p
data AUserServer p = forall s. AUS (SDBStored s) (UserServer' s p)
deriving instance Show (AUserServer p)
data UserServer' s p = UserServer
{ serverId :: DBEntityId' s,
server :: ProtoServerWithAuth p,
preset :: Bool,
tested :: Maybe Bool,
enabled :: Bool,
deleted :: Bool
}
deriving (Show)
data PresetOperator = PresetOperator
{ operator :: Maybe NewServerOperator,
smp :: [NewUserServer 'PSMP],
useSMP :: Int,
xftp :: [NewUserServer 'PXFTP],
useXFTP :: Int
}
operatorServers :: UserProtocol p => SProtocolType p -> PresetOperator -> [NewUserServer p]
operatorServers p PresetOperator {smp, xftp} = case p of
SPSMP -> smp
SPXFTP -> xftp
operatorServersToUse :: UserProtocol p => SProtocolType p -> PresetOperator -> Int
operatorServersToUse p PresetOperator {useSMP, useXFTP} = case p of
SPSMP -> useSMP
SPXFTP -> useXFTP
presetServer :: Bool -> ProtoServerWithAuth p -> NewUserServer p
presetServer = newUserServer_ True
newUserServer :: ProtoServerWithAuth p -> NewUserServer p
newUserServer = newUserServer_ False True
newUserServer_ :: Bool -> Bool -> ProtoServerWithAuth p -> NewUserServer p
newUserServer_ preset enabled server =
UserServer {serverId = DBNewEntity, server, preset, tested = Nothing, enabled, deleted = False}
-- This function should be used inside DB transaction to update conditions in the database
-- it evaluates to (conditions to mark as accepted to SimpleX operator, current conditions, and conditions to add)
usageConditionsToAdd :: Bool -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, UsageConditions, [UsageConditions])
usageConditionsToAdd = usageConditionsToAdd' previousConditionsCommit usageConditionsCommit
-- This function is used in unit tests
usageConditionsToAdd' :: Text -> Text -> Bool -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, UsageConditions, [UsageConditions])
usageConditionsToAdd' prevCommit sourceCommit newUser createdAt = \case
[]
| newUser -> (Just sourceCond, sourceCond, [sourceCond])
| otherwise -> (Just prevCond, sourceCond, [prevCond, sourceCond])
where
prevCond = conditions 1 prevCommit
sourceCond = conditions 2 sourceCommit
conds
| hasSourceCond -> (Nothing, last conds, [])
| otherwise -> (Nothing, sourceCond, [sourceCond])
where
hasSourceCond = any ((sourceCommit ==) . conditionsCommit) conds
sourceCond = conditions cId sourceCommit
cId = maximum (map conditionsId conds) + 1
where
conditions cId commit = UsageConditions {conditionsId = cId, conditionsCommit = commit, notifiedAt = Nothing, createdAt}
-- This function should be used inside DB transaction to update operators.
-- It allows to add/remove/update preset operators in the database preserving enabled and roles settings,
-- and preserves custom operators without tags for forward compatibility.
updatedServerOperators :: NonEmpty PresetOperator -> [ServerOperator] -> [AServerOperator]
updatedServerOperators presetOps storedOps =
foldr addPreset [] presetOps
<> map (ASO SDBStored) (filter (isNothing . operatorTag) storedOps)
where
-- TODO remove domains of preset operators from custom
addPreset PresetOperator {operator} = case operator of
Nothing -> id
Just presetOp -> (storedOp' :)
where
storedOp' = case find ((operatorTag presetOp ==) . operatorTag) storedOps of
Just ServerOperator {operatorId, conditionsAcceptance, enabled, roles} ->
ASO SDBStored presetOp {operatorId, conditionsAcceptance, enabled, roles}
Nothing -> ASO SDBNew presetOp
-- This function should be used inside DB transaction to update servers.
updatedUserServers :: forall p. UserProtocol p => SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> [UserServer p] -> NonEmpty (AUserServer p)
updatedUserServers _ _ randomSrvs [] = L.map (AUS SDBNew) randomSrvs
updatedUserServers p presetOps randomSrvs srvs =
fromMaybe (L.map (AUS SDBNew) randomSrvs) (L.nonEmpty updatedSrvs)
where
updatedSrvs = map userServer presetSrvs <> map (AUS SDBStored) (filter customServer srvs)
storedSrvs :: Map (ProtoServerWithAuth p) (UserServer p)
storedSrvs = foldl' (\ss srv@UserServer {server} -> M.insert server srv ss) M.empty srvs
customServer :: UserServer p -> Bool
customServer srv = not (preset srv) && all (`S.notMember` presetHosts) (srvHost srv)
presetSrvs :: [NewUserServer p]
presetSrvs = concatMap (operatorServers p) presetOps
presetHosts :: Set TransportHost
presetHosts = foldMap' (S.fromList . L.toList . srvHost) presetSrvs
userServer :: NewUserServer p -> AUserServer p
userServer srv@UserServer {server} = maybe (AUS SDBNew srv) (AUS SDBStored) (M.lookup server storedSrvs)
srvHost :: UserServer' s p -> NonEmpty TransportHost
srvHost UserServer {server = ProtoServerWithAuth srv _} = host srv
agentServerCfgs :: [(Text, ServerOperator)] -> NonEmpty (NewUserServer p) -> [UserServer' s p] -> NonEmpty (ServerCfg p)
agentServerCfgs opDomains randomSrvs =
fromMaybe fallbackSrvs . L.nonEmpty . mapMaybe enabledOpAgentServer
where
fallbackSrvs = L.map (snd . agentServer) randomSrvs
enabledOpAgentServer srv =
let (opEnabled, srvCfg) = agentServer srv
in if opEnabled then Just srvCfg else Nothing
agentServer :: UserServer' s p -> (Bool, ServerCfg p)
agentServer srv@UserServer {server, enabled} =
case find (\(d, _) -> any (matchingHost d) (srvHost srv)) opDomains of
Just (_, ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled, roles}) ->
(opEnabled, ServerCfg {server, enabled, operator = Just opId, roles})
Nothing ->
(True, ServerCfg {server, enabled, operator = Nothing, roles = allRoles})
matchingHost :: Text -> TransportHost -> Bool
matchingHost d = \case
THDomainName h -> d `T.isSuffixOf` T.pack h
_ -> False
operatorDomains :: [ServerOperator] -> [(Text, ServerOperator)]
operatorDomains = foldr (\op ds -> foldr (\d -> ((d, op) :)) ds (serverDomains op)) []
groupByOperator :: ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> IO [UserOperatorServers]
groupByOperator (ops, smpSrvs, xftpSrvs) = do
ss <- mapM (\op -> (serverDomains op,) <$> newIORef (UserOperatorServers (Just op) [] [])) ops
custom <- newIORef $ UserOperatorServers Nothing [] []
mapM_ (addServer ss custom addSMP) (reverse smpSrvs)
mapM_ (addServer ss custom addXFTP) (reverse xftpSrvs)
opSrvs <- mapM (readIORef . snd) ss
customSrvs <- readIORef custom
pure $ opSrvs <> [customSrvs]
where
addServer :: [([Text], IORef UserOperatorServers)] -> IORef UserOperatorServers -> (UserServer p -> UserOperatorServers -> UserOperatorServers) -> UserServer p -> IO ()
addServer ss custom add srv =
let v = maybe custom snd $ find (\(ds, _) -> any (\d -> any (matchingHost d) (srvHost srv)) ds) ss
in atomicModifyIORef'_ v $ add srv
addSMP srv s@UserOperatorServers {smpServers} = (s :: UserOperatorServers) {smpServers = srv : smpServers}
addXFTP srv s@UserOperatorServers {xftpServers} = (s :: UserOperatorServers) {xftpServers = srv : xftpServers}
data UserServersError
= USEStorageMissing {protocol :: AProtocolType}
| USEProxyMissing {protocol :: AProtocolType}
| USEDuplicateServer {protocol :: AProtocolType, duplicateServer :: AProtoServerWithAuth, duplicateHost :: TransportHost}
deriving (Show)
validateUserServers :: NonEmpty UpdatedUserOperatorServers -> [UserServersError]
validateUserServers uss =
missingRolesErr SPSMP storage USEStorageMissing
<> missingRolesErr SPSMP proxy USEProxyMissing
<> missingRolesErr SPXFTP storage USEStorageMissing
<> duplicatServerErrs SPSMP
<> duplicatServerErrs SPXFTP
where
missingRolesErr :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> (ServerRoles -> Bool) -> (AProtocolType -> UserServersError) -> [UserServersError]
missingRolesErr p roleSel err = [err (AProtocolType p) | not hasRole]
where
hasRole =
any (\(AUS _ UserServer {deleted, enabled}) -> enabled && not deleted) $
concatMap (`updatedServers` p) $ filter roleEnabled (L.toList uss)
roleEnabled UpdatedUserOperatorServers {operator} =
maybe True (\ServerOperator {enabled, roles} -> enabled && roleSel roles) operator
duplicatServerErrs :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [UserServersError]
duplicatServerErrs p = mapMaybe duplicateErr_ srvs
where
srvs =
filter (\(AUS _ UserServer {deleted}) -> not deleted) $
concatMap (`updatedServers` p) (L.toList uss)
duplicateErr_ (AUS _ srv@UserServer {server}) =
USEDuplicateServer (AProtocolType p) (AProtoServerWithAuth p server)
<$> find (`S.member` duplicateHosts) (srvHost srv)
duplicateHosts = snd $ foldl' addHost (S.empty, S.empty) allHosts
allHosts = concatMap (\(AUS _ srv) -> L.toList $ srvHost srv) srvs
addHost (hs, dups) h
| h `S.member` hs = (hs, S.insert h dups)
| otherwise = (S.insert h hs, dups)
instance ToJSON (DBEntityId' s) where
toEncoding = \case
DBEntityId i -> toEncoding i
DBNewEntity -> JE.null_
toJSON = \case
DBEntityId i -> toJSON i
DBNewEntity -> J.Null
instance DBStoredI s => FromJSON (DBEntityId' s) where
parseJSON v = case (v, sdbStored @s) of
(J.Null, SDBNew) -> pure DBNewEntity
(J.Number n, SDBStored) -> case floatingOrInteger n of
Left (_ :: Double) -> fail "bad DBEntityId"
Right i -> pure $ DBEntityId (fromInteger i)
_ -> fail "bad DBEntityId"
omittedField = case sdbStored @s of
SDBStored -> Nothing
SDBNew -> Just DBNewEntity
$(JQ.deriveJSON defaultJSON ''UsageConditions)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance)
instance ToJSON (ServerOperator' s) where
toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerOperator')
toJSON = $(JQ.mkToJSON defaultJSON ''ServerOperator')
instance DBStoredI s => FromJSON (ServerOperator' s) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerOperator')
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)
instance ProtocolTypeI p => ToJSON (UserServer' s p) where
toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer')
toJSON = $(JQ.mkToJSON defaultJSON ''UserServer')
instance (DBStoredI s, ProtocolTypeI p) => FromJSON (UserServer' s p) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer')
instance ProtocolTypeI p => FromJSON (AUserServer p) where
parseJSON v = (AUS SDBStored <$> parseJSON v) <|> (AUS SDBNew <$> parseJSON v)
$(JQ.deriveJSON defaultJSON ''UserOperatorServers)
instance FromJSON UpdatedUserOperatorServers where
parseJSON = $(JQ.mkParseJSON defaultJSON ''UpdatedUserOperatorServers)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USE") ''UserServersError)
+19
View File
@@ -0,0 +1,19 @@
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Operators.Conditions where
import Data.Char (isSpace)
import Data.Text (Text)
import qualified Data.Text as T
stripFrontMatter :: Text -> Text
stripFrontMatter =
T.unlines
-- . dropWhile ("# " `T.isPrefixOf`) -- strip title
. dropWhile (T.all isSpace)
. dropWhile fm
. (\ls -> let ls' = dropWhile (not . fm) ls in if null ls' then ls else ls')
. dropWhile fm
. T.lines
where
fm = ("---" `T.isPrefixOf`)
+1 -2
View File
@@ -7,7 +7,6 @@ module Simplex.Chat.Stats where
import qualified Data.Aeson.TH as J
import Data.List (partition)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust)
@@ -131,7 +130,7 @@ data NtfServerSummary = NtfServerSummary
-- - users are passed to exclude hidden users from totalServersSummary;
-- - if currentUser is hidden, it should be accounted in totalServersSummary;
-- - known is set only in user level summaries based on passed userSMPSrvs and userXFTPSrvs
toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> NonEmpty SMPServer -> NonEmpty XFTPServer -> [NtfServer] -> PresentedServersSummary
toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> [SMPServer] -> [XFTPServer] -> [NtfServer] -> PresentedServersSummary
toPresentedServersSummary agentSummary users currentUser userSMPSrvs userXFTPSrvs userNtfSrvs = do
let (userSMPSrvsSumms, allSMPSrvsSumms) = accSMPSrvsSummaries
(userSMPCurr, userSMPPrev, userSMPProx) = smpSummsIntoCategories userSMPSrvsSumms
+504 -178
View File
@@ -3,6 +3,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
@@ -947,37 +948,41 @@ getContactConnectionChatPreviews_ db User {userId} pagination clq = case clq of
aChat = AChat SCTContactConnection $ Chat (ContactConnection conn) [] stats
in ACPD SCTContactConnection $ ContactConnectionPD updatedAt aChat
getDirectChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect)
getDirectChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect, Maybe NavigationInfo)
getDirectChat db vr user contactId pagination search_ = do
let search = fromMaybe "" search_
ct <- getContact db vr user contactId
liftIO $ case pagination of
CPLast count -> getDirectChatLast_ db user ct count search
CPAfter afterId count -> getDirectChatAfter_ db user ct afterId count search
CPBefore beforeId count -> getDirectChatBefore_ db user ct beforeId count search
case pagination of
CPLast count -> liftIO $ (,Nothing) <$> getDirectChatLast_ db user ct count search
CPAfter afterId count -> (,Nothing) <$> getDirectChatAfter_ db user ct afterId count search
CPBefore beforeId count -> (,Nothing) <$> getDirectChatBefore_ db user ct beforeId count search
CPAround aroundId count -> getDirectChatAround_ db user ct aroundId count search
CPInitial count -> do
unless (null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
getDirectChatInitial_ db user ct count
-- the last items in reverse order (the last item in the conversation is the first in the returned list)
getDirectChatLast_ :: DB.Connection -> User -> Contact -> Int -> String -> IO (Chat 'CTDirect)
getDirectChatLast_ db user@User {userId} ct@Contact {contactId} count search = do
getDirectChatLast_ db user ct count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getDirectChatItemIdsLast_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetDirectItem db user ct currentTs) chatItemIds
pure $ Chat (DirectChat ct) (reverse chatItems) stats
where
getDirectChatItemIdsLast_ :: IO [ChatItemId]
getDirectChatItemIdsLast_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, contactId, search, count)
ciIds <- getDirectChatItemIdsLast_ db user ct count search
ts <- getCurrentTime
cis <- mapM (safeGetDirectItem db user ct ts) ciIds
pure $ Chat (DirectChat ct) (reverse cis) stats
getDirectChatItemIdsLast_ :: DB.Connection -> User -> Contact -> Int -> String -> IO [ChatItemId]
getDirectChatItemIdsLast_ db User {userId} Contact {contactId} count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, contactId, search, count)
safeGetDirectItem :: DB.Connection -> User -> Contact -> UTCTime -> ChatItemId -> IO (CChatItem 'CTDirect)
safeGetDirectItem db user ct currentTs itemId =
@@ -1021,82 +1026,181 @@ getDirectChatItemLast db user@User {userId} contactId = do
(userId, contactId)
getDirectChatItem db user contactId chatItemId
getDirectChatAfter_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> IO (Chat 'CTDirect)
getDirectChatAfter_ db user@User {userId} ct@Contact {contactId} afterChatItemId count search = do
getDirectChatAfter_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect)
getDirectChatAfter_ db user ct@Contact {contactId} afterId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getDirectChatItemIdsAfter_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetDirectItem db user ct currentTs) chatItemIds
pure $ Chat (DirectChat ct) chatItems stats
afterCI <- getDirectChatItem db user contactId afterId
ciIds <- liftIO $ getDirectCIsAfter_ db user ct afterCI count search
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM (safeGetDirectItem db user ct ts) ciIds
pure $ Chat (DirectChat ct) cis stats
getDirectCIsAfter_ :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> Int -> String -> IO [ChatItemId]
getDirectCIsAfter_ db User {userId} Contact {contactId} afterCI count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
AND (created_at > ? OR (created_at = ? AND chat_item_id > ?))
ORDER BY created_at ASC, chat_item_id ASC
LIMIT ?
|]
(userId, contactId, search, ciCreatedAt afterCI, ciCreatedAt afterCI, cChatItemId afterCI, count)
getDirectChatBefore_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect)
getDirectChatBefore_ db user ct@Contact {contactId} beforeId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
beforeCI <- getDirectChatItem db user contactId beforeId
ciIds <- liftIO $ getDirectCIsBefore_ db user ct beforeCI count search
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM (safeGetDirectItem db user ct ts) ciIds
pure $ Chat (DirectChat ct) (reverse cis) stats
getDirectCIsBefore_ :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> Int -> String -> IO [ChatItemId]
getDirectCIsBefore_ db User {userId} Contact {contactId} beforeCI count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
AND (created_at < ? OR (created_at = ? AND chat_item_id < ?))
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, contactId, search, ciCreatedAt beforeCI, ciCreatedAt beforeCI, cChatItemId beforeCI, count)
getDirectChatAround_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect, Maybe NavigationInfo)
getDirectChatAround_ db user ct aroundId count search = do
stats <- liftIO $ getContactStats_ db user ct
getDirectChatAround' db user ct aroundId count search stats
getDirectChatAround' :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ChatStats -> ExceptT StoreError IO (Chat 'CTDirect, Maybe NavigationInfo)
getDirectChatAround' db user ct@Contact {contactId} aroundId count search stats = do
aroundCI <- getDirectChatItem db user contactId aroundId
beforeIds <- liftIO $ getDirectCIsBefore_ db user ct aroundCI count search
afterIds <- liftIO $ getDirectCIsAfter_ db user ct aroundCI count search
ts <- liftIO getCurrentTime
beforeCIs <- liftIO $ mapM (safeGetDirectItem db user ct ts) beforeIds
afterCIs <- liftIO $ mapM (safeGetDirectItem db user ct ts) afterIds
let cis = reverse beforeCIs <> [aroundCI] <> afterCIs
navInfo <- liftIO $ getNavInfo cis
pure (Chat (DirectChat ct) cis stats, Just navInfo)
where
getDirectChatItemIdsAfter_ :: IO [ChatItemId]
getDirectChatItemIdsAfter_ =
map fromOnly
getNavInfo cis_ = case cis_ of
[] -> pure $ NavigationInfo 0 0
cis -> getContactNavInfo_ db user ct (last cis)
getDirectChatInitial_ :: DB.Connection -> User -> Contact -> Int -> ExceptT StoreError IO (Chat 'CTDirect, Maybe NavigationInfo)
getDirectChatInitial_ db user ct count = do
liftIO (getContactMinUnreadId_ db user ct) >>= \case
Just minUnreadItemId -> do
unreadCount <- liftIO $ getContactUnreadCount_ db user ct
let stats = ChatStats {unreadCount, minUnreadItemId, unreadChat = False}
getDirectChatAround' db user ct minUnreadItemId count "" stats
Nothing -> liftIO $ (,Just $ NavigationInfo 0 0) <$> getDirectChatLast_ db user ct count ""
getContactStats_ :: DB.Connection -> User -> Contact -> IO ChatStats
getContactStats_ db user ct = do
minUnreadItemId <- fromMaybe 0 <$> getContactMinUnreadId_ db user ct
unreadCount <- getContactUnreadCount_ db user ct
pure ChatStats {unreadCount, minUnreadItemId, unreadChat = False}
getContactMinUnreadId_ :: DB.Connection -> User -> Contact -> IO (Maybe ChatItemId)
getContactMinUnreadId_ db User {userId} Contact {contactId} =
fmap join . maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_status = ?
ORDER BY created_at ASC, chat_item_id ASC
LIMIT 1
|]
(userId, contactId, CISRcvNew)
getContactUnreadCount_ :: DB.Connection -> User -> Contact -> IO Int
getContactUnreadCount_ db User {userId} Contact {contactId} =
fromOnly . head
<$> DB.query
db
[sql|
SELECT COUNT(1)
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_status = ?
|]
(userId, contactId, CISRcvNew)
getContactNavInfo_ :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO NavigationInfo
getContactNavInfo_ db User {userId} Contact {contactId} afterCI = do
afterUnread <- getAfterUnreadCount
afterTotal <- getAfterTotalCount
pure NavigationInfo {afterUnread, afterTotal}
where
getAfterUnreadCount :: IO Int
getAfterUnreadCount =
fromOnly . head
<$> DB.query
db
[sql|
SELECT chat_item_id
SELECT COUNT(1)
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
AND chat_item_id > ?
ORDER BY created_at ASC, chat_item_id ASC
LIMIT ?
WHERE user_id = ? AND contact_id = ? AND item_status = ?
AND (created_at > ? OR (created_at = ? AND chat_item_id > ?))
|]
(userId, contactId, search, afterChatItemId, count)
getDirectChatBefore_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> IO (Chat 'CTDirect)
getDirectChatBefore_ db user@User {userId} ct@Contact {contactId} beforeChatItemId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getDirectChatItemsIdsBefore_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetDirectItem db user ct currentTs) chatItemIds
pure $ Chat (DirectChat ct) (reverse chatItems) stats
where
getDirectChatItemsIdsBefore_ :: IO [ChatItemId]
getDirectChatItemsIdsBefore_ =
map fromOnly
(userId, contactId, CISRcvNew, ciCreatedAt afterCI, ciCreatedAt afterCI, cChatItemId afterCI)
getAfterTotalCount :: IO Int
getAfterTotalCount =
fromOnly . head
<$> DB.query
db
[sql|
SELECT chat_item_id
SELECT COUNT(1)
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
AND chat_item_id < ?
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
WHERE user_id = ? AND contact_id = ?
AND (created_at > ? OR (created_at = ? AND chat_item_id > ?))
|]
(userId, contactId, search, beforeChatItemId, count)
(userId, contactId, ciCreatedAt afterCI, ciCreatedAt afterCI, cChatItemId afterCI)
getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
getGroupChat db vr user groupId pagination search_ = do
let search = fromMaybe "" search_
g <- getGroupInfo db vr user groupId
case pagination of
CPLast count -> liftIO $ getGroupChatLast_ db user g count search
CPAfter afterId count -> getGroupChatAfter_ db user g afterId count search
CPBefore beforeId count -> getGroupChatBefore_ db user g beforeId count search
CPLast count -> liftIO $ (,Nothing) <$> getGroupChatLast_ db user g count search
CPAfter afterId count -> (,Nothing) <$> getGroupChatAfter_ db user g afterId count search
CPBefore beforeId count -> (,Nothing) <$> getGroupChatBefore_ db user g beforeId count search
CPAround aroundId count -> getGroupChatAround_ db user g aroundId count search
CPInitial count -> do
unless (null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
getGroupChatInitial_ db user g count
getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Int -> String -> IO (Chat 'CTGroup)
getGroupChatLast_ db user@User {userId} g@GroupInfo {groupId} count search = do
getGroupChatLast_ db user g count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getGroupChatItemIdsLast_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetGroupItem db user g currentTs) chatItemIds
pure $ Chat (GroupChat g) (reverse chatItems) stats
where
getGroupChatItemIdsLast_ :: IO [ChatItemId]
getGroupChatItemIdsLast_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
|]
(userId, groupId, search, count)
ciIds <- getGroupChatItemIdsLast_ db user g count search
ts <- getCurrentTime
cis <- mapM (safeGetGroupItem db user g ts) ciIds
pure $ Chat (GroupChat g) (reverse cis) stats
getGroupChatItemIdsLast_ :: DB.Connection -> User -> GroupInfo -> Int -> String -> IO [ChatItemId]
getGroupChatItemIdsLast_ db User {userId} GroupInfo {groupId} count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
|]
(userId, groupId, search, count)
safeGetGroupItem :: DB.Connection -> User -> GroupInfo -> UTCTime -> ChatItemId -> IO (CChatItem 'CTGroup)
safeGetGroupItem db user g currentTs itemId =
@@ -1141,83 +1245,180 @@ getGroupMemberChatItemLast db user@User {userId} groupId groupMemberId = do
getGroupChatItem db user groupId chatItemId
getGroupChatAfter_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChatAfter_ db user@User {userId} g@GroupInfo {groupId} afterChatItemId count search = do
getGroupChatAfter_ db user g@GroupInfo {groupId} afterId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
afterChatItem <- getGroupChatItem db user groupId afterChatItemId
chatItemIds <- liftIO $ getGroupChatItemIdsAfter_ (chatItemTs afterChatItem)
currentTs <- liftIO getCurrentTime
chatItems <- liftIO $ mapM (safeGetGroupItem db user g currentTs) chatItemIds
pure $ Chat (GroupChat g) chatItems stats
where
getGroupChatItemIdsAfter_ :: UTCTime -> IO [ChatItemId]
getGroupChatItemIdsAfter_ afterChatItemTs =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?))
ORDER BY item_ts ASC, chat_item_id ASC
LIMIT ?
|]
(userId, groupId, search, afterChatItemTs, afterChatItemTs, afterChatItemId, count)
afterCI <- getGroupChatItem db user groupId afterId
ciIds <- liftIO $ getGroupCIsAfter_ db user g afterCI count search
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM (safeGetGroupItem db user g ts) ciIds
pure $ Chat (GroupChat g) cis stats
getGroupCIsAfter_ :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> Int -> String -> IO [ChatItemId]
getGroupCIsAfter_ db User {userId} GroupInfo {groupId} afterCI count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?))
ORDER BY item_ts ASC, chat_item_id ASC
LIMIT ?
|]
(userId, groupId, search, chatItemTs afterCI, chatItemTs afterCI, cChatItemId afterCI, count)
getGroupChatBefore_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChatBefore_ db user@User {userId} g@GroupInfo {groupId} beforeChatItemId count search = do
getGroupChatBefore_ db user g@GroupInfo {groupId} beforeId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
beforeChatItem <- getGroupChatItem db user groupId beforeChatItemId
chatItemIds <- liftIO $ getGroupChatItemIdsBefore_ (chatItemTs beforeChatItem)
currentTs <- liftIO getCurrentTime
chatItems <- liftIO $ mapM (safeGetGroupItem db user g currentTs) chatItemIds
pure $ Chat (GroupChat g) (reverse chatItems) stats
beforeCI <- getGroupChatItem db user groupId beforeId
ciIds <- liftIO $ getGroupCIsBefore_ db user g beforeCI count search
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM (safeGetGroupItem db user g ts) ciIds
pure $ Chat (GroupChat g) (reverse cis) stats
getGroupCIsBefore_ :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> Int -> String -> IO [ChatItemId]
getGroupCIsBefore_ db User {userId} GroupInfo {groupId} beforeCI count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?))
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
|]
(userId, groupId, search, chatItemTs beforeCI, chatItemTs beforeCI, cChatItemId beforeCI, count)
getGroupChatAround_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
getGroupChatAround_ db user g aroundId count search = do
stats <- liftIO $ getGroupStats_ db user g
getGroupChatAround' db user g aroundId count search stats
getGroupChatAround' :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ChatStats -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
getGroupChatAround' db user g@GroupInfo {groupId} aroundId count search stats = do
aroundCI <- getGroupChatItem db user groupId aroundId
beforeIds <- liftIO $ getGroupCIsBefore_ db user g aroundCI count search
afterIds <- liftIO $ getGroupCIsAfter_ db user g aroundCI count search
ts <- liftIO getCurrentTime
beforeCIs <- liftIO $ mapM (safeGetGroupItem db user g ts) beforeIds
afterCIs <- liftIO $ mapM (safeGetGroupItem db user g ts) afterIds
let cis = reverse beforeCIs <> [aroundCI] <> afterCIs
navInfo <- liftIO $ getNavInfo cis
pure (Chat (GroupChat g) cis stats, Just navInfo)
where
getGroupChatItemIdsBefore_ :: UTCTime -> IO [ChatItemId]
getGroupChatItemIdsBefore_ beforeChatItemTs =
map fromOnly
getNavInfo cis_ = case cis_ of
[] -> pure $ NavigationInfo 0 0
cis -> getGroupNavInfo_ db user g (last cis)
getGroupChatInitial_ :: DB.Connection -> User -> GroupInfo -> Int -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
getGroupChatInitial_ db user g count =
liftIO (getGroupMinUnreadId_ db user g) >>= \case
Just minUnreadItemId -> do
unreadCount <- liftIO $ getGroupUnreadCount_ db user g
let stats = ChatStats {unreadCount, minUnreadItemId, unreadChat = False}
getGroupChatAround' db user g minUnreadItemId count "" stats
Nothing -> liftIO $ (,Just $ NavigationInfo 0 0) <$> getGroupChatLast_ db user g count ""
getGroupStats_ :: DB.Connection -> User -> GroupInfo -> IO ChatStats
getGroupStats_ db user g = do
minUnreadItemId <- fromMaybe 0 <$> getGroupMinUnreadId_ db user g
unreadCount <- getGroupUnreadCount_ db user g
pure ChatStats {unreadCount, minUnreadItemId, unreadChat = False}
getGroupMinUnreadId_ :: DB.Connection -> User -> GroupInfo -> IO (Maybe ChatItemId)
getGroupMinUnreadId_ db User {userId} GroupInfo {groupId} =
fmap join . maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_status = ?
ORDER BY item_ts ASC, chat_item_id ASC
LIMIT 1
|]
(userId, groupId, CISRcvNew)
getGroupUnreadCount_ :: DB.Connection -> User -> GroupInfo -> IO Int
getGroupUnreadCount_ db User {userId} GroupInfo {groupId} =
fromOnly . head
<$> DB.query
db
[sql|
SELECT COUNT(1)
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_status = ?
|]
(userId, groupId, CISRcvNew)
getGroupNavInfo_ :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO NavigationInfo
getGroupNavInfo_ db User {userId} GroupInfo {groupId} afterCI = do
afterUnread <- getAfterUnreadCount
afterTotal <- getAfterTotalCount
pure NavigationInfo {afterUnread, afterTotal}
where
getAfterUnreadCount :: IO Int
getAfterUnreadCount =
fromOnly . head
<$> DB.query
db
[sql|
SELECT chat_item_id
SELECT COUNT(1)
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?))
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
WHERE user_id = ? AND group_id = ? AND item_status = ?
AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?))
|]
(userId, groupId, search, beforeChatItemTs, beforeChatItemTs, beforeChatItemId, count)
(userId, groupId, CISRcvNew, chatItemTs afterCI, chatItemTs afterCI, cChatItemId afterCI)
getAfterTotalCount :: IO Int
getAfterTotalCount =
fromOnly . head
<$> DB.query
db
[sql|
SELECT COUNT(1)
FROM chat_items
WHERE user_id = ? AND group_id = ?
AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?))
|]
(userId, groupId, chatItemTs afterCI, chatItemTs afterCI, cChatItemId afterCI)
getLocalChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTLocal)
getLocalChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTLocal, Maybe NavigationInfo)
getLocalChat db user folderId pagination search_ = do
let search = fromMaybe "" search_
nf <- getNoteFolder db user folderId
liftIO $ case pagination of
CPLast count -> getLocalChatLast_ db user nf count search
CPAfter afterId count -> getLocalChatAfter_ db user nf afterId count search
CPBefore beforeId count -> getLocalChatBefore_ db user nf beforeId count search
case pagination of
CPLast count -> liftIO $ (,Nothing) <$> getLocalChatLast_ db user nf count search
CPAfter afterId count -> (,Nothing) <$> getLocalChatAfter_ db user nf afterId count search
CPBefore beforeId count -> (,Nothing) <$> getLocalChatBefore_ db user nf beforeId count search
CPAround aroundId count -> getLocalChatAround_ db user nf aroundId count search
CPInitial count -> do
unless (null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
getLocalChatInitial_ db user nf count
getLocalChatLast_ :: DB.Connection -> User -> NoteFolder -> Int -> String -> IO (Chat 'CTLocal)
getLocalChatLast_ db user@User {userId} nf@NoteFolder {noteFolderId} count search = do
getLocalChatLast_ db user nf count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getLocalChatItemIdsLast_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetLocalItem db user nf currentTs) chatItemIds
pure $ Chat (LocalChat nf) (reverse chatItems) stats
where
getLocalChatItemIdsLast_ :: IO [ChatItemId]
getLocalChatItemIdsLast_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, noteFolderId, search, count)
ciIds <- getLocalChatItemIdsLast_ db user nf count search
ts <- getCurrentTime
cis <- mapM (safeGetLocalItem db user nf ts) ciIds
pure $ Chat (LocalChat nf) (reverse cis) stats
getLocalChatItemIdsLast_ :: DB.Connection -> User -> NoteFolder -> Int -> String -> IO [ChatItemId]
getLocalChatItemIdsLast_ db User {userId} NoteFolder {noteFolderId} count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, noteFolderId, search, count)
safeGetLocalItem :: DB.Connection -> User -> NoteFolder -> UTCTime -> ChatItemId -> IO (CChatItem 'CTLocal)
safeGetLocalItem db user NoteFolder {noteFolderId} currentTs itemId =
@@ -1245,51 +1446,146 @@ safeToLocalItem currentTs itemId = \case
file = Nothing
}
getLocalChatAfter_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> IO (Chat 'CTLocal)
getLocalChatAfter_ db user@User {userId} nf@NoteFolder {noteFolderId} afterChatItemId count search = do
getLocalChatAfter_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTLocal)
getLocalChatAfter_ db user nf@NoteFolder {noteFolderId} afterId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getLocalChatItemIdsAfter_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetLocalItem db user nf currentTs) chatItemIds
pure $ Chat (LocalChat nf) chatItems stats
where
getLocalChatItemIdsAfter_ :: IO [ChatItemId]
getLocalChatItemIdsAfter_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
AND chat_item_id > ?
ORDER BY created_at ASC, chat_item_id ASC
LIMIT ?
|]
(userId, noteFolderId, search, afterChatItemId, count)
afterCI <- getLocalChatItem db user noteFolderId afterId
ciIds <- liftIO $ getLocalCIsAfter_ db user nf afterCI count search
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM (safeGetLocalItem db user nf ts) ciIds
pure $ Chat (LocalChat nf) cis stats
getLocalChatBefore_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> IO (Chat 'CTLocal)
getLocalChatBefore_ db user@User {userId} nf@NoteFolder {noteFolderId} beforeChatItemId count search = do
getLocalCIsAfter_ :: DB.Connection -> User -> NoteFolder -> CChatItem 'CTLocal -> Int -> String -> IO [ChatItemId]
getLocalCIsAfter_ db User {userId} NoteFolder {noteFolderId} afterCI count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
AND (created_at > ? OR (created_at = ? AND chat_item_id > ?))
ORDER BY created_at ASC, chat_item_id ASC
LIMIT ?
|]
(userId, noteFolderId, search, ciCreatedAt afterCI, ciCreatedAt afterCI, cChatItemId afterCI, count)
getLocalChatBefore_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTLocal)
getLocalChatBefore_ db user nf@NoteFolder {noteFolderId} beforeId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getLocalChatItemIdsBefore_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetLocalItem db user nf currentTs) chatItemIds
pure $ Chat (LocalChat nf) (reverse chatItems) stats
beforeCI <- getLocalChatItem db user noteFolderId beforeId
ciIds <- liftIO $ getLocalCIsBefore_ db user nf beforeCI count search
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM (safeGetLocalItem db user nf ts) ciIds
pure $ Chat (LocalChat nf) (reverse cis) stats
getLocalCIsBefore_ :: DB.Connection -> User -> NoteFolder -> CChatItem 'CTLocal -> Int -> String -> IO [ChatItemId]
getLocalCIsBefore_ db User {userId} NoteFolder {noteFolderId} beforeCI count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
AND (created_at < ? OR (created_at = ? AND chat_item_id < ?))
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, noteFolderId, search, ciCreatedAt beforeCI, ciCreatedAt beforeCI, cChatItemId beforeCI, count)
getLocalChatAround_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTLocal, Maybe NavigationInfo)
getLocalChatAround_ db user nf aroundId count search = do
stats <- liftIO $ getLocalStats_ db user nf
getLocalChatAround' db user nf aroundId count search stats
getLocalChatAround' :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ChatStats -> ExceptT StoreError IO (Chat 'CTLocal, Maybe NavigationInfo)
getLocalChatAround' db user nf@NoteFolder {noteFolderId} aroundId count search stats = do
aroundCI <- getLocalChatItem db user noteFolderId aroundId
beforeIds <- liftIO $ getLocalCIsBefore_ db user nf aroundCI count search
afterIds <- liftIO $ getLocalCIsAfter_ db user nf aroundCI count search
ts <- liftIO getCurrentTime
beforeCIs <- liftIO $ mapM (safeGetLocalItem db user nf ts) beforeIds
afterCIs <- liftIO $ mapM (safeGetLocalItem db user nf ts) afterIds
let cis = reverse beforeCIs <> [aroundCI] <> afterCIs
navInfo <- liftIO $ getNavInfo cis
pure (Chat (LocalChat nf) cis stats, Just navInfo)
where
getLocalChatItemIdsBefore_ :: IO [ChatItemId]
getLocalChatItemIdsBefore_ =
map fromOnly
getNavInfo cis_ = case cis_ of
[] -> pure $ NavigationInfo 0 0
cis -> getLocalNavInfo_ db user nf (last cis)
getLocalChatInitial_ :: DB.Connection -> User -> NoteFolder -> Int -> ExceptT StoreError IO (Chat 'CTLocal, Maybe NavigationInfo)
getLocalChatInitial_ db user nf count = do
liftIO (getLocalMinUnreadId_ db user nf) >>= \case
Just minUnreadItemId -> do
unreadCount <- liftIO $ getLocalUnreadCount_ db user nf
let stats = ChatStats {unreadCount, minUnreadItemId, unreadChat = False}
getLocalChatAround' db user nf minUnreadItemId count "" stats
Nothing -> liftIO $ (,Just $ NavigationInfo 0 0) <$> getLocalChatLast_ db user nf count ""
getLocalStats_ :: DB.Connection -> User -> NoteFolder -> IO ChatStats
getLocalStats_ db user nf = do
minUnreadItemId <- fromMaybe 0 <$> getLocalMinUnreadId_ db user nf
unreadCount <- getLocalUnreadCount_ db user nf
pure ChatStats {unreadCount, minUnreadItemId, unreadChat = False}
getLocalMinUnreadId_ :: DB.Connection -> User -> NoteFolder -> IO (Maybe ChatItemId)
getLocalMinUnreadId_ db User {userId} NoteFolder {noteFolderId} =
fmap join . maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_status = ?
ORDER BY created_at ASC, chat_item_id ASC
LIMIT 1
|]
(userId, noteFolderId, CISRcvNew)
getLocalUnreadCount_ :: DB.Connection -> User -> NoteFolder -> IO Int
getLocalUnreadCount_ db User {userId} NoteFolder {noteFolderId} =
fromOnly . head
<$> DB.query
db
[sql|
SELECT COUNT(1)
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_status = ?
|]
(userId, noteFolderId, CISRcvNew)
getLocalNavInfo_ :: DB.Connection -> User -> NoteFolder -> CChatItem 'CTLocal -> IO NavigationInfo
getLocalNavInfo_ db User {userId} NoteFolder {noteFolderId} afterCI = do
afterUnread <- getAfterUnreadCount
afterTotal <- getAfterTotalCount
pure NavigationInfo {afterUnread, afterTotal}
where
getAfterUnreadCount :: IO Int
getAfterUnreadCount =
fromOnly . head
<$> DB.query
db
[sql|
SELECT chat_item_id
SELECT COUNT(1)
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
AND chat_item_id < ?
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
WHERE user_id = ? AND note_folder_id = ? AND item_status = ?
AND (created_at > ? OR (created_at = ? AND chat_item_id > ?))
|]
(userId, noteFolderId, search, beforeChatItemId, count)
(userId, noteFolderId, CISRcvNew, ciCreatedAt afterCI, ciCreatedAt afterCI, cChatItemId afterCI)
getAfterTotalCount :: IO Int
getAfterTotalCount =
fromOnly . head
<$> DB.query
db
[sql|
SELECT COUNT(1)
FROM chat_items
WHERE user_id = ? AND note_folder_id = ?
AND (created_at > ? OR (created_at = ? AND chat_item_id > ?))
|]
(userId, noteFolderId, ciCreatedAt afterCI, ciCreatedAt afterCI, cChatItemId afterCI)
toChatItemRef :: (ChatItemId, Maybe Int64, Maybe Int64, Maybe Int64) -> Either StoreError (ChatRef, ChatItemId)
toChatItemRef = \case
@@ -1581,6 +1877,12 @@ getAllChatItems db vr user@User {userId} pagination search_ = do
CPLast count -> liftIO $ getAllChatItemsLast_ count
CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId
CPBefore beforeId count -> liftIO . getAllChatItemsBefore_ beforeId count . aChatItemTs =<< getAChatItem_ beforeId
CPAround aroundId count -> liftIO . getAllChatItemsAround_ aroundId count . aChatItemTs =<< getAChatItem_ aroundId
CPInitial count -> do
unless (null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
liftIO getFirstUnreadItemId_ >>= \case
Just itemId -> liftIO . getAllChatItemsAround_ itemId count . aChatItemTs =<< getAChatItem_ itemId
Nothing -> liftIO $ getAllChatItemsLast_ count
mapM (uncurry (getAChatItem db vr user)) itemRefs
where
search = fromMaybe "" search_
@@ -1624,6 +1926,30 @@ getAllChatItems db vr user@User {userId} pagination search_ = do
LIMIT ?
|]
(userId, search, beforeTs, beforeTs, beforeId, count)
getChatItem chatId =
DB.query
db
[sql|
SELECT chat_item_id, contact_id, group_id, note_folder_id
FROM chat_items
WHERE chat_item_id = ?
|]
(Only chatId)
getAllChatItemsAround_ aroundId count aroundTs = do
itemsBefore <- getAllChatItemsBefore_ aroundId count aroundTs
item <- getChatItem aroundId
itemsAfter <- getAllChatItemsAfter_ aroundId count aroundTs
pure $ itemsBefore <> item <> itemsAfter
getFirstUnreadItemId_ =
fmap join . maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT MIN(chat_item_id)
FROM chat_items
WHERE user_id = ? AND item_status = ?
|]
(userId, CISRcvNew)
getChatItemIdsByAgentMsgId :: DB.Connection -> Int64 -> AgentMsgId -> IO [ChatItemId]
getChatItemIdsByAgentMsgId db connId msgId =
@@ -2631,9 +2957,9 @@ getGroupSndStatusCounts db itemId =
getGroupHistoryItems :: DB.Connection -> User -> GroupInfo -> Int -> IO [Either StoreError (CChatItem 'CTGroup)]
getGroupHistoryItems db user@User {userId} GroupInfo {groupId} count = do
chatItemIds <- getLastItemIds_
ciIds <- getLastItemIds_
-- use getGroupCIWithReactions to read reactions data
reverse <$> mapM (runExceptT . getGroupChatItem db user groupId) chatItemIds
reverse <$> mapM (runExceptT . getGroupChatItem db user groupId) ciIds
where
getLastItemIds_ :: IO [ChatItemId]
getLastItemIds_ =
+5 -1
View File
@@ -114,6 +114,8 @@ import Simplex.Chat.Migrations.M20240827_calls_uuid
import Simplex.Chat.Migrations.M20240920_user_order
import Simplex.Chat.Migrations.M20241008_indexes
import Simplex.Chat.Migrations.M20241010_contact_requests_contact_id
import Simplex.Chat.Migrations.M20241023_chat_item_autoincrement_id
import Simplex.Chat.Migrations.M20241027_server_operators
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -227,7 +229,9 @@ schemaMigrations =
("20240827_calls_uuid", m20240827_calls_uuid, Just down_m20240827_calls_uuid),
("20240920_user_order", m20240920_user_order, Just down_m20240920_user_order),
("20241008_indexes", m20241008_indexes, Just down_m20241008_indexes),
("20241010_contact_requests_contact_id", m20241010_contact_requests_contact_id, Just down_m20241010_contact_requests_contact_id)
("20241010_contact_requests_contact_id", m20241010_contact_requests_contact_id, Just down_m20241010_contact_requests_contact_id),
("20241023_chat_item_autoincrement_id", m20241023_chat_item_autoincrement_id, Just down_m20241023_chat_item_autoincrement_id),
("20241027_server_operators", m20241027_server_operators, Just down_m20241027_server_operators)
]
-- | The list of migrations in ascending order by date
+309 -23
View File
@@ -1,5 +1,8 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
@@ -47,7 +50,19 @@ module Simplex.Chat.Store.Profiles
getContactWithoutConnViaAddress,
updateUserAddressAutoAccept,
getProtocolServers,
getUpdateUserServers,
-- overwriteOperatorsAndServers,
overwriteProtocolServers,
insertProtocolServer,
getUpdateServerOperators,
getServerOperators,
getUserServers,
setServerOperators,
getCurrentUsageConditions,
getLatestAcceptedConditions,
setConditionsNotified,
acceptConditions,
setUserServers,
createCall,
deleteCalls,
getCalls,
@@ -70,12 +85,14 @@ import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..))
import Database.SQLite.Simple (NamedParam (..), Only (..), Query, (:.) (..))
import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Call
import Simplex.Chat.Messages
import Simplex.Chat.Operators
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared
@@ -83,7 +100,7 @@ import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..))
import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
@@ -91,7 +108,7 @@ import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode, UserProtocol)
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
@@ -515,42 +532,311 @@ updateUserAddressAutoAccept db user@User {userId} autoAccept = do
Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply)
_ -> (False, False, Nothing)
getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p]
getProtocolServers db User {userId} =
map toServerCfg
getUpdateUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => DB.Connection -> SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> User -> IO [UserServer p]
getUpdateUserServers db p presetOps randomSrvs user = do
ts <- getCurrentTime
srvs <- getProtocolServers db p user
let srvs' = L.toList $ updatedUserServers p presetOps randomSrvs srvs
mapM (upsertServer ts) srvs'
where
upsertServer :: UTCTime -> AUserServer p -> IO (UserServer p)
upsertServer ts (AUS _ s@UserServer {serverId}) = case serverId of
DBNewEntity -> insertProtocolServer db p user ts s
DBEntityId _ -> updateProtocolServer db p ts s $> s
getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> IO [UserServer p]
getProtocolServers db p User {userId} =
map toUserServer
<$> DB.query
db
[sql|
SELECT host, port, key_hash, basic_auth, preset, tested, enabled
SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled
FROM protocol_servers
WHERE user_id = ? AND protocol = ?;
WHERE user_id = ? AND protocol = ?
|]
(userId, decodeLatin1 $ strEncode protocol)
(userId, decodeLatin1 $ strEncode p)
where
protocol = protocolTypeI @p
toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg p
toServerCfg (host, port, keyHash, auth_, preset, tested, enabled) =
let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
in ServerCfg {server, preset, tested, enabled}
toUserServer :: (DBEntityId, NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> UserServer p
toUserServer (serverId, host, port, keyHash, auth_, preset, tested, enabled) =
let server = ProtoServerWithAuth (ProtocolServer p host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
in UserServer {serverId, server, preset, tested, enabled, deleted = False}
overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
overwriteProtocolServers db User {userId} servers =
-- TODO remove
-- overwriteOperatorsAndServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> Maybe [ServerOperator] -> [ServerCfg p] -> ExceptT StoreError IO [ServerCfg p]
-- overwriteOperatorsAndServers db user@User {userId} operators_ servers = do
overwriteProtocolServers :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> [UserServer p] -> ExceptT StoreError IO ()
overwriteProtocolServers db p User {userId} servers =
-- liftIO $ mapM_ (updateServerOperators_ db) operators_
checkConstraint SEUniqueID . ExceptT $ do
currentTs <- getCurrentTime
DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, protocol)
forM_ servers $ \ServerCfg {server, preset, tested, enabled} -> do
let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server
DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, decodeLatin1 $ strEncode p)
forM_ servers $ \UserServer {serverId, server, preset, tested, enabled} -> do
DB.execute
db
[sql|
INSERT INTO protocol_servers
(protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?)
(server_id, protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|]
((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs))
(Only serverId :. serverColumns p server :. (preset, tested, enabled, userId, currentTs, currentTs))
pure $ Right ()
insertProtocolServer :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> UTCTime -> NewUserServer p -> IO (UserServer p)
insertProtocolServer db p User {userId} ts srv@UserServer {server, preset, tested, enabled} = do
DB.execute
db
[sql|
INSERT INTO protocol_servers
(protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?)
|]
(serverColumns p server :. (preset, tested, enabled, userId, ts, ts))
sId <- insertedRowId db
pure (srv :: NewUserServer p) {serverId = DBEntityId sId}
updateProtocolServer :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO ()
updateProtocolServer db p ts UserServer {serverId, server, preset, tested, enabled} =
DB.execute
db
[sql|
UPDATE protocol_servers
SET protocol = ?, host = ?, port = ?, key_hash = ?, basic_auth = ?,
preset = ?, tested = ?, enabled = ?, updated_at = ?
WHERE smp_server_id = ?
|]
(serverColumns p server :. (preset, tested, enabled, ts, serverId))
serverColumns :: ProtocolTypeI p => SProtocolType p -> ProtoServerWithAuth p -> (Text, NonEmpty TransportHost, String, C.KeyHash, Maybe Text)
serverColumns p (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_) =
let protocol = decodeLatin1 $ strEncode p
auth = safeDecodeUtf8 . unBasicAuth <$> auth_
in (protocol, host, port, keyHash, auth)
getServerOperators :: DB.Connection -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
getServerOperators db = do
currentConds <- getCurrentUsageConditions db
liftIO $ do
now <- getCurrentTime
latestAcceptedConds_ <- getLatestAcceptedConditions db
let getConds op = (\ca -> op {conditionsAcceptance = ca}) <$> getOperatorConditions_ db op currentConds latestAcceptedConds_ now
operators <- mapM getConds =<< getServerOperators_ db
pure (operators, usageConditionsAction operators currentConds now)
getUserServers :: DB.Connection -> User -> ExceptT StoreError IO ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
getUserServers db user =
(,,)
<$> (fst <$> getServerOperators db)
<*> liftIO (getProtocolServers db SPSMP user)
<*> liftIO (getProtocolServers db SPXFTP user)
setServerOperators :: DB.Connection -> NonEmpty ServerOperator -> IO ()
setServerOperators db ops = do
currentTs <- getCurrentTime
mapM_ (updateServerOperator db currentTs) ops
updateServerOperator :: DB.Connection -> UTCTime -> ServerOperator -> IO ()
updateServerOperator db currentTs ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} =
DB.execute
db
[sql|
UPDATE server_operators
SET enabled = ?, role_storage = ?, role_proxy = ?, updated_at = ?
WHERE server_operator_id = ?
|]
(enabled, storage, proxy, operatorId, currentTs)
getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [ServerOperator]
getUpdateServerOperators db presetOps newUser = do
conds <- map toUsageConditions <$> DB.query_ db usageCondsQuery
now <- getCurrentTime
let (acceptForSimplex_, currentConds, condsToAdd) = usageConditionsToAdd newUser now conds
mapM_ insertConditions condsToAdd
latestAcceptedConds_ <- getLatestAcceptedConditions db
ops <- updatedServerOperators presetOps <$> getServerOperators_ db
forM ops $ \(ASO _ op) ->
case operatorId op of
DBNewEntity -> do
op' <- insertOperator op
case (operatorTag op', acceptForSimplex_) of
(Just OTSimplex, Just cond) -> autoAcceptConditions op' cond
_ -> pure op'
DBEntityId _ -> do
updateOperator op
getOperatorConditions_ db op currentConds latestAcceptedConds_ now >>= \case
CARequired Nothing | operatorTag op == Just OTSimplex -> autoAcceptConditions op currentConds
CARequired (Just ts) | ts < now -> autoAcceptConditions op currentConds
ca -> pure op {conditionsAcceptance = ca}
where
protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
insertConditions UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt} =
DB.execute
db
[sql|
INSERT INTO usage_conditions
(usage_conditions_id, conditions_commit, notified_at, created_at)
VALUES (?,?,?,?)
|]
(conditionsId, conditionsCommit, notifiedAt, createdAt)
updateOperator :: ServerOperator -> IO ()
updateOperator ServerOperator {operatorId, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} =
DB.execute
db
[sql|
UPDATE server_operators
SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, role_storage = ?, role_proxy = ?
WHERE server_operator_id = ?
|]
(tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy, operatorId)
insertOperator :: NewServerOperator -> IO ServerOperator
insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} = do
DB.execute
db
[sql|
INSERT INTO server_operators
(server_operator_tag, trade_name, legal_name, server_domains, enabled, role_storage, role_proxy)
VALUES (?,?,?,?,?,?,?)
|]
(operatorTag, tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy)
opId <- insertedRowId db
pure op {operatorId = DBEntityId opId}
autoAcceptConditions op UsageConditions {conditionsCommit} =
acceptConditions_ db op conditionsCommit Nothing
$> op {conditionsAcceptance = CAAccepted Nothing}
serverOperatorQuery :: Query
serverOperatorQuery =
[sql|
SELECT server_operator_id, server_operator_tag, trade_name, legal_name,
server_domains, enabled, role_storage, role_proxy
FROM server_operators
|]
getServerOperators_ :: DB.Connection -> IO [ServerOperator]
getServerOperators_ db = map toServerOperator <$> DB.query_ db serverOperatorQuery
toServerOperator :: (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool) -> ServerOperator
toServerOperator (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) =
ServerOperator
{ operatorId,
operatorTag,
tradeName,
legalName,
serverDomains = T.splitOn "," domains,
conditionsAcceptance = CARequired Nothing,
enabled,
roles = ServerRoles {storage, proxy}
}
getOperatorConditions_ :: DB.Connection -> ServerOperator -> UsageConditions -> Maybe UsageConditions -> UTCTime -> IO ConditionsAcceptance
getOperatorConditions_ db ServerOperator {operatorId} UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt} latestAcceptedConds_ now = do
case latestAcceptedConds_ of
Nothing -> pure $ CARequired Nothing -- no conditions accepted by any operator
Just UsageConditions {conditionsCommit = latestAcceptedCommit} -> do
operatorAcceptedConds_ <-
maybeFirstRow id $
DB.query
db
[sql|
SELECT conditions_commit, accepted_at
FROM operator_usage_conditions
WHERE server_operator_id = ?
ORDER BY operator_usage_conditions_id DESC
LIMIT 1
|]
(Only operatorId)
pure $ case operatorAcceptedConds_ of
Just (operatorCommit, acceptedAt_)
| operatorCommit /= latestAcceptedCommit -> CARequired Nothing -- TODO should we consider this operator disabled?
| currentCommit /= latestAcceptedCommit -> CARequired $ conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
| otherwise -> CAAccepted acceptedAt_
_ -> CARequired Nothing -- no conditions were accepted for this operator
getCurrentUsageConditions :: DB.Connection -> ExceptT StoreError IO UsageConditions
getCurrentUsageConditions db =
ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
DB.query_ db (usageCondsQuery <> " DESC LIMIT 1")
usageCondsQuery :: Query
usageCondsQuery =
[sql|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
FROM usage_conditions
ORDER BY usage_conditions_id
|]
toUsageConditions :: (Int64, Text, Maybe UTCTime, UTCTime) -> UsageConditions
toUsageConditions (conditionsId, conditionsCommit, notifiedAt, createdAt) =
UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt}
getLatestAcceptedConditions :: DB.Connection -> IO (Maybe UsageConditions)
getLatestAcceptedConditions db =
maybeFirstRow toUsageConditions $
DB.query_
db
[sql|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
FROM usage_conditions
WHERE conditions_commit = (
SELECT conditions_commit
FROM operator_usage_conditions
ORDER BY accepted_at DESC
LIMIT 1
)
|]
setConditionsNotified :: DB.Connection -> Int64 -> UTCTime -> IO ()
setConditionsNotified db condId notifiedAt =
DB.execute db "UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?" (notifiedAt, condId)
acceptConditions :: DB.Connection -> Int64 -> NonEmpty Int64 -> UTCTime -> ExceptT StoreError IO ()
acceptConditions db condId opIds acceptedAt = do
UsageConditions {conditionsCommit} <- getUsageConditionsById_ db condId
operators <- mapM getServerOperator_ opIds
let ts = Just acceptedAt
liftIO $ forM_ operators $ \op -> acceptConditions_ db op conditionsCommit ts
where
getServerOperator_ opId =
ExceptT $ firstRow toServerOperator (SEOperatorNotFound opId) $
DB.query db (serverOperatorQuery <> " WHERE operator_id = ?") (Only opId)
acceptConditions_ :: DB.Connection -> ServerOperator -> Text -> Maybe UTCTime -> IO ()
acceptConditions_ db ServerOperator {operatorId, operatorTag} conditionsCommit acceptedAt =
DB.execute
db
[sql|
INSERT INTO operator_usage_conditions
(server_operator_id, server_operator_tag, conditions_commit, accepted_at)
VALUES (?,?,?,?)
|]
(operatorId, operatorTag, conditionsCommit, acceptedAt)
getUsageConditionsById_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UsageConditions
getUsageConditionsById_ db conditionsId =
ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
DB.query
db
[sql|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
FROM usage_conditions
WHERE usage_conditions_id = ?
|]
(Only conditionsId)
setUserServers :: DB.Connection -> User -> NonEmpty UpdatedUserOperatorServers -> ExceptT StoreError IO ()
setUserServers db user@User {userId} userServers = checkConstraint SEUniqueID $ liftIO $ do
ts <- getCurrentTime
forM_ userServers $ \UpdatedUserOperatorServers {operator, smpServers, xftpServers} -> do
mapM_ (updateServerOperator db ts) operator
mapM_ (upsertOrDelete SPSMP ts) smpServers
mapM_ (upsertOrDelete SPXFTP ts) xftpServers
where
upsertOrDelete :: ProtocolTypeI p => SProtocolType p -> UTCTime -> AUserServer p -> IO ()
upsertOrDelete p ts (AUS _ s@UserServer {serverId, deleted}) = case serverId of
DBNewEntity
| deleted -> pure ()
| otherwise -> void $ insertProtocolServer db p user ts s
DBEntityId srvId
| deleted -> DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND smp_server_id = ? AND preset = ?" (userId, srvId, False)
| otherwise -> updateProtocolServer db p ts s
createCall :: DB.Connection -> User -> Call -> UTCTime -> IO ()
createCall db user@User {userId} Call {contactId, callId, callUUID, chatItemId, callState} callTs = do
+2
View File
@@ -127,6 +127,8 @@ data StoreError
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
| SERemoteCtrlDuplicateCA
| SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
| SEOperatorNotFound {serverOperatorId :: Int64}
| SEUsageConditionsNotFound
deriving (Show, Exception)
$(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError)
+21 -16
View File
@@ -1,6 +1,7 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Terminal where
@@ -13,15 +14,15 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Database.SQLite.Simple (SQLError (..))
import qualified Database.SQLite.Simple as DB
import Simplex.Chat (defaultChatConfig)
import Simplex.Chat (_defaultNtfServers, defaultChatConfig, operatorSimpleXChat)
import Simplex.Chat.Controller
import Simplex.Chat.Core
import Simplex.Chat.Help (chatWelcome)
import Simplex.Chat.Operators
import Simplex.Chat.Options
import Simplex.Chat.Terminal.Input
import Simplex.Chat.Terminal.Output
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
import Simplex.Messaging.Agent.Env.SQLite (presetServerCfg)
import Simplex.Messaging.Client (NetworkConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig)
import Simplex.Messaging.Util (raceAny_)
import System.IO (hFlush, hSetEcho, stdin, stdout)
@@ -29,20 +30,24 @@ import System.IO (hFlush, hSetEcho, stdin, stdout)
terminalChatConfig :: ChatConfig
terminalChatConfig =
defaultChatConfig
{ defaultServers =
DefaultAgentServers
{ smp =
L.fromList $
map
(presetServerCfg True)
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
],
useSMP = 3,
ntf = ["ntf://FB-Uop7RTaZZEG0ZLD2CIaTjsPh-Fw0zFAnb7QyA8Ks=@ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion"],
xftp = L.map (presetServerCfg True) defaultXFTPServers,
useXFTP = L.length defaultXFTPServers,
{ presetServers =
PresetServers
{ operators =
[ PresetOperator
{ operator = Just operatorSimpleXChat,
smp =
map
(presetServer True)
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
],
useSMP = 3,
xftp = map (presetServer True) $ L.toList defaultXFTPServers,
useXFTP = 3
}
],
ntf = _defaultNtfServers,
netCfg =
defaultNetworkConfig
{ smpProxyMode = SPMUnknown,
+2 -2
View File
@@ -10,7 +10,7 @@ import Data.Maybe (fromMaybe)
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Network.Socket
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), DefaultAgentServers (DefaultAgentServers, netCfg), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), PresetServers (..), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
import Simplex.Chat.Core
import Simplex.Chat.Options
import Simplex.Chat.Terminal
@@ -56,7 +56,7 @@ simplexChatCLI' cfg opts@ChatOpts {chatCmd, chatCmdLog, chatCmdDelay, chatServer
putStrLn $ serializeChatResponse (rh, Just user) ts tz rh r
welcome :: ChatConfig -> ChatOpts -> IO ()
welcome ChatConfig {defaultServers = DefaultAgentServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
welcome ChatConfig {presetServers = PresetServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
mapM_
putStrLn
[ versionString versionNumber,
+87 -26
View File
@@ -25,6 +25,7 @@ import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
@@ -42,6 +43,7 @@ import Simplex.Chat.Help
import Simplex.Chat.Markdown
import Simplex.Chat.Messages hiding (NewChatItem (..))
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Operators
import Simplex.Chat.Protocol
import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange)
import Simplex.Chat.Remote.Types
@@ -53,7 +55,7 @@ import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..))
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerCfg (..))
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerRoles (..))
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
import Simplex.Messaging.Client (SMPProxyFallback, SMPProxyMode (..), SocksMode (..))
@@ -93,10 +95,13 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRChatSuspended -> ["chat suspended"]
CRApiChats u chats -> ttyUser u $ if testView then testViewChats chats else [viewJSON chats]
CRChats chats -> viewChats ts tz chats
CRApiChat u chat -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat]
CRApiChat u chat _ -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat]
CRApiParsedMarkdown ft -> [viewJSON ft]
CRUserProtoServers u userServers -> ttyUser u $ viewUserServers userServers testView
CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
CRServerOperators ops ca -> viewServerOperators ops ca
CRUserServers u uss -> ttyUser u $ concatMap viewUserServers uss <> (if testView then [] else serversUserHelp)
CRUserServersValidation _ -> []
CRUsageConditions {} -> []
CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl
CRNetworkConfig cfg -> viewNetworkConfig cfg
CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile
@@ -1209,27 +1214,31 @@ viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', sho
"profile is " <> if isJust viewPwdHash then "hidden" else "visible"
]
viewUserServers :: AUserProtoServers -> Bool -> [StyledString]
viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) testView =
customServers
<> if testView
then []
else
[ "",
"use " <> highlight (srvCmd <> " test <srv>") <> " to test " <> pName <> " server connection",
"use " <> highlight (srvCmd <> " <srv1[,srv2,...]>") <> " to configure " <> pName <> " servers",
"use " <> highlight (srvCmd <> " default") <> " to remove configured " <> pName <> " servers and use presets"
]
<> case p of
SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"]
SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"]
viewUserServers :: UserOperatorServers -> [StyledString]
viewUserServers (UserOperatorServers _ [] []) = []
viewUserServers UserOperatorServers {operator, smpServers, xftpServers} =
[plain $ maybe "Your servers" shortViewOperator operator]
<> viewServers SPSMP smpServers
<> viewServers SPXFTP xftpServers
where
srvCmd = "/" <> strEncode p
pName = protocolName p
customServers =
if null protoServers
then ("no " <> pName <> " servers saved, using presets: ") : viewServers presetServers
else viewServers protoServers
viewServers :: ProtocolTypeI p => SProtocolType p -> [UserServer p] -> [StyledString]
viewServers _ [] = []
viewServers p srvs = [" " <> protocolName p <> " servers"] <> map (plain . (" " <> ) . viewServer) srvs
where
viewServer UserServer {server, preset, tested, enabled} = safeDecodeUtf8 (strEncode server) <> serverInfo
where
serverInfo = if null serverInfo_ then "" else parens $ T.intercalate ", " serverInfo_
serverInfo_ = ["preset" | preset] <> testedInfo <> ["disabled" | not enabled]
testedInfo = maybe [] (\t -> ["test: " <> if t then "passed" else "failed"]) tested
serversUserHelp :: [StyledString]
serversUserHelp =
[ "",
"use " <> highlight' "/smp test <srv>" <> " to test SMP server connection",
"use " <> highlight' "/smp <srv1[,srv2,...]>" <> " to configure SMP servers",
"or the same commands starting from /xftp for XFTP servers",
"chat options " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") and " <> highlight' "--xftp-servers" <> " have precedence over preset servers for new user profiles"
]
protocolName :: ProtocolTypeI p => SProtocolType p -> StyledString
protocolName = plain . map toUpper . T.unpack . decodeLatin1 . strEncode
@@ -1250,6 +1259,53 @@ viewServerTestResult (AProtoServerWithAuth p _) = \case
where
pName = protocolName p
viewServerOperators :: [ServerOperator] -> Maybe UsageConditionsAction -> [StyledString]
viewServerOperators ops ca = map (plain . viewOperator) ops <> maybe [] viewConditionsAction ca
viewOperator :: ServerOperator' s -> Text
viewOperator op@ServerOperator {tradeName, legalName, serverDomains, conditionsAcceptance} =
viewOpIdTag op
<> tradeName
<> maybe "" parens legalName
<> (", domains: " <> T.intercalate ", " serverDomains)
<> (", conditions: " <> viewOpConditions conditionsAcceptance)
<> (", " <> viewOpEnabled op)
shortViewOperator :: ServerOperator -> Text
shortViewOperator op@ServerOperator {operatorId = DBEntityId opId, tradeName} =
tshow opId <> ". " <> tradeName <> parens (viewOpEnabled op)
viewOpIdTag :: ServerOperator' s -> Text
viewOpIdTag ServerOperator {operatorId, operatorTag} = case operatorId of
DBEntityId i -> tshow i <> " - " <> tag
DBNewEntity -> tag
where
tag = maybe "" textEncode operatorTag <> ". "
viewOpConditions :: ConditionsAcceptance -> Text
viewOpConditions = \case
CAAccepted ts -> viewCond "accepted" ts
CARequired ts -> viewCond "required" ts
where
viewCond w ts = w <> maybe "" (parens . tshow) ts
viewOpEnabled :: ServerOperator' s -> Text
viewOpEnabled ServerOperator {enabled, roles = ServerRoles {storage, proxy}}
| enabled && storage && proxy = "enabled"
| enabled && storage = "enabled storage"
| enabled && proxy = "enabled proxy"
| otherwise = "disabled"
viewConditionsAction :: UsageConditionsAction -> [StyledString]
viewConditionsAction = \case
UCAReview {operators, deadline, showNotice} | showNotice -> case deadline of
Just ts -> [plain $ "New conditions will be accepted at " <> tshow ts <> " for " <> ops]
Nothing -> [plain $ "New conditions have to be accepted for " <> ops]
where
ops = T.intercalate ", " $ map legalName_ operators
legalName_ ServerOperator {tradeName, legalName} = fromMaybe tradeName legalName
_ -> []
viewChatItemTTL :: Maybe Int64 -> [StyledString]
viewChatItemTTL = \case
Nothing -> ["old messages are not being deleted"]
@@ -1326,8 +1382,11 @@ viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
["receiving messages via: " <> viewRcvQueuesInfo rcvQueuesInfo | not $ null rcvQueuesInfo]
<> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo]
viewServers :: ProtocolTypeI p => NonEmpty (ServerCfg p) -> [StyledString]
viewServers = map (plain . B.unpack . strEncode . (\ServerCfg {server} -> server)) . L.toList
-- viewServers :: ProtocolTypeI p => [ServerOperator] -> NonEmpty (ServerCfg p) -> [StyledString]
-- viewServers operators = map (plain . (\ServerCfg {server, operator} -> B.unpack (strEncode server) <> viewOperator operator)) . L.toList
-- where
-- ops :: Map (Maybe DBEntityId) Text = foldl' (\m ServerOperator {operatorId, tradeName} -> M.insert (Just operatorId) tradeName m) M.empty operators
-- viewOperator = maybe "" $ \op -> " (operator " <> maybe (show op) T.unpack (M.lookup (Just op) ops) <> ")"
viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString
viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo
@@ -1926,7 +1985,9 @@ viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCo
then [versionString version, updateStr, "simplexmq: " <> simplexmqVersion <> parens simplexmqCommit]
else [versionString version, updateStr]
where
parens s = " (" <> s <> ")"
parens :: (IsString a, Semigroup a) => a -> a
parens s = " (" <> s <> ")"
viewRemoteHosts :: [RemoteHostInfo] -> [StyledString]
viewRemoteHosts = \case
+29 -10
View File
@@ -10,7 +10,8 @@ import ChatTests.Utils
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Exception (finally)
import Control.Monad (forM_)
import Directory.Events (viewName)
import qualified Data.Text as T
import qualified Directory.Events as DE
import Directory.Options
import Directory.Service
import Directory.Store
@@ -27,7 +28,7 @@ import Test.Hspec hiding (it)
directoryServiceTests :: SpecWith FilePath
directoryServiceTests = do
it "should register group" testDirectoryService
it "should suspend and resume group" testSuspendResume
it "should suspend and resume group, send message to owner" testSuspendResume
it "should delete group registration" testDeleteGroup
it "should change initial member role" testSetRole
it "should join found group via link" testJoinGroup
@@ -67,6 +68,7 @@ mkDirectoryOpts :: FilePath -> [KnownContact] -> DirectoryOpts
mkDirectoryOpts tmp superUsers =
DirectoryOpts
{ coreOptions = testCoreOpts {dbFilePrefix = tmp </> serviceDbPrefix},
adminUsers = [],
superUsers,
directoryLog = Just $ tmp </> "directory_service.log",
serviceName = "SimpleX-Directory",
@@ -77,6 +79,9 @@ mkDirectoryOpts tmp superUsers =
serviceDbPrefix :: FilePath
serviceDbPrefix = "directory_service"
viewName :: String -> String
viewName = T.unpack . DE.viewName . T.pack
testDirectoryService :: HasCallStack => FilePath -> IO ()
testDirectoryService tmp =
withDirectoryService tmp $ \superUser dsLink ->
@@ -111,7 +116,7 @@ testDirectoryService tmp =
-- putStrLn "*** update profile so that it has link"
updateGroupProfile bob welcomeWithLink
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (PSA) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
approvalRequested superUser welcomeWithLink (1 :: Int)
-- putStrLn "*** update profile so that it still has link"
let welcomeWithLink' = "Welcome! " <> welcomeWithLink
@@ -139,7 +144,7 @@ testDirectoryService tmp =
-- putStrLn "*** update profile so that it has link again"
updateGroupProfile bob welcomeWithLink'
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (PSA) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
approvalRequested superUser welcomeWithLink' (1 :: Int)
superUser #> "@SimpleX-Directory /pending"
superUser <# "SimpleX-Directory> > /pending"
@@ -207,6 +212,17 @@ testSuspendResume tmp =
superUser <## " Group listing resumed!"
bob <# "SimpleX-Directory> The group ID 1 (privacy) is listed in the directory again!"
groupFound bob "privacy"
superUser #> "@SimpleX-Directory privacy"
groupFoundN_ (Just 1) 2 superUser "privacy"
superUser #> "@SimpleX-Directory /link 1:privacy"
superUser <# "SimpleX-Directory> > /link 1:privacy"
superUser <## " The link to join the group ID 1 (privacy):"
superUser <##. "https://simplex.chat/contact"
superUser <## "New member role: member"
superUser #> "@SimpleX-Directory /owner 1:privacy hello there"
superUser <# "SimpleX-Directory> > /owner 1:privacy hello there"
superUser <## " Forwarded to @bob, the owner of the group ID 1 (privacy)"
bob <# "SimpleX-Directory> hello there"
testDeleteGroup :: HasCallStack => FilePath -> IO ()
testDeleteGroup tmp =
@@ -650,7 +666,7 @@ testRegOwnerRemovedLink tmp =
bob <## "description changed to:"
bob <## welcomeWithLink
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
cath <## "bob updated group #privacy:"
cath <## "description changed to:"
cath <## welcomeWithLink
@@ -692,7 +708,7 @@ testAnotherOwnerRemovedLink tmp =
bob <## "description changed to:"
bob <## (welcomeWithLink <> " - welcome!")
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
cath <## "bob updated group #privacy:"
cath <## "description changed to:"
cath <## (welcomeWithLink <> " - welcome!")
@@ -774,7 +790,7 @@ testDuplicateProhibitWhenUpdated tmp =
cath ##> "/gp privacy security Security"
cath <## "changed to #security (Security)"
cath <# "SimpleX-Directory> Thank you! The group link for ID 2 (security) is added to the welcome message."
cath <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
cath <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
notifySuperUser superUser cath "security" "Security" welcomeWithLink' 2
approveRegistration superUser cath "security" 2
groupFound bob "security"
@@ -1035,7 +1051,7 @@ updateProfileWithLink u n welcomeWithLink ugId = do
u <## "description changed to:"
u <## welcomeWithLink
u <# ("SimpleX-Directory> Thank you! The group link for ID " <> show ugId <> " (" <> n <> ") is added to the welcome message.")
u <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
u <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
notifySuperUser :: TestCC -> TestCC -> String -> String -> String -> Int -> IO ()
notifySuperUser su u n fn welcomeWithLink gId = do
@@ -1112,10 +1128,13 @@ groupFoundN count u name = do
groupFoundN' count u name
groupFoundN' :: Int -> TestCC -> String -> IO ()
groupFoundN' count u name = do
groupFoundN' = groupFoundN_ Nothing
groupFoundN_ :: Maybe Int -> Int -> TestCC -> String -> IO ()
groupFoundN_ shownId_ count u name = do
u <# ("SimpleX-Directory> > " <> name)
u <## " Found 1 group(s)."
u <#. ("SimpleX-Directory> " <> name)
u <#. ("SimpleX-Directory> " <> maybe "" (\gId -> show gId <> ". ") shownId_ <> name)
u <## "Welcome message:"
u <##. "Link to join the group "
u <## (show count <> " members")
+19 -7
View File
@@ -25,9 +25,10 @@ import Data.Maybe (isNothing)
import qualified Data.Text as T
import Network.Socket
import Simplex.Chat
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg)
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), PresetServers (..), defaultSimpleNetCfg)
import Simplex.Chat.Core
import Simplex.Chat.Options
import Simplex.Chat.Operators (PresetOperator (..), presetServer)
import Simplex.Chat.Protocol (currentChatVersion, pqEncryptionCompressionVersion)
import Simplex.Chat.Store
import Simplex.Chat.Store.Profiles
@@ -94,8 +95,8 @@ testCoreOpts =
{ dbFilePrefix = "./simplex_v1",
dbKey = "",
-- dbKey = "this is a pass-phrase to encrypt the database",
smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
smpServers = [],
xftpServers = [],
simpleNetCfg = defaultSimpleNetCfg,
logLevel = CLLImportant,
logConnections = False,
@@ -149,6 +150,18 @@ testCfg :: ChatConfig
testCfg =
defaultChatConfig
{ agentConfig = testAgentCfg,
presetServers =
(presetServers defaultChatConfig)
{ operators =
[ PresetOperator
{ operator = Nothing,
smp = map (presetServer True) ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
useSMP = 1,
xftp = map (presetServer True) ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
useXFTP = 1
}
]
},
showReceipts = False,
testView = True,
tbqSize = 16
@@ -423,11 +436,10 @@ smpServerCfg =
ServerConfig
{ transports = [(serverPort, transport @TLS, False)],
tbqSize = 1,
-- serverTbqSize = 1,
msgQueueQuota = 16,
msgStoreType = AMSType SMSMemory,
maxJournalMsgCount = 1000,
maxJournalStateLines = 1000,
msgQueueQuota = 16,
maxJournalMsgCount = 24,
maxJournalStateLines = 4,
queueIdBytes = 12,
msgIdBytes = 6,
storeLogFile = Nothing,
+105 -30
View File
@@ -25,7 +25,7 @@ import Database.SQLite.Simple (Only (..))
import Simplex.Chat.AppSettings (defaultAppSettings)
import qualified Simplex.Chat.AppSettings as AS
import Simplex.Chat.Call
import Simplex.Chat.Controller (ChatConfig (..), DefaultAgentServers (..))
import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..))
import Simplex.Chat.Messages (ChatItemId)
import Simplex.Chat.Options
import Simplex.Chat.Protocol (supportedChatVRange)
@@ -66,6 +66,7 @@ chatDirectTests = do
it "repeat AUTH errors disable contact" testRepeatAuthErrorsDisableContact
it "should send multiline message" testMultilineMessage
it "send large message" testLargeMessage
it "initial chat pagination" testChatPaginationInitial
describe "batch send messages" $ do
it "send multiple messages api" testSendMulti
it "send multiple timed messages" testSendMultiTimed
@@ -123,7 +124,7 @@ chatDirectTests = do
it "chat items only expire for users who configured expiration" testEnableCIExpirationOnlyForOneUser
it "disabling chat item expiration doesn't disable it for other users" testDisableCIExpirationOnlyForOneUser
it "both users have configured timed messages with contacts, messages expire, restart" testUsersTimedMessages
it "user profile privacy: hide profiles and notificaitons" testUserPrivacy
it "user profile privacy: hide profiles and notifications" testUserPrivacy
describe "settings" $ do
it "set chat item expiration TTL" testSetChatItemTTL
it "save/get app settings" testAppSettings
@@ -210,6 +211,7 @@ testAddContact = versionTestMatrix2 runTestAddContact
-- pagination
alice #$> ("/_get chat @2 after=" <> itemId 1 <> " count=100", chat, [(0, "hello there"), (0, "how are you?")])
alice #$> ("/_get chat @2 before=" <> itemId 2 <> " count=100", chat, features <> [(1, "hello there 🙂")])
alice #$> ("/_get chat @2 around=" <> itemId 2 <> " count=2", chat, [(0, "Audio/video calls: enabled"), (1, "hello there 🙂"), (0, "hello there"), (0, "how are you?")])
-- search
alice #$> ("/_get chat @2 count=100 search=ello ther", chat, [(1, "hello there 🙂"), (0, "hello there")])
-- read messages
@@ -332,8 +334,8 @@ testRetryConnectingClientTimeout tmp = do
{ quotaExceededTimeout = 1,
messageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval}
},
defaultServers =
let def@DefaultAgentServers {netCfg} = defaultServers testCfg
presetServers =
let def@PresetServers {netCfg} = presetServers testCfg
in def {netCfg = (netCfg :: NetworkConfig) {tcpTimeout = 10}}
}
opts' =
@@ -360,6 +362,36 @@ testMarkReadDirect = testChat2 aliceProfile bobProfile $ \alice bob -> do
let itemIds = intercalate "," $ map show [i - 3 .. i]
bob #$> ("/_read chat items @2 " <> itemIds, id, "ok")
testChatPaginationInitial :: HasCallStack => FilePath -> IO ()
testChatPaginationInitial = testChatOpts2 opts aliceProfile bobProfile $ \alice bob -> do
connectUsers alice bob
-- Wait, otherwise ids are going to be wrong.
threadDelay 1000000
-- Send messages from alice to bob
forM_ ([1 .. 10] :: [Int]) $ \n -> alice #> ("@bob " <> show n)
-- Bob receives the messages.
forM_ ([1 .. 10] :: [Int]) $ \n -> bob <# ("alice> " <> show n)
-- All messages are unread for bob, should return area around unread
bob #$> ("/_get chat @2 initial=2", chat, [(0, "Voice messages: enabled"), (0, "Audio/video calls: enabled"), (0, "1"), (0, "2"), (0, "3")])
-- Read next 2 items
let itemIds = intercalate "," $ map itemId [1 .. 2]
bob #$> ("/_read chat items @2 " <> itemIds, id, "ok")
bob #$> ("/_get chat @2 initial=2", chat, [(0, "1"), (0, "2"), (0, "3"), (0, "4"), (0, "5")])
-- Read all items
bob #$> ("/_read chat @2", id, "ok")
bob #$> ("/_get chat @2 initial=3", chat, [(0, "8"), (0, "9"), (0, "10")])
bob #$> ("/_get chat @2 initial=5", chat, [(0, "6"), (0, "7"), (0, "8"), (0, "9"), (0, "10")])
where
opts =
testOpts
{ markRead = False
}
testDuplicateContactsSeparate :: HasCallStack => FilePath -> IO ()
testDuplicateContactsSeparate =
testChat2 aliceProfile bobProfile $
@@ -791,7 +823,7 @@ testDirectMessageDelete =
alice @@@ [("@bob", lastChatFeature)]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures)
-- alice: msg id 1
-- alice: msg id 3
bob ##> ("/_update item @2 " <> itemId 2 <> " text hey alice")
bob <# "@alice [edited] > hello 🙂"
bob <## " hey alice"
@@ -806,12 +838,12 @@ testDirectMessageDelete =
alice @@@ [("@bob", "hey alice [marked deleted]")]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "hey alice [marked deleted]")])
-- alice: deletes msg id 1 that was broadcast deleted by bob
alice #$> ("/_delete item @2 " <> itemId 1 <> " internal", id, "message deleted")
-- alice: deletes msg id 3 that was broadcast deleted by bob
alice #$> ("/_delete item @2 " <> itemId 3 <> " internal", id, "message deleted")
alice @@@ [("@bob", lastChatFeature)]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures)
-- alice: msg id 1, bob: msg id 3 (quoting message alice deleted locally)
-- alice: msg id 4, bob: msg id 3 (quoting message alice deleted locally)
bob `send` "> @alice (hello 🙂) do you receive my messages?"
bob <# "@alice > hello 🙂"
bob <## " do you receive my messages?"
@@ -819,14 +851,14 @@ testDirectMessageDelete =
alice <## " do you receive my messages?"
alice @@@ [("@bob", "do you receive my messages?")]
alice #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "do you receive my messages?"), Just (1, "hello 🙂"))])
alice #$> ("/_delete item @2 " <> itemId 1 <> " broadcast", id, "cannot delete this item")
alice #$> ("/_delete item @2 " <> itemId 4 <> " broadcast", id, "cannot delete this item")
-- alice: msg id 2, bob: msg id 4
-- alice: msg id 5, bob: msg id 4
bob #> "@alice how are you?"
alice <# "bob> how are you?"
-- alice: deletes msg id 2
alice #$> ("/_delete item @2 " <> itemId 2 <> " internal", id, "message deleted")
-- alice: deletes msg id 5
alice #$> ("/_delete item @2 " <> itemId 5 <> " internal", id, "message deleted")
-- bob: marks deleted msg id 4 (that alice deleted locally)
bob #$> ("/_delete item @2 " <> itemId 4 <> " broadcast", id, "message marked deleted")
@@ -1109,17 +1141,32 @@ testGetSetSMPServers :: HasCallStack => FilePath -> IO ()
testGetSetSMPServers =
testChat2 aliceProfile bobProfile $
\alice _ -> do
alice #$> ("/_servers 1 smp", id, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001")
alice ##> "/_servers 1"
alice <## "Your servers"
alice <## " SMP servers"
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)"
alice <## " XFTP servers"
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset)"
alice #$> ("/smp smp://1234-w==@smp1.example.im", id, "ok")
alice #$> ("/smp", id, "smp://1234-w==@smp1.example.im")
alice ##> "/smp"
alice <## "Your servers"
alice <## " SMP servers"
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
alice <## " smp://1234-w==@smp1.example.im"
alice #$> ("/smp smp://1234-w==:password@smp1.example.im", id, "ok")
alice #$> ("/smp", id, "smp://1234-w==:password@smp1.example.im")
-- alice #$> ("/smp", id, "smp://1234-w==:password@smp1.example.im")
alice ##> "/smp"
alice <## "Your servers"
alice <## " SMP servers"
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
alice <## " smp://1234-w==:password@smp1.example.im"
alice #$> ("/smp smp://2345-w==@smp2.example.im smp://3456-w==@smp3.example.im:5224", id, "ok")
alice ##> "/smp"
alice <## "smp://2345-w==@smp2.example.im"
alice <## "smp://3456-w==@smp3.example.im:5224"
alice #$> ("/smp default", id, "ok")
alice #$> ("/smp", id, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001")
alice <## "Your servers"
alice <## " SMP servers"
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
alice <## " smp://2345-w==@smp2.example.im"
alice <## " smp://3456-w==@smp3.example.im:5224"
testTestSMPServerConnection :: HasCallStack => FilePath -> IO ()
testTestSMPServerConnection =
@@ -1140,17 +1187,31 @@ testGetSetXFTPServers :: HasCallStack => FilePath -> IO ()
testGetSetXFTPServers =
testChat2 aliceProfile bobProfile $
\alice _ -> withXFTPServer $ do
alice #$> ("/_servers 1 xftp", id, "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002")
alice ##> "/_servers 1"
alice <## "Your servers"
alice <## " SMP servers"
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)"
alice <## " XFTP servers"
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset)"
alice #$> ("/xftp xftp://1234-w==@xftp1.example.im", id, "ok")
alice #$> ("/xftp", id, "xftp://1234-w==@xftp1.example.im")
alice ##> "/xftp"
alice <## "Your servers"
alice <## " XFTP servers"
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
alice <## " xftp://1234-w==@xftp1.example.im"
alice #$> ("/xftp xftp://1234-w==:password@xftp1.example.im", id, "ok")
alice #$> ("/xftp", id, "xftp://1234-w==:password@xftp1.example.im")
alice ##> "/xftp"
alice <## "Your servers"
alice <## " XFTP servers"
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
alice <## " xftp://1234-w==:password@xftp1.example.im"
alice #$> ("/xftp xftp://2345-w==@xftp2.example.im xftp://3456-w==@xftp3.example.im:5224", id, "ok")
alice ##> "/xftp"
alice <## "xftp://2345-w==@xftp2.example.im"
alice <## "xftp://3456-w==@xftp3.example.im:5224"
alice #$> ("/xftp default", id, "ok")
alice #$> ("/xftp", id, "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002")
alice <## "Your servers"
alice <## " XFTP servers"
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
alice <## " xftp://2345-w==@xftp2.example.im"
alice <## " xftp://3456-w==@xftp3.example.im:5224"
testTestXFTPServer :: HasCallStack => FilePath -> IO ()
testTestXFTPServer =
@@ -1768,11 +1829,17 @@ testCreateUserSameServers =
where
checkCustomServers alice = do
alice ##> "/smp"
alice <## "smp://2345-w==@smp2.example.im"
alice <## "smp://3456-w==@smp3.example.im:5224"
alice <## "Your servers"
alice <## " SMP servers"
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
alice <## " smp://2345-w==@smp2.example.im"
alice <## " smp://3456-w==@smp3.example.im:5224"
alice ##> "/xftp"
alice <## "xftp://2345-w==@xftp2.example.im"
alice <## "xftp://3456-w==@xftp3.example.im:5224"
alice <## "Your servers"
alice <## " XFTP servers"
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
alice <## " xftp://2345-w==@xftp2.example.im"
alice <## " xftp://3456-w==@xftp3.example.im:5224"
testDeleteUser :: HasCallStack => FilePath -> IO ()
testDeleteUser =
@@ -2340,6 +2407,14 @@ testUserPrivacy =
"bob> Voice messages: enabled",
"bob> Audio/video calls: enabled"
]
alice ##> "/_get items around=11 count=2"
alice
<##? [ "bob> Full deletion: off",
"bob> Message reactions: enabled",
"bob> Voice messages: enabled",
"bob> Audio/video calls: enabled",
"@bob hello"
]
alice ##> "/_get items after=12 count=10"
alice
<##? [ "@bob hello",
+36
View File
@@ -1,8 +1,10 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatTests.Groups where
@@ -36,6 +38,7 @@ chatGroupTests = do
describe "chat groups" $ do
describe "add contacts, create group and send/receive messages" testGroupMatrix
it "mark multiple messages as read" testMarkReadGroup
it "initial chat pagination" testChatPaginationInitial
it "v1: add contacts, create group and send/receive messages" testGroup
it "v1: add contacts, create group and send/receive messages, check messages" testGroupCheckMessages
it "send large message" testGroupLargeMessage
@@ -344,6 +347,7 @@ testGroupShared alice bob cath checkMessages directConnections = do
-- so we take into account group event items as well as sent group invitations in direct chats
alice #$> ("/_get chat #1 after=" <> msgItem1 <> " count=100", chat, [(0, "hi there"), (0, "hey team")])
alice #$> ("/_get chat #1 before=" <> msgItem2 <> " count=100", chat, [(1, e2eeInfoNoPQStr), (0, "connected"), (0, "connected"), (1, "hello"), (0, "hi there")])
alice #$> ("/_get chat #1 around=" <> msgItem1 <> " count=2", chat, [(0, "connected"), (0, "connected"), (1, "hello"), (0, "hi there"), (0, "hey team")])
alice #$> ("/_get chat #1 count=100 search=team", chat, [(0, "hey team")])
bob @@@ [("@cath", "hey"), ("#team", "hey team"), ("@alice", "received invitation to join group team as admin")]
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "added cath (Catherine)"), (0, "connected"), (0, "hello"), (1, "hi there"), (0, "hey team")])
@@ -374,6 +378,38 @@ testMarkReadGroup = testChat2 aliceProfile bobProfile $ \alice bob -> do
let itemIds = intercalate "," $ map show [i - 3 .. i]
bob #$> ("/_read chat items #1 " <> itemIds, id, "ok")
testChatPaginationInitial :: HasCallStack => FilePath -> IO ()
testChatPaginationInitial = testChatOpts2 opts aliceProfile bobProfile $ \alice bob -> do
createGroup2 "team" alice bob
-- Wait, otherwise ids are going to be wrong.
threadDelay 1000000
lastEventId <- (read :: String -> Int) <$> lastItemId bob
let groupItemId n = show $ lastEventId + n
-- Send messages from alice to bob
forM_ ([1 .. 10] :: [Int]) $ \n -> alice #> ("#team " <> show n)
-- Bob receives the messages.
forM_ ([1 .. 10] :: [Int]) $ \n -> bob <# ("#team alice> " <> show n)
-- All messages are unread for bob, should return area around unread
bob #$> ("/_get chat #1 initial=2", chat, [(0, "Recent history: on"), (0, "connected"), (0, "1"), (0, "2"), (0, "3")])
-- Read next 2 items
let itemIds = intercalate "," $ map groupItemId [1 .. 2]
bob #$> ("/_read chat items #1 " <> itemIds, id, "ok")
bob #$> ("/_get chat #1 initial=2", chat, [(0, "1"), (0, "2"), (0, "3"), (0, "4"), (0, "5")])
-- Read all items
bob #$> ("/_read chat #1", id, "ok")
bob #$> ("/_get chat #1 initial=3", chat, [(0, "8"), (0, "9"), (0, "10")])
bob #$> ("/_get chat #1 initial=5", chat, [(0, "6"), (0, "7"), (0, "8"), (0, "9"), (0, "10")])
where
opts =
testOpts
{ markRead = False
}
testGroupLargeMessage :: HasCallStack => FilePath -> IO ()
testGroupLargeMessage =
testChat2 aliceProfile bobProfile $
+5 -1
View File
@@ -51,7 +51,7 @@ testNotes tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do
alice ##> "/chats"
alice /* "ahoy!"
alice ##> "/_update item *1 1 text Greetings."
alice ##> "/_update item *1 2 text Greetings."
alice ##> "/tail *"
alice <# "* Greetings."
@@ -102,6 +102,10 @@ testChatPagination tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do
alice #$> ("/_get chat *1 count=100", chat, [(1, "hello world"), (1, "memento mori"), (1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 count=1", chat, [(1, "who's there?")])
alice #$> ("/_get chat *1 around=2 count=1", chat, [(1, "hello world"), (1, "memento mori"), (1, "knock-knock")])
alice #$> ("/_get chat *1 around=2 count=3", chat, [(1, "hello world"), (1, "memento mori"), (1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 around=3 count=10", chat, [(1, "hello world"), (1, "memento mori"), (1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 around=4 count=1", chat, [(1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 after=2 count=10", chat, [(1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 after=2 count=2", chat, [(1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 after=1 count=2", chat, [(1, "memento mori"), (1, "knock-knock")])
+11 -1
View File
@@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatTests.Profiles where
@@ -1733,7 +1734,16 @@ testChangePCCUserDiffSrv tmp = do
-- Create new user with different servers
alice ##> "/create user alisa"
showActiveUser alice "alisa"
alice #$> ("/smp smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003", id, "ok")
alice ##> "/smp"
alice <## "Your servers"
alice <## " SMP servers"
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)"
alice #$> ("/smp smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003", id, "ok")
alice ##> "/smp"
alice <## "Your servers"
alice <## " SMP servers"
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003"
alice ##> "/user alice"
showActiveUser alice "alice (Alice)"
-- Change connection to newly created user and use the newly created connection
+33 -20
View File
@@ -1,51 +1,64 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module RandomServers where
import Control.Monad (replicateM)
import Data.Foldable (foldMap')
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Simplex.Chat (cfgServers, cfgServersToUse, defaultChatConfig, randomServers)
import Simplex.Chat.Controller (ChatConfig (..))
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..))
import Data.Monoid (Sum (..))
import Simplex.Chat (defaultChatConfig, randomPresetServers)
import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..))
import Simplex.Chat.Operators (DBEntityId' (..), NewUserServer, UserServer' (..), operatorServers, operatorServersToUse)
import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SProtocolType (..), UserProtocol)
import Test.Hspec
randomServersTests :: Spec
randomServersTests = describe "choosig random servers" $ do
it "should choose 4 random SMP servers and keep the rest disabled" testRandomSMPServers
it "should keep all 6 XFTP servers" testRandomXFTPServers
it "should choose 4 + 3 random SMP servers and keep the rest disabled" testRandomSMPServers
it "should choose 3 + 3 random XFTP servers and keep the rest disabled" testRandomXFTPServers
deriving instance Eq (ServerCfg p)
deriving instance Eq ServerRoles
deriving instance Eq (DBEntityId' s)
deriving instance Eq (UserServer' s p)
testRandomSMPServers :: IO ()
testRandomSMPServers = do
[srvs1, srvs2, srvs3] <-
replicateM 3 $
checkEnabled SPSMP 4 False =<< randomServers SPSMP defaultChatConfig
checkEnabled SPSMP 7 False =<< randomPresetServers SPSMP (presetServers defaultChatConfig)
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures
testRandomXFTPServers :: IO ()
testRandomXFTPServers = do
[srvs1, srvs2, srvs3] <-
replicateM 3 $
checkEnabled SPXFTP 6 True =<< randomServers SPXFTP defaultChatConfig
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` True
checkEnabled SPXFTP 6 False =<< randomPresetServers SPXFTP (presetServers defaultChatConfig)
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures
checkEnabled :: UserProtocol p => SProtocolType p -> Int -> Bool -> (L.NonEmpty (ServerCfg p), [ServerCfg p]) -> IO [ServerCfg p]
checkEnabled p n allUsed (srvs, _) = do
let def = defaultServers defaultChatConfig
cfgSrvs = L.sortWith server' $ cfgServers p def
toUse = cfgServersToUse p def
srvs == cfgSrvs `shouldBe` allUsed
L.map enable srvs `shouldBe` L.map enable cfgSrvs
let enbldSrvs = L.filter (\ServerCfg {enabled} -> enabled) srvs
checkEnabled :: UserProtocol p => SProtocolType p -> Int -> Bool -> NonEmpty (NewUserServer p) -> IO [NewUserServer p]
checkEnabled p n allUsed srvs = do
let srvs' = sortOn server' $ L.toList srvs
PresetServers {operators = presetOps} = presetServers defaultChatConfig
presetSrvs = sortOn server' $ concatMap (operatorServers p) presetOps
Sum toUse = foldMap' (Sum . operatorServersToUse p) presetOps
srvs' == presetSrvs `shouldBe` allUsed
map enable srvs' `shouldBe` map enable presetSrvs
let enbldSrvs = filter (\UserServer {enabled} -> enabled) srvs'
toUse `shouldBe` n
length enbldSrvs `shouldBe` n
pure enbldSrvs
where
server' ServerCfg {server = ProtoServerWithAuth srv _} = srv
enable :: forall p. ServerCfg p -> ServerCfg p
enable srv = (srv :: ServerCfg p) {enabled = False}
server' UserServer {server = ProtoServerWithAuth srv _} = srv
enable :: forall p. NewUserServer p -> NewUserServer p
enable srv = (srv :: NewUserServer p) {enabled = False}
+3 -1
View File
@@ -102,7 +102,9 @@ skipComparisonForDownMigrations =
-- table and indexes move down to the end of the file
"20231215_recreate_msg_deliveries",
-- on down migration idx_msg_deliveries_agent_ack_cmd_id index moves down to the end of the file
"20240313_drop_agent_ack_cmd_id"
"20240313_drop_agent_ack_cmd_id",
-- on down migration chat_item_autoincrement_id makes sequence table creation move down on the file
"20241023_chat_item_autoincrement_id"
]
getSchema :: FilePath -> FilePath -> IO String