IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master-ghc8107' into master-android

Browse Source
This commit is contained in:
Evgeny Poberezkin 2023-12-26 21:27:06 +00:00
commit 82dd5751c1
26 changed files with 711 additions and 729 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
apps/ios/Shared/Views/Chat/ChatView.swift
View File

@ -723,9 +723,14 @@ struct ChatView: View {
if ci.meta.itemDeleted == nil && !ci.isLiveDummy && !live {
menu.append(replyUIAction(ci))
}
menu.append(shareUIAction(ci))
menu.append(copyUIAction(ci))
if let fileSource = getLoadedFileSource(ci.file) {
let fileSource = getLoadedFileSource(ci.file)
let fileExists = if let fs = fileSource, FileManager.default.fileExists(atPath: getAppFilePath(fs.filePath).path) { true } else { false }
let copyAndShareAllowed = !ci.content.text.isEmpty || (ci.content.msgContent?.isImage == true && fileExists)
if copyAndShareAllowed {
menu.append(shareUIAction(ci))
menu.append(copyUIAction(ci))
}
if let fileSource = fileSource, fileExists {
if case .image = ci.content.msgContent, let image = getLoadedImage(ci.file) {
if image.imageData != nil {
menu.append(saveFileAction(fileSource))

56
apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chat/ChatView.kt
View File

@ -220,8 +220,9 @@ fun ChatView(chatId: String, chatModel: ChatModel, onComposed: suspend (chatId:
}
}
},
loadPrevMessages = { cInfo ->
val c = chatModel.getChat(cInfo.id)
loadPrevMessages = {
if (chatModel.chatId.value != activeChat.value?.id) return@ChatLayout
val c = chatModel.getChat(chatModel.chatId.value ?: return@ChatLayout)
val firstId = chatModel.chatItems.firstOrNull()?.id
if (c != null && firstId != null) {
withApi {
@ -440,7 +441,8 @@ fun ChatView(chatId: String, chatModel: ChatModel, onComposed: suspend (chatId:
changeNtfsState = { enabled, currentValue -> toggleNotifications(chat, enabled, chatModel, currentValue) },
onSearchValueChanged = { value ->
if (searchText.value == value) return@ChatLayout
val c = chatModel.getChat(chat.chatInfo.id) ?: return@ChatLayout
if (chatModel.chatId.value != activeChat.value?.id) return@ChatLayout
val c = chatModel.getChat(chatModel.chatId.value ?: return@ChatLayout) ?: return@ChatLayout
withApi {
apiFindMessages(c, chatModel, value)
searchText.value = value
@ -467,7 +469,7 @@ fun ChatLayout(
back: () -> Unit,
info: () -> Unit,
showMemberInfo: (GroupInfo, GroupMember) -> Unit,
loadPrevMessages: (ChatInfo) -> Unit,
loadPrevMessages: () -> Unit,
deleteMessage: (Long, CIDeleteMode) -> Unit,
deleteMessages: (List<Long>) -> Unit,
receiveFile: (Long, Boolean) -> Unit,
@ -790,7 +792,7 @@ fun BoxWithConstraintsScope.ChatItemsList(
useLinkPreviews: Boolean,
linkMode: SimplexLinkMode,
showMemberInfo: (GroupInfo, GroupMember) -> Unit,
loadPrevMessages: (ChatInfo) -> Unit,
loadPrevMessages: () -> Unit,
deleteMessage: (Long, CIDeleteMode) -> Unit,
deleteMessages: (List<Long>) -> Unit,
receiveFile: (Long, Boolean) -> Unit,
@ -828,9 +830,7 @@ fun BoxWithConstraintsScope.ChatItemsList(
}
}
PreloadItems(listState, ChatPagination.UNTIL_PRELOAD_COUNT, chat, chatItems) { c ->
loadPrevMessages(c.chatInfo)
}
PreloadItems(listState, ChatPagination.UNTIL_PRELOAD_COUNT, loadPrevMessages)
Spacer(Modifier.size(8.dp))
val reversedChatItems by remember { derivedStateOf { chatItems.reversed().toList() } }
@ -1150,24 +1150,32 @@ fun BoxWithConstraintsScope.FloatingButtons(
fun PreloadItems(
listState: LazyListState,
remaining: Int = 10,
chat: Chat,
items: List<*>,
onLoadMore: (chat: Chat) -> Unit,
onLoadMore: () -> Unit,
) {
LaunchedEffect(listState, chat, items) {
snapshotFlow { listState.layoutInfo }
.map {
val totalItemsNumber = it.totalItemsCount
val lastVisibleItemIndex = (it.visibleItemsInfo.lastOrNull()?.index ?: 0) + 1
if (lastVisibleItemIndex > (totalItemsNumber - remaining) && totalItemsNumber >= ChatPagination.INITIAL_COUNT)
totalItemsNumber
else
0
// Prevent situation when initial load and load more happens one after another after selecting a chat with long scroll position from previous selection
val allowLoad = remember { mutableStateOf(false) }
LaunchedEffect(Unit) {
snapshotFlow { chatModel.chatId.value }
.filterNotNull()
.collect {
allowLoad.value = listState.layoutInfo.totalItemsCount == listState.layoutInfo.visibleItemsInfo.size
delay(500)
allowLoad.value = true
}
.distinctUntilChanged()
}
KeyChangeEffect(allowLoad.value) {
snapshotFlow {
val lInfo = listState.layoutInfo
val totalItemsNumber = lInfo.totalItemsCount
val lastVisibleItemIndex = (lInfo.visibleItemsInfo.lastOrNull()?.index ?: 0) + 1
if (allowLoad.value && lastVisibleItemIndex > (totalItemsNumber - remaining) && totalItemsNumber >= ChatPagination.INITIAL_COUNT)
totalItemsNumber + ChatPagination.PRELOAD_COUNT
else
0
}
.filter { it > 0 }
.collect {
onLoadMore(chat)
onLoadMore()
}
}
}
@ -1439,7 +1447,7 @@ fun PreviewChatLayout() {
back = {},
info = {},
showMemberInfo = { _, _ -> },
loadPrevMessages = { _ -> },
loadPrevMessages = {},
deleteMessage = { _, _ -> },
deleteMessages = { _ -> },
receiveFile = { _, _ -> },
@ -1512,7 +1520,7 @@ fun PreviewGroupChatLayout() {
back = {},
info = {},
showMemberInfo = { _, _ -> },
loadPrevMessages = { _ -> },
loadPrevMessages = {},
deleteMessage = { _, _ -> },
deleteMessages = {},
receiveFile = { _, _ -> },

2
cabal.project
View File

@ -14,7 +14,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: 1e15d56e92c0549c7ba6a60d2c9d557b2949b0ff
tag: 577e3cf14d3c1e6cb6a45b987ca934ed793dac26
source-repository-package
type: git

13
docs/ANDROID.md
View File

@ -20,6 +20,7 @@ If you want to view what's stored inside SimpleX data directory you need to have
- your device connected via USB or Wi-Fi to the computer.
## The process:
- open SimpleX, go to `Database passphrase & export`, enable `App data backup`. This will make other steps working
- _optional_: if you want to view database contents, change database passphrase from random to yours. To do this, stop a chat in `Database passphrase & export` screen, open `Database passphrase`, enter new passphrase and confirm it, then update it. Do not forget it, otherwise you'll lose all your data in case passphrase will be asked again later
- open a terminal emulator (Windows CMD/Powershell will not work) and change directory to the one you want to use for storing the backup:
@ -43,4 +44,14 @@ Now the backed-up files will be inside `./apps/chat.simplex.app/`.
Please, note, that if you use a modern version of SimpleX, the databases will be encrypted, and you'll not be able to view contents of them without using `sqlcipher` application and without knowing decryption passphrase (you need to change it to yours from randomly generated in the app firstly).
Please, follow [SQL.md](./SQL.md) guide for more info of how to decrypt your databases and to make queries to them.
## Decrypting databases
In order to view database data you need to decrypt it first. Install `sqlcipher` using your favorite package manager and run the following commands in the directory with databases:
```bash
sqlcipher files_chat.db
pragma key="youDecryptionPassphrase";
# Ensure it works fine
select * from users;
```
If you see `Parse error: no such table: users`, make sure you entered correct passphrase, and you have changed passphrase from random in Android app (if you got this database from Android device, of course).

34
docs/CLI.md
View File

@ -243,37 +243,3 @@ User address is "long-term" in a sense that it is a multiple-use connection link
Use `/help address` for other commands.
![simplex-chat](../images/user-addresses.gif)
### Access chat history
SimpleX chat stores all your contacts and conversations in a local SQLite database, making it private and portable by design, owned and controlled by user.
You can view and search your chat history by querying your database. Run the below script to create message views in your database.
```sh
curl -o- https://raw.githubusercontent.com/simplex-chat/simplex-chat/stable/scripts/message_views.sql | sqlite3 ~/.simplex/simplex_v1_chat.db
```
Open SQLite Command Line Shell:
```sh
sqlite3 ~/.simplex/simplex_v1_chat.db
```
See [Message queries](./SQL.md) for examples.
> **Please note:** SQLite foreign key constraints are disabled by default, and must be **[enabled separately for each database connection](https://sqlite.org/foreignkeys.html#fk_enable)**. The latter can be achieved by running `PRAGMA foreign_keys = ON;` command on an open database connection. By running data altering queries without enabling foreign keys prior to that, you may risk putting your database in an inconsistent state.
**Convenience queries**
Get all messages from today (`chat_dt` is in UTC):
```sql
select * from all_messages_plain where date(chat_dt) > date('now', '-1 day') order by chat_dt;
```
Get overnight messages in the morning:
```sql
select * from all_messages_plain where chat_dt > datetime('now', '-15 hours') order by chat_dt;
```

60
docs/SQL.md
View File

@ -1,60 +0,0 @@
---
title: Accessing messages in the database
revision: 31.01.2023
---
| Updated 31.01.2023 | Languages: EN, [FR](/docs/lang/fr/SQL.md), [CZ](/docs/lang/cs/SQL.md) |
# Accessing messages in the database
## Decrypting databases
In order to view database data you need to decrypt it first. Install `sqlcipher` using your favorite package manager and run the following commands in the directory with databases:
```bash
sqlcipher files_chat.db
pragma key="youDecryptionPassphrase";
# Ensure it works fine
select * from users;
```
If you see `Parse error: no such table: users`, make sure you entered correct passphrase, and you have changed passphrase from random in Android app (if you got this database from Android device, of course).
## SQL queries
You can run queries against `direct_messages`, `group_messages` and `all_messages` (or their simpler alternatives `direct_messages_plain`, `group_messages_plain` and `all_messages_plain`), for example:
```sql
-- you can put these or your preferred settings into ~/.sqliterc
-- to persist across sqlite3 client sessions
.mode column
.headers on
.nullvalue NULL
-- simple views into direct, group and all_messages
-- with user's messages deduplicated for group and all_messages;
-- only 'x.msg.new' ("new message") chat events - filters out service events;
-- msg_sent is 0 for received, 1 for sent
select * from direct_messages_plain;
select * from group_messages_plain;
select * from all_messages_plain;
-- query other details of your chat history with regular SQL, for example:
-- files you offered for sending
select * from direct_messages where msg_sent = 1 and chat_msg_event = 'x.file';
-- everything catherine sent related to cats
select * from direct_messages where msg_sent = 0 and contact = 'catherine' and msg_body like '%cats%';
-- all correspondence with alice in #team
select * from group_messages where group_name = 'team' and contact = 'alice';
-- aggregate your chat data
select contact_or_group, num_messages from (
select
contact as contact_or_group, count(1) as num_messages
from direct_messages_plain group by contact
union
select
group_name as contact_or_group, count(1) as num_messages
from group_messages_plain group by group_name
)
order by num_messages desc;
```

13
docs/lang/cs/ANDROID.md
View File

@ -19,6 +19,7 @@ Pokud chcete zobrazit, co je uloženo v datovém adresáři SimpleX, musíte mí
- zařízení připojené přes USB nebo Wi-Fi k počítači.
## Postup:
- Otevřete SimpleX, přejděte na `Databáze passphrase & export`, povolte `Zálohování dat aplikace`. Tím se zprovozní další kroky
- _Volitelné_: pokud chcete zobrazit obsah databáze, změňte přístupovou frázi databáze z náhodné na svou. Chcete-li to provést, zastavte chat na obrazovce `Database passphrase & export`, otevřete `Database passphrase`, zadejte novou passphrase a potvrďte ji, poté ji aktualizujte. Nezapomeňte ji, jinak přijdete o všechna svá data v případě, že bude passphrase později znovu požadována.
- otevřete emulátor terminálu (Windows CMD/Powershell nebude fungovat) a změňte adresář na ten, který chcete použít pro uložení zálohy:
@ -42,4 +43,14 @@ Nyní budou zálohované soubory uvnitř `./apps/chat.simplex.app/`.
Upozorňujeme, že pokud používáte moderní verzi SimpleX, budou databáze zašifrované a jejich obsah nebudete moci zobrazit bez použití aplikace `sqlcipher` a bez znalosti dešifrovací fráze (musíte ji nejprve změnit na svou z náhodně vygenerovaných v aplikaci).
Další informace o tom, jak dešifrovat databáze a provádět dotazy do nich, najdete v příručce [SQL.md](./SQL.md).
## Dešifrování databází
Chcete-li zobrazit data v databázi, musíte je nejprve dešifrovat. Nainstalujte `sqlcipher` pomocí svého oblíbeného správce balíčků a v adresáři s databázemi spusťte následující příkazy:
```bash
sqlcipher files_chat.db
pragma key="youDecryptionPassphrase";
# Ujistěte se, že vše funguje správně
select * from users;
```
Pokud se zobrazí `Parse error: no such table: users`, ujistěte se, že jste zadali správnou přístupovou frázi a že jste ji v aplikaci pro Android změnili z náhodné (pokud jste tuto databázi získali ze zařízení s Androidem, samozřejmě).

34
docs/lang/cs/CLI.md
View File

@ -220,37 +220,3 @@ Uživatelská adresa je "dlouhodobá" v tom smyslu, že se jedná o odkaz pro v
Pro ostatní příkazy použijte `/help address`.
![simplex-chat](/images/user-addresses.gif)
### Přístup k historii chatu
SimpleX chat ukládá všechny vaše kontakty a konverzace do místní databáze SQLite, takže jsou soukromé a přenosné, vlastněné a kontrolované uživatelem.
Historii chatu můžete zobrazit a prohledávat dotazem do databáze. Spusťte níže uvedený skript pro vytvoření zobrazení zpráv ve vaší databázi.
```sh
curl -o- https://raw.githubusercontent.com/simplex-chat/simplex-chat/stable/scripts/message_views.sql | sqlite3 ~/.simplex/simplex_v1_chat.db
```
Otevřete SQLite Command Line Shell:
```sh
sqlite3 ~/.simplex/simplex_v1_chat.db
```
Příklady viz [Message queries](./SQL.md).
> **Upozornění:** Omezení cizích klíčů SQLite jsou ve výchozím nastavení vypnuta a musí být **[povolena pro každé připojení k databázi zvlášť](https://sqlite.org/foreignkeys.html#fk_enable)**. Toho lze dosáhnout spuštěním příkazu `PRAGMA foreign_keys = ON;` na otevřeném databázovém připojení. Spouštěním dotazů měnících data bez předchozího povolení cizích klíčů můžete riskovat, že se databáze dostane do nekonzistentního stavu.
**Pohodlné dotazy**
Získat všechny zprávy z dnešního dne (`chat_dt` je v UTC):
```sql
select * from all_messages_plain where date(chat_dt) > date('now', '-1 day') order by chat_dt;
```
Získejte ranní noční zprávy:
```sql
select * from all_messages_plain where chat_dt > datetime('now', '-15 hours') order by chat_dt;
```

59
docs/lang/cs/SQL.md
View File

@ -1,59 +0,0 @@
---
title: Přístup ke zprávám v databázi
revision: 31.01.2023
---
| Aktualizováno 31.01.2023 | Jazyky: CZ, [EN](/docs/SQL.md), [FR](/docs/lang/fr/SQL.md) |
# Přístup ke zprávám v databázi
## Dešifrování databází
Chcete-li zobrazit data v databázi, musíte je nejprve dešifrovat. Nainstalujte `sqlcipher` pomocí svého oblíbeného správce balíčků a v adresáři s databázemi spusťte následující příkazy:
```bash
sqlcipher files_chat.db
pragma key="youDecryptionPassphrase";
# Ujistěte se, že vše funguje správně
select * from users;
```
Pokud se zobrazí `Parse error: no such table: users`, ujistěte se, že jste zadali správnou přístupovou frázi a že jste ji v aplikaci pro Android změnili z náhodné (pokud jste tuto databázi získali ze zařízení s Androidem, samozřejmě).
## SQL dotazy
Můžete spouštět dotazy proti `direct_messages`, `group_messages` a `all_messages` (nebo jejich jednodušším alternativám `direct_messages_plain`, `group_messages_plain` a `all_messages_plain`), např:
```sql
-- tato nebo vámi preferovaná nastavení můžete vložit do souboru ~/.sqliterc
-- aby přetrvaly napříč relacemi klienta sqlite3
.mode column
.headers on
.nullvalue NULL
-- jednoduché pohledy na direct, group a all_messages
-- s deduplikací uživatelských zpráv pro group a all_messages;
-- pouze události chatu 'x.msg.new' ("nová zpráva") - filtruje události služby;
-- msg_sent je 0 pro přijaté, 1 pro odeslané
select * from direct_messages_plain;
select * from group_messages_plain;
select * from all_messages_plain;
-- dotaz na další podrobnosti historie chatu pomocí běžného SQL, například:
-- soubory, které jste nabídli k odeslání
select * from direct_messages where msg_sent = 1 and chat_msg_event = 'x.file';
-- vše, co catherine poslala v souvislosti s kočkami
select * from direct_messages where msg_sent = 0 and contact = 'catherine' and msg_body like '%cats%';
-- veškerá korespondence s alice v #teamu
select * from group_messages where group_name = 'team' and contact = 'alice';
-- shrňte data z chatu
select contact_or_group, num_messages from (
select
contact as contact_or_group, count(1) as num_messages
from direct_messages_plain group by contact
union
select
group_name as contact_or_group, count(1) as num_messages
from group_messages_plain group by group_name
)
order by num_messages desc;
```

13
docs/lang/fr/ANDROID.md
View File

@ -19,6 +19,7 @@ Si vous voulez voir ce qui est stocké dans le répertoire de données de Simple
- votre appareil connecté via USB ou Wi-Fi à l'ordinateur.
## La procédure :
- Ouvrez SimpleX, allez dans `Phrase secrète et exportation de la base de données`, activez `Sauvegarde des données de l'app`. Cela permettra aux autres étapes de fonctionner
- optionnel_ : si vous voulez voir le contenu de la base de données, changez la phrase secrète de la base de données aléatoire pour la vôtre. Pour ce faire, arrêtez le chat dans le menu "Phrase secrète et exportation de la base de données", ouvrez "Phrase secrète de la base de données", entrez la nouvelle phrase secrète et confirmez-la, puis mettez-la à jour. Ne l'oubliez pas, sinon vous perdrez toutes vos données au cas où la phrase d'authentification vous serait redemandée plus tard.
- ouvrez un émulateur de terminal (Windows CMD/Powershell ne fonctionnera pas) et changez de répertoire pour celui que vous voulez utiliser pour stocker la sauvegarde :
@ -42,4 +43,14 @@ Maintenant les fichiers sauvegardés seront dans `./apps/chat.simplex.app/`.
Veuillez noter que si vous utilisez une version récente de SimpleX, les bases de données seront chiffrées, et vous ne pourrez pas en voir le contenu sans utiliser l'application `sqlcipher` et sans connaître la phrase secrète de déchiffrement (vous devez d'abord la changer pour la vôtre à partir de celle qui est générée aléatoirement dans l'application).
Veuillez suivre le guide [SQL.md](/SQL.md) pour plus d'informations sur la manière de déchiffrer vos bases de données et d'y effectuer des requêtes.
## Déchiffrer les bases de données
Afin de visualiser les données de la base de données, vous devez d'abord les déchiffrer. Installez `sqlcipher` en utilisant votre gestionnaire de paquets préféré et exécutez les commandes suivantes dans le répertoire contenant les bases de données :
```bash
sqlcipher files_chat.db
pragma key="youDecryptionPassphrase";
# S'assurer qu'il fonctionne bien
select * from users;
```
Si vous voyez `Parse error : no such table : users`, assurez-vous que vous avez entré la bonne phrase secrète, et que vous avez changé la phrase secrète au hasard dans l'application Android (si vous avez obtenu cette base de données à partir d'un appareil Android, bien sûr).

34
docs/lang/fr/CLI.md
View File

@ -222,37 +222,3 @@ L'adresse de l'utilisateur est "à long terme" dans le sens où il s'agit d'un l
Utilisez `/help address` pour les autres commandes.
![simplex-chat](/images/user-addresses.gif)
### Accéder à l'historique des chats
SimpleX chat stocke tous vos contacts et conversations dans une base de données SQLite locale, ce qui la rend privée et portable par définition, appartenant et contrôlée par l'utilisateur.
Vous pouvez visualiser et rechercher votre historique de chat en interrogeant votre base de données. Exécutez le script ci-dessous pour créer des aperçus de messages dans votre base de données.
```sh
curl -o- https://raw.githubusercontent.com/simplex-chat/simplex-chat/stable/scripts/message_views.sql | sqlite3 ~/.simplex/simplex_v1_chat.db
```
Ouvrir un terminal de commande SQLite :
```sh
sqlite3 ~/.simplex/simplex_v1_chat.db
```
Voir les [requêtes de message](./SQL.md) à titre d'exemple.
> **Veuillez noter :** Les contraintes de clé étrangère SQLite sont désactivées par défaut, et doivent être **[activé séparément pour chaque connexion de base de données](https://sqlite.org/foreignkeys.html#fk_enable)**. Cette dernière peut être réalisée en exécutant la commande `PRAGMA foreign_keys = ON;` sur une connexion de base de données ouverte. En exécutant des requêtes modifiant les données sans activer les clés étrangères au préalable, vous risquez de mettre votre base de données dans un état inconsistant.
**Requêtes de commodité**
Pour recevoir tous les messages du jour (`chat_dt` est en UTC) :
```sql
select * from all_messages_plain where date(chat_dt) > date('now', '-1 day') order by chat_dt;
```
Pour recevoir les messages de la nuit dans la matinée :
```sql
select * from all_messages_plain where chat_dt > datetime('now', '-15 hours') order by chat_dt;
```

59
docs/lang/fr/SQL.md
View File

@ -1,59 +0,0 @@
---
title: Accès aux messages de la base de données
revision: 31.01.2023
---
| 31.01.2023 | FR, [EN](/docs/SQL.md), [CZ](/docs/lang/cs/SQL.md) |
# Accès aux messages de la base de données
## Déchiffrer les bases de données
Afin de visualiser les données de la base de données, vous devez d'abord les déchiffrer. Installez `sqlcipher` en utilisant votre gestionnaire de paquets préféré et exécutez les commandes suivantes dans le répertoire contenant les bases de données :
```bash
sqlcipher files_chat.db
pragma key="youDecryptionPassphrase";
# S'assurer qu'il fonctionne bien
select * from users;
```
Si vous voyez `Parse error : no such table : users`, assurez-vous que vous avez entré la bonne phrase secrète, et que vous avez changé la phrase secrète au hasard dans l'application Android (si vous avez obtenu cette base de données à partir d'un appareil Android, bien sûr).
# Requêtes SQL
Vous pouvez exécuter des requêtes `direct_messages`, `group_messages` et `all_messages` (ou leurs alternatives plus simples `direct_messages_plain`, `group_messages_plain` et `all_messages_plain`), par exemple :
```sql
-- vous pouvez mettre ces paramètres ou ceux que vous préférez dans ~/.sqliterc
-- pour maintenir les sessions du client sqlite3
.mode column
.headers on
.nullvalue NULL
-- vues simples pour direct, group et all_messages
-- avec les messages de l'utilisateur dédupliqués pour group et all_messages ;
-- seuls les événements de chat "x.msg.new" ("nouveau message") - filtre les événements de service ;
-- msg_sent est 0 pour reçu, 1 pour envoyé
select * from direct_messages_plain;
select * from group_messages_plain;
select * from all_messages_plain;
-- demander d'autres détails de votre historique de chat avec le SQL régulier, par exemple :
-- les fichiers que vous avez soumis pour l'envoi
select * from direct_messages where msg_sent = 1 and chat_msg_event = 'x.file';
-- tout ce que Catherine a envoyé lié aux chats
select * from direct_messages where msg_sent = 0 and contact = 'catherine' and msg_body like '%cats%';
-- toute correspondance avec alice dans #team
select * from group_messages where group_name = 'team' and contact = 'alice';
-- regrouper vos données de chat
select contact_or_group, num_messages from (
select
contact as contact_or_group, count(1) as num_messages
from direct_messages_plain group by contact
union
select
group_name as contact_or_group, count(1) as num_messages
from group_messages_plain group by group_name
)
order by num_messages desc;
```

110
scripts/message_views.sql
View File

@ -1,110 +0,0 @@
CREATE VIEW direct_messages AS
SELECT
ct.local_display_name AS contact,
m.message_id AS message_id,
m.msg_sent AS msg_sent,
m.chat_msg_event AS chat_msg_event,
m.msg_body AS msg_body,
md.msg_delivery_id AS delivery_id,
datetime(md.chat_ts) AS chat_dt,
md.agent_msg_meta AS msg_meta,
mde.delivery_status AS delivery_status,
datetime(mde.created_at) AS delivery_status_dt
FROM messages m
JOIN msg_deliveries md ON md.message_id = m.message_id
JOIN (
SELECT msg_delivery_id, MAX(created_at) MaxDate
FROM msg_delivery_events
GROUP BY msg_delivery_id
) MaxDates ON MaxDates.msg_delivery_id = md.msg_delivery_id
JOIN msg_delivery_events mde ON mde.msg_delivery_id = MaxDates.msg_delivery_id
AND mde.created_at = MaxDates.MaxDate
JOIN connections c ON c.connection_id = md.connection_id
JOIN contacts ct ON ct.contact_id = c.contact_id
ORDER BY chat_dt DESC;
CREATE VIEW direct_messages_plain AS
SELECT
dm.contact AS contact,
dm.msg_sent AS msg_sent,
dm.msg_body AS msg_body,
dm.chat_dt AS chat_dt
FROM direct_messages dm
WHERE dm.chat_msg_event = 'x.msg.new';
CREATE VIEW group_messages AS
SELECT
g.local_display_name AS group_name,
gm.local_display_name AS contact,
m.message_id AS message_id,
m.msg_sent AS msg_sent,
m.chat_msg_event AS chat_msg_event,
m.msg_body AS msg_body,
md.msg_delivery_id AS delivery_id,
datetime(md.chat_ts) AS chat_dt,
md.agent_msg_meta AS msg_meta,
mde.delivery_status AS delivery_status,
datetime(mde.created_at) AS delivery_status_dt
FROM messages m
JOIN msg_deliveries md ON md.message_id = m.message_id
JOIN (
SELECT msg_delivery_id, MAX(created_at) MaxDate
FROM msg_delivery_events
GROUP BY msg_delivery_id
) MaxDates ON MaxDates.msg_delivery_id = md.msg_delivery_id
JOIN msg_delivery_events mde ON mde.msg_delivery_id = MaxDates.msg_delivery_id
AND mde.created_at = MaxDates.MaxDate
JOIN connections c ON c.connection_id = md.connection_id
JOIN group_members gm ON gm.group_member_id = c.group_member_id
JOIN groups g ON g.group_id = gm.group_id
ORDER BY chat_dt DESC;
CREATE VIEW group_messages_plain AS
SELECT
gm.group_name AS group_name,
(CASE WHEN gm.msg_sent = 0 THEN gm.contact ELSE gm.group_name END) AS contact,
gm.msg_sent AS msg_sent,
gm.msg_body AS msg_body,
gm.chat_dt AS chat_dt
FROM group_messages gm
JOIN (
SELECT message_id, MIN(delivery_id) MinDeliveryId
FROM group_messages
GROUP BY message_id
) Deduplicated ON Deduplicated.message_id = gm.message_id
AND Deduplicated.MinDeliveryId = gm.delivery_id
WHERE gm.chat_msg_event = 'x.msg.new';
CREATE VIEW all_messages (
group_name,
contact,
message_id,
msg_sent,
chat_msg_event,
msg_body,
delivery_id,
chat_dt,
msg_meta,
delivery_status,
delivery_status_dt
) AS
SELECT * FROM (
SELECT NULL AS group_name, * FROM direct_messages
UNION
SELECT * FROM group_messages
)
ORDER BY chat_dt DESC;
CREATE VIEW all_messages_plain (
group_name,
contact,
msg_sent,
msg_body,
chat_dt
) AS
SELECT * FROM (
SELECT NULL AS group_name, * FROM direct_messages_plain
UNION
SELECT * FROM group_messages_plain
)
ORDER BY chat_dt DESC;

2
scripts/nix/sha256map.nix
View File

@ -1,5 +1,5 @@
{
"https://github.com/simplex-chat/simplexmq.git"."1e15d56e92c0549c7ba6a60d2c9d557b2949b0ff" = "1miy6452py1hbf5d1z1zq3krx8b1fncix8xvzgpxxyfw8qq0gw4b";
"https://github.com/simplex-chat/simplexmq.git"."577e3cf14d3c1e6cb6a45b987ca934ed793dac26" = "1dgx4qb2ha3mp1jj5h7ff3pd4bzyjxm1jh36pnz0psp1z23m3s19";
"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";

363
src/Simplex/Chat.hs
View File

@ -275,28 +275,28 @@ newChatController
logFilePath = logFile,
contactMergeEnabled
}
where
configServers :: DefaultAgentServers
configServers =
let smp' = fromMaybe (smp (defaultServers :: DefaultAgentServers)) (nonEmpty smpServers)
xftp' = fromMaybe (xftp (defaultServers :: DefaultAgentServers)) (nonEmpty xftpServers)
in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig}
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
pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg}
where
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ProtoServerWithAuth p)))
getUserServers users protocol = case users of
[] -> pure $ M.fromList [(1, cfgServers protocol defServers)]
_ -> M.fromList <$> initialServers
where
initialServers :: IO [(UserId, NonEmpty (ProtoServerWithAuth p))]
initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users
userServers :: User -> IO (NonEmpty (ProtoServerWithAuth p))
userServers user' = activeAgentServers config protocol <$> withTransaction chatStore (`getProtocolServers` user')
where
configServers :: DefaultAgentServers
configServers =
let smp' = fromMaybe (smp (defaultServers :: DefaultAgentServers)) (nonEmpty smpServers)
xftp' = fromMaybe (xftp (defaultServers :: DefaultAgentServers)) (nonEmpty xftpServers)
in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig}
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
pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg}
where
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ProtoServerWithAuth p)))
getUserServers users protocol = case users of
[] -> pure $ M.fromList [(1, cfgServers protocol defServers)]
_ -> M.fromList <$> initialServers
where
initialServers :: IO [(UserId, NonEmpty (ProtoServerWithAuth p))]
initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users
userServers :: User -> IO (NonEmpty (ProtoServerWithAuth p))
userServers user' = activeAgentServers config protocol <$> withTransaction chatStore (`getProtocolServers` user')
activeAgentServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ProtoServerWithAuth p)
activeAgentServers ChatConfig {defaultServers} p =
@ -355,11 +355,12 @@ startChatController subConns enableExpireCIs startXFTPWorkers = do
subscribeUsers :: forall m. ChatMonad' m => Bool -> [User] -> m ()
subscribeUsers onlyNeeded users = do
let (us, us') = partition activeUser users
subscribe us
subscribe us'
vr <- chatVersionRange
subscribe vr us
subscribe vr us'
where
subscribe :: [User] -> m ()
subscribe = mapM_ $ runExceptT . subscribeUserConnections onlyNeeded Agent.subscribeConnections
subscribe :: VersionRange -> [User] -> m ()
subscribe vr = mapM_ $ runExceptT . subscribeUserConnections vr onlyNeeded Agent.subscribeConnections
startFilesToReceive :: forall m. ChatMonad' m => [User] -> m ()
startFilesToReceive users = do
@ -436,7 +437,11 @@ parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
-- | Chat API commands interpreted in context of a local zone
processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse
processChatCommand = \case
processChatCommand cmd = chatVersionRange >>= (`processChatCommand'` cmd)
{-# INLINE processChatCommand #-}
processChatCommand' :: forall m. ChatMonad m => VersionRange -> ChatCommand -> m ChatResponse
processChatCommand' vr = \case
ShowActiveUser -> withUser' $ pure . CRActiveUser
CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do
forM_ profile $ \Profile {displayName} -> checkValidName displayName
@ -606,7 +611,7 @@ processChatCommand = \case
. M.assocs
<$> withConnection st (readTVarIO . DB.slow)
APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db user pendingConnections pagination query)
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db vr user pendingConnections pagination query)
unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRApiChats user previews
APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of
@ -615,16 +620,16 @@ processChatCommand = \case
directChat <- withStore (\db -> getDirectChat db user cId pagination search)
pure $ CRApiChat user (AChat SCTDirect directChat)
CTGroup -> do
groupChat <- withStore (\db -> getGroupChat db user cId pagination search)
groupChat <- withStore (\db -> getGroupChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTGroup groupChat)
CTContactRequest -> pure $ chatCmdError (Just user) "not implemented"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIGetChatItems pagination search -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user pagination search
chatItems <- withStore $ \db -> getAllChatItems db vr user pagination search
pure $ CRChatItems user Nothing chatItems
APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do
(aci@(AChatItem cType dir _ ci), versions) <- withStore $ \db ->
(,) <$> getAChatItem db user chatRef itemId <*> liftIO (getChatItemVersions db itemId)
(,) <$> getAChatItem db vr user chatRef itemId <*> liftIO (getChatItemVersions db itemId)
let itemVersions = if null versions then maybeToList $ mkItemVersion ci else versions
memberDeliveryStatuses <- case (cType, dir) of
(SCTGroup, SMDSnd) -> do
@ -698,7 +703,7 @@ processChatCommand = \case
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
quoteData _ = throwChatError CEInvalidQuote
CTGroup -> do
g@(Group gInfo _) <- withStore $ \db -> getGroup db user chatId
g@(Group gInfo _) <- withStore $ \db -> getGroup db vr user chatId
assertUserGroupRole gInfo GRAuthor
send g
where
@ -803,7 +808,7 @@ processChatCommand = \case
_ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
CTGroup -> do
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db user chatId
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db vr user chatId
assertUserGroupRole gInfo GRAuthor
cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId
case cci of
@ -839,7 +844,7 @@ processChatCommand = \case
else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
CTGroup -> do
Group gInfo ms <- withStore $ \db -> getGroup db user chatId
Group gInfo ms <- withStore $ \db -> getGroup db vr user chatId
CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}} <- withStore $ \db -> getGroupChatItem db user chatId itemId
case (mode, msgDir, itemSharedMsgId, editable) of
(CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime
@ -851,7 +856,7 @@ processChatCommand = \case
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do
Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db user gId
Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db vr user gId
CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withStore $ \db -> getGroupChatItem db user gId itemId
case (chatDir, itemSharedMsgId) of
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do
@ -880,7 +885,7 @@ processChatCommand = \case
pure $ CRChatItemReaction user add r
_ -> throwChatError $ CECommandError "reaction not possible - no shared item ID"
CTGroup ->
withStore (\db -> (,) <$> getGroup db user chatId <*> getGroupChatItem db user chatId itemId) >>= \case
withStore (\db -> (,) <$> getGroup db vr user chatId <*> getGroupChatItem db user chatId itemId) >>= \case
(Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do
unless (groupFeatureAllowed SGFReactions g) $
throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions))
@ -939,7 +944,7 @@ processChatCommand = \case
ok user
CTGroup -> do
withStore $ \db -> do
Group {groupInfo} <- getGroup db user chatId
Group {groupInfo} <- getGroup db vr user chatId
liftIO $ updateGroupUnreadChat db user groupInfo unreadChat
ok user
_ -> pure $ chatCmdError (Just user) "not supported"
@ -964,7 +969,7 @@ processChatCommand = \case
withStore' $ \db -> deletePendingContactConnection db userId chatId
pure $ CRContactConnectionDeleted user conn
CTGroup -> do
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user chatId
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user chatId
let isOwner = memberRole (membership :: GroupMember) == GROwner
canDelete = isOwner || not (memberCurrent membership)
unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
@ -1007,7 +1012,7 @@ processChatCommand = \case
withStore' $ \db -> deleteContactCIs db user ct
pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct)
CTGroup -> do
gInfo <- withStore $ \db -> getGroupInfo db user chatId
gInfo <- withStore $ \db -> getGroupInfo db vr user chatId
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
deleteFilesAndConns user filesInfo
withStore' $ \db -> deleteGroupCIs db user gInfo
@ -1151,7 +1156,7 @@ processChatCommand = \case
user_ <- withStore' (`getUserByAConnId` agentConnId)
connEntity_ <-
pure user_ $>>= \user ->
withStore (\db -> Just <$> getConnectionEntity db user agentConnId) `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing)
withStore (\db -> Just <$> getConnectionEntity db vr user agentConnId) `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing)
pure CRNtfMessages {user_, connEntity_, msgTs = msgTs', ntfMessages = map ntfMsgInfo msgs}
APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
ChatConfig {defaultServers} <- asks config
@ -1214,7 +1219,7 @@ processChatCommand = \case
ok user
CTGroup -> do
ms <- withStore $ \db -> do
Group _ ms <- getGroup db user chatId
Group _ ms <- getGroup db vr user chatId
liftIO $ updateGroupSettings db user chatId chatSettings
pure ms
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
@ -1240,10 +1245,10 @@ processChatCommand = \case
connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct)
pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile)
APIGroupInfo gId -> withUser $ \user -> do
(g, s) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> liftIO (getGroupSummary db user gId)
(g, s) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> liftIO (getGroupSummary db user gId)
pure $ CRGroupInfo user g s
APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m)
pure $ CRGroupMemberInfo user g m connectionStats
APISwitchContact contactId -> withUser $ \user -> do
@ -1254,7 +1259,7 @@ processChatCommand = \case
pure $ CRContactSwitchStarted user ct connectionStats
Nothing -> throwChatError $ CEContactNotActive ct
APISwitchGroupMember gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
case memberConnId m of
Just connId -> do
connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId)
@ -1268,7 +1273,7 @@ processChatCommand = \case
pure $ CRContactSwitchAborted user ct connectionStats
Nothing -> throwChatError $ CEContactNotActive ct
APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
case memberConnId m of
Just connId -> do
connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId
@ -1283,7 +1288,7 @@ processChatCommand = \case
pure $ CRContactRatchetSyncStarted user ct cStats
Nothing -> throwChatError $ CEContactNotActive ct
APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> withChatLock "syncGroupMemberRatchet" $ do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
case memberConnId m of
Just connId -> do
cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force
@ -1305,7 +1310,7 @@ processChatCommand = \case
pure $ CRContactCode user ct' code
Nothing -> throwChatError $ CEContactNotActive ct
APIGetGroupMemberCode gId gMemberId -> withUser $ \user -> do
(g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
case activeConn of
Just conn@Connection {connId} -> do
code <- getConnectionCode $ aConnId conn
@ -1487,7 +1492,7 @@ processChatCommand = \case
let chatRef = ChatRef CTDirect ctId
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc
Left _ ->
withStore' (\db -> runExceptT $ getActiveMembersByName db user name) >>= \case
withStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case
Right [(gInfo, member)] -> do
let GroupInfo {localDisplayName = gName} = gInfo
GroupMember {localDisplayName = mName} = member
@ -1507,7 +1512,7 @@ processChatCommand = \case
let mc = MCText msg
case memberContactId m of
Nothing -> do
gInfo <- withStore $ \db -> getGroupInfo db user gId
gInfo <- withStore $ \db -> getGroupInfo db vr user gId
toView $ CRNoMemberContactCreating user gInfo m
processChatCommand (APICreateMemberContact gId mId) >>= \case
cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do
@ -1567,13 +1572,13 @@ processChatCommand = \case
gVar <- asks random
-- [incognito] generate incognito profile for group membership
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
groupInfo <- withStore $ \db -> createNewGroup db gVar user gProfile incognitoProfile
groupInfo <- withStore $ \db -> createNewGroup db vr gVar user gProfile incognitoProfile
pure $ CRGroupCreated user groupInfo
NewGroup incognito gProfile -> withUser $ \User {userId} ->
processChatCommand $ APINewGroup userId incognito gProfile
APIAddMember groupId contactId memRole -> withUser $ \user -> withChatLock "addMember" $ do
-- TODO for large groups: no need to load all members to determine if contact is a member
(group, contact) <- withStore $ \db -> (,) <$> getGroup db user groupId <*> getContact db user contactId
(group, contact) <- withStore $ \db -> (,) <$> getGroup db vr user groupId <*> getContact db user contactId
assertDirectAllowed user MDSnd contact XGrpInv_
let Group gInfo members = group
Contact {localDisplayName = cName} = contact
@ -1603,7 +1608,7 @@ processChatCommand = \case
APIJoinGroup groupId -> withUser $ \user@User {userId} -> do
withChatLock "joinGroup" . procCmd $ do
(invitation, ct) <- withStore $ \db -> do
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db user groupId
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId
(inv,) <$> getContactViaMember db user fromMember
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
Contact {activeConn} = ct
@ -1621,14 +1626,14 @@ processChatCommand = \case
Nothing -> throwChatError $ CEContactNotActive ct
where
updateCIGroupInvitationStatus user = do
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db user groupId
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db vr user groupId
case (cInfo, content) of
(DirectChat ct, CIRcvGroupInvitation ciGroupInv memRole) -> do
let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = CIGISAccepted} memRole
updateDirectChatItemView user ct itemId aciContent False Nothing
_ -> pure () -- prohibited
APIMemberRole groupId memberId memRole -> withUser $ \user -> do
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId
if memberId == groupMemberId' membership
then changeMemberRole user gInfo members membership $ SGEUserRole memRole
else case find ((== memberId) . groupMemberId') members of
@ -1652,7 +1657,7 @@ processChatCommand = \case
toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole}
APIRemoveMember groupId memberId -> withUser $ \user -> do
Group gInfo members <- withStore $ \db -> getGroup db user groupId
Group gInfo members <- withStore $ \db -> getGroup db vr user groupId
case find ((== memberId) . groupMemberId') members of
Nothing -> throwChatError CEGroupMemberNotFound
Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do
@ -1671,7 +1676,7 @@ processChatCommand = \case
deleteOrUpdateMemberRecord user m
pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved}
APILeaveGroup groupId -> withUser $ \user@User {userId} -> do
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId
withChatLock "leaveGroup" . procCmd $ do
(msg, _) <- sendGroupMessage user gInfo members XGrpLeave
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft)
@ -1683,7 +1688,7 @@ processChatCommand = \case
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft
pure $ CRLeftMemberUser user gInfo {membership = membership {memberStatus = GSMemLeft}}
APIListMembers groupId -> withUser $ \user ->
CRGroupMembers user <$> withStore (\db -> getGroup db user groupId)
CRGroupMembers user <$> withStore (\db -> getGroup db vr user groupId)
AddMember gName cName memRole -> withUser $ \user -> do
(groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName
processChatCommand $ APIAddMember groupId contactId memRole
@ -1705,23 +1710,23 @@ processChatCommand = \case
groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIListMembers groupId
APIListGroups userId contactId_ search_ -> withUserId userId $ \user ->
CRGroupsList user <$> withStore' (\db -> getUserGroupsWithSummary db user contactId_ search_)
CRGroupsList user <$> withStore' (\db -> getUserGroupsWithSummary db vr user contactId_ search_)
ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do
ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName
processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_
APIUpdateGroupProfile groupId p' -> withUser $ \user -> do
g <- withStore $ \db -> getGroup db user groupId
g <- withStore $ \db -> getGroup db vr user groupId
runUpdateGroupProfile user g p'
UpdateGroupNames gName GroupProfile {displayName, fullName} ->
updateGroupProfileByName gName $ \p -> p {displayName, fullName}
ShowGroupProfile gName -> withUser $ \user ->
CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db user gName)
CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db vr user gName)
UpdateGroupDescription gName description ->
updateGroupProfileByName gName $ \p -> p {description}
ShowGroupDescription gName -> withUser $ \user ->
CRGroupDescription user <$> withStore (\db -> getGroupInfoByName db user gName)
CRGroupDescription user <$> withStore (\db -> getGroupInfoByName db vr user gName)
APICreateGroupLink groupId mRole -> withUser $ \user -> withChatLock "createGroupLink" $ do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
assertUserGroupRole gInfo GRAdmin
when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
@ -1731,22 +1736,22 @@ processChatCommand = \case
withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode
pure $ CRGroupLinkCreated user gInfo cReq mRole
APIGroupLinkMemberRole groupId mRole' -> withUser $ \user -> withChatLock "groupLinkMemberRole " $ do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
(groupLinkId, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
assertUserGroupRole gInfo GRAdmin
when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole'
when (mRole' /= mRole) $ withStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole'
pure $ CRGroupLink user gInfo groupLink mRole'
APIDeleteGroupLink groupId -> withUser $ \user -> withChatLock "deleteGroupLink" $ do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
deleteGroupLink' user gInfo
pure $ CRGroupLinkDeleted user gInfo
APIGetGroupLink groupId -> withUser $ \user -> do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
(_, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
pure $ CRGroupLink user gInfo groupLink mRole
APICreateMemberContact gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
assertUserGroupRole g GRAuthor
unless (groupFeatureAllowed SGFDirectMessages g) $ throwChatError $ CECommandError "direct messages not allowed"
case memberConn m of
@ -1762,7 +1767,7 @@ processChatCommand = \case
pure $ CRNewMemberContact user ct g m
_ -> throwChatError CEGroupMemberNotActive
APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do
(g, m, ct, cReq) <- withStore $ \db -> getMemberContact db user contactId
(g, m, ct, cReq) <- withStore $ \db -> getMemberContact db vr user contactId
when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent"
case memberConn m of
Just mConn -> do
@ -1794,7 +1799,7 @@ processChatCommand = \case
processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc
LastChats count_ -> withUser' $ \user -> do
let count = fromMaybe 5000 count_
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db user False (PTLast count) clqNoFilters)
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db vr user False (PTLast count) clqNoFilters)
unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRChats previews
LastMessages (Just chatName) count search -> withUser $ \user -> do
@ -1802,22 +1807,22 @@ processChatCommand = \case
chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search
pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp)
LastMessages Nothing count search -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast count) search
chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast count) search
pure $ CRChatItems user Nothing chatItems
LastChatItemId (Just chatName) index -> withUser $ \user -> do
chatRef <- getChatRef user chatName
chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing)
pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp)
LastChatItemId Nothing index -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast $ index + 1) Nothing
chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast $ index + 1) Nothing
pure $ CRChatItemId user (fmap aChatItemId . listToMaybe $ chatItems)
ShowChatItem (Just itemId) -> withUser $ \user -> do
chatItem <- withStore $ \db -> do
chatRef <- getChatRefViaItemId db user itemId
getAChatItem db user chatRef itemId
getAChatItem db vr user chatRef itemId
pure $ CRChatItems user Nothing ((: []) chatItem)
ShowChatItem Nothing -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast 1) Nothing
chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast 1) Nothing
pure $ CRChatItems user Nothing chatItems
ShowChatItemInfo chatName msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName
@ -1859,19 +1864,19 @@ processChatCommand = \case
| not (null fts) && all fileCancelledOrCompleteSMP fts ->
throwChatError $ CEFileCancel fileId "file transfer is complete"
| otherwise -> do
fileAgentConnIds <- cancelSndFile user ftm fts True
deleteAgentConnectionsAsync user fileAgentConnIds
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
withStore (\db -> getChatRefByFileId db user fileId) >>= \case
ChatRef CTDirect contactId -> do
contact <- withStore $ \db -> getContact db user contactId
void . sendDirectContactMessage contact $ XFileCancel sharedMsgId
ChatRef CTGroup groupId -> do
Group gInfo ms <- withStore $ \db -> getGroup db user groupId
void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
ci <- withStore $ \db -> getChatItemByFileId db user fileId
pure $ CRSndFileCancelled user ci ftm fts
fileAgentConnIds <- cancelSndFile user ftm fts True
deleteAgentConnectionsAsync user fileAgentConnIds
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
withStore (\db -> getChatRefByFileId db user fileId) >>= \case
ChatRef CTDirect contactId -> do
contact <- withStore $ \db -> getContact db user contactId
void . sendDirectContactMessage contact $ XFileCancel sharedMsgId
ChatRef CTGroup groupId -> do
Group gInfo ms <- withStore $ \db -> getGroup db vr user groupId
void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
pure $ CRSndFileCancelled user ci ftm fts
where
fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} =
s == FSCancelled || (s == FSComplete && isNothing xftpSndFile)
@ -1879,25 +1884,25 @@ processChatCommand = \case
| cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled"
| rcvFileComplete fileStatus -> throwChatError $ CEFileCancel fileId "file transfer is complete"
| otherwise -> case xftpRcvFile of
Nothing -> do
cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user)
ci <- withStore $ \db -> getChatItemByFileId db user fileId
pure $ CRRcvFileCancelled user ci ftr
Just XFTPRcvFile {agentRcvFileId} -> do
forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do
fsFilePath <- toFSFilePath filePath
liftIO $ removeFile fsFilePath `catchAll_` pure ()
forM_ agentRcvFileId $ \(AgentRcvFileId aFileId) ->
withAgent (`xftpDeleteRcvFile` aFileId)
ci <- withStore $ \db -> do
liftIO $ do
updateCIFileStatus db user fileId CIFSRcvInvitation
updateRcvFileStatus db fileId FSNew
updateRcvFileAgentId db fileId Nothing
getChatItemByFileId db user fileId
pure $ CRRcvFileCancelled user ci ftr
Nothing -> do
cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user)
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
pure $ CRRcvFileCancelled user ci ftr
Just XFTPRcvFile {agentRcvFileId} -> do
forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do
fsFilePath <- toFSFilePath filePath
liftIO $ removeFile fsFilePath `catchAll_` pure ()
forM_ agentRcvFileId $ \(AgentRcvFileId aFileId) ->
withAgent (`xftpDeleteRcvFile` aFileId)
ci <- withStore $ \db -> do
liftIO $ do
updateCIFileStatus db user fileId CIFSRcvInvitation
updateRcvFileStatus db fileId FSNew
updateRcvFileAgentId db fileId Nothing
getChatItemByFileId db vr user fileId
pure $ CRRcvFileCancelled user ci ftr
FileStatus fileId -> withUser $ \user -> do
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> getChatItemByFileId db user fileId
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> getChatItemByFileId db vr user fileId
case file of
Just CIFile {fileProtocol = FPXFTP} ->
pure $ CRFileTransferStatusXFTP user ci
@ -2198,7 +2203,7 @@ processChatCommand = \case
updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse
updateGroupProfileByName gName update = withUser $ \user -> do
g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db ->
getGroupIdByName db user gName >>= getGroup db user
getGroupIdByName db user gName >>= getGroup db vr user
runUpdateGroupProfile user g $ update p
withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
withCurrentCall ctId action = do
@ -2313,15 +2318,16 @@ processChatCommand = \case
ctId <- getContactIdByName db user name
Contact {chatSettings} <- getContact db user ctId
pure (ctId, chatSettings)
CTGroup -> withStore $ \db -> do
gId <- getGroupIdByName db user name
GroupInfo {chatSettings} <- getGroupInfo db user gId
pure (gId, chatSettings)
CTGroup ->
withStore $ \db -> do
gId <- getGroupIdByName db user name
GroupInfo {chatSettings} <- getGroupInfo db vr user gId
pure (gId, chatSettings)
_ -> throwChatError $ CECommandError "not supported"
processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings
connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan
connectPlan user (ACR SCMInvitation cReq) = do
withStore' (\db -> getConnectionEntityByConnReq db user cReqSchemas) >>= \case
withStore' (\db -> getConnectionEntityByConnReq db vr user cReqSchemas) >>= \case
Nothing -> pure $ CPInvitationLink ILPOk
Just (RcvDirectMsgConnection conn ct_) -> do
let Connection {connStatus, contactConnInitiated} = conn
@ -2351,7 +2357,7 @@ processChatCommand = \case
withStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case
Just _ -> pure $ CPContactAddress CAPOwnLink
Nothing ->
withStore' (\db -> getContactConnEntityByConnReqHash db user cReqHashes) >>= \case
withStore' (\db -> getContactConnEntityByConnReqHash db vr user cReqHashes) >>= \case
Nothing ->
withStore' (\db -> getContactWithoutConnViaAddress db user cReqSchemas) >>= \case
Nothing -> pure $ CPContactAddress CAPOk
@ -2364,11 +2370,11 @@ processChatCommand = \case
Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
-- group link
Just _ ->
withStore' (\db -> getGroupInfoByUserContactLinkConnReq db user cReqSchemas) >>= \case
withStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case
Just g -> pure $ CPGroupLink (GLPOwnLink g)
Nothing -> do
connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db user cReqHashes
gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db user cReqHashes
connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes
gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes
case (gInfo_, connEnt_) of
(Nothing, Nothing) -> pure $ CPGroupLink GLPOk
(Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> pure $ CPGroupLink GLPConnectingConfirmReconnect
@ -2599,6 +2605,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
unless (fileStatus == RFSNew) $ case fileStatus of
RFSCancelled _ -> throwChatError $ CEFileCancelled fName
_ -> throwChatError $ CEFileAlreadyReceiving fName
vr <- chatVersionRange
case (xftpRcvFile, fileConnReq) of
-- direct file protocol
(Nothing, Just connReq) -> do
@ -2606,14 +2613,14 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
dm <- directMessage $ XFileAcpt fName
connIds <- joinAgentConnectionAsync user True connReq dm subMode
filePath <- getRcvFilePath fileId filePath_ fName True
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath subMode
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db vr user fileId connIds ConnJoined filePath subMode
-- XFTP
(Just XFTPRcvFile {}, _) -> do
filePath <- getRcvFilePath fileId filePath_ fName False
(ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do
-- marking file as accepted and reading description in the same transaction
-- to prevent race condition with appending description
ci <- xftpAcceptRcvFT db user fileId filePath
ci <- xftpAcceptRcvFT db vr user fileId filePath
rfd <- getRcvFileDescrByRcvFileId db fileId
pure (ci, rfd)
receiveViaCompleteFD user fileId rfd cryptoArgs
@ -2637,10 +2644,11 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
acceptFile cmdFunction send = do
filePath <- getRcvFilePath fileId filePath_ fName True
inline <- receiveInline
vr <- chatVersionRange
if
| inline -> do
-- accepting inline
ci <- withStoreCtx (Just "acceptFile, acceptRcvInlineFT") $ \db -> acceptRcvInlineFT db user fileId filePath
ci <- withStoreCtx (Just "acceptFile, acceptRcvInlineFT") $ \db -> acceptRcvInlineFT db vr user fileId filePath
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
send $ XFileAcptInv sharedMsgId Nothing fName
pure ci
@ -2649,7 +2657,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
-- accepting via a new connection
subMode <- chatReadVar subscriptionMode
connIds <- createAgentConnectionAsync user cmdFunction True SCMInvitation subMode
withStoreCtx (Just "acceptFile, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnNew filePath subMode
withStoreCtx (Just "acceptFile, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db vr user fileId connIds ConnNew filePath subMode
receiveInline :: m Bool
receiveInline = do
ChatConfig {fileChunkSize, inlineFiles = InlineFilesConfig {receiveChunks, offerChunks}} <- asks config
@ -2670,10 +2678,11 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
startReceivingFile :: ChatMonad m => User -> FileTransferId -> m ()
startReceivingFile user fileId = do
vr <- chatVersionRange
ci <- withStoreCtx (Just "startReceivingFile, updateRcvFileStatus ...") $ \db -> do
liftIO $ updateRcvFileStatus db fileId FSConnected
liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
toView $ CRRcvFileStart user ci
getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> Bool -> m FilePath
@ -2789,14 +2798,14 @@ agentSubscriber = do
type AgentBatchSubscribe m = AgentClient -> [ConnId] -> ExceptT AgentErrorType m (Map ConnId (Either AgentErrorType ()))
subscribeUserConnections :: forall m. ChatMonad m => Bool -> AgentBatchSubscribe m -> User -> m ()
subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
subscribeUserConnections :: forall m. ChatMonad m => VersionRange -> Bool -> AgentBatchSubscribe m -> User -> m ()
subscribeUserConnections vr onlyNeeded agentBatchSubscribe user@User {userId} = do
-- get user connections
ce <- asks $ subscriptionEvents . config
(conns, cts, ucs, gs, ms, sfts, rfts, pcs) <-
if onlyNeeded
then do
(conns, entities) <- withStore' getConnectionsToSubscribe
(conns, entities) <- withStore' (`getConnectionsToSubscribe` vr)
let (cts, ucs, ms, sfts, rfts, pcs) = foldl' addEntity (M.empty, M.empty, M.empty, M.empty, M.empty, M.empty) entities
pure (conns, cts, ucs, [], ms, sfts, rfts, pcs)
else do
@ -2846,7 +2855,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
getContactConns :: m ([ConnId], Map ConnId Contact)
getContactConns = do
cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") getUserContacts
let connIds = catMaybes $ map contactConnId (filter contactActive cts)
let connIds = mapMaybe contactConnId (filter contactActive cts)
pure (connIds, M.fromList $ zip connIds cts)
getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact)
getUserContactLinkConns = do
@ -2855,7 +2864,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
pure (connIds, M.fromList $ zip connIds ucs)
getGroupMemberConns :: m ([Group], [ConnId], Map ConnId GroupMember)
getGroupMemberConns = do
gs <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserGroups") getUserGroups
gs <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserGroups") (`getUserGroups` vr)
let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) (filter (not . memberRemoved) ms)) gs
pure (gs, map fst mPairs, M.fromList mPairs)
getSndFileTransferConns :: m ([ConnId], Map ConnId SndFileTransfer)
@ -3030,12 +3039,13 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do
ts <- liftIO getCurrentTime
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts
waitChatStarted
vr <- chatVersionRange
case cType of
CTDirect -> do
(ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
deleteDirectCI user ct ci True True >>= toView
CTGroup -> do
(gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId
(gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId
deletedTs <- liftIO getCurrentTime
deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView
_ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType"
@ -3050,12 +3060,13 @@ startUpdatedTimedItemThread user chatRef ci ci' =
expireChatItems :: forall m. ChatMonad m => User -> Int64 -> Bool -> m ()
expireChatItems user@User {userId} ttl sync = do
currentTs <- liftIO getCurrentTime
vr <- chatVersionRange
let expirationDate = addUTCTime (-1 * fromIntegral ttl) currentTs
-- this is to keep group messages created during last 12 hours even if they're expired according to item_ts
createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs
contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user)
loop contacts $ processContact expirationDate
groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (\db -> getUserGroupDetails db user Nothing Nothing)
groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (\db -> getUserGroupDetails db vr user Nothing Nothing)
loop groups $ processGroup expirationDate createdAtCutoff
where
loop :: [a] -> (a -> m ()) -> m ()
@ -3089,9 +3100,10 @@ processAgentMessage _ connId (DEL_RCVQ srv qId err_) =
toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_
processAgentMessage _ connId DEL_CONN =
toView $ CRAgentConnDeleted (AgentConnId connId)
processAgentMessage corrId connId msg =
processAgentMessage corrId connId msg = do
vr <- chatVersionRange
withStore' (`getUserByAConnId` AgentConnId connId) >>= \case
Just user -> processAgentMessageConn user corrId connId msg `catchChatError` (toView . CRChatError (Just user))
Just user -> processAgentMessageConn vr user corrId connId msg `catchChatError` (toView . CRChatError (Just user))
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone -> m ()
@ -3128,17 +3140,18 @@ processAgentMsgSndFile _corrId aFileId msg =
(ft@FileTransferMeta {fileId, cancelled}, sfts) <- withStore $ \db -> do
fileId <- getXFTPSndFileDBId db user $ AgentSndFileId aFileId
getSndFileTransfer db user fileId
vr <- chatVersionRange
unless cancelled $ case msg of
SFPROG sndProgress sndTotal -> do
let status = CIFSSndTransfer {sndProgress, sndTotal}
ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId status
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal
SFDONE sndDescr rfds -> do
withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
ci@(AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) <-
withStore $ \db -> getChatItemByFileId db user fileId
withStore $ \db -> getChatItemByFileId db vr user fileId
case (msgId_, itemDeleted) of
(Just sharedMsgId, Nothing) -> do
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
@ -3158,7 +3171,7 @@ processAgentMsgSndFile _corrId aFileId msg =
forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchChatError` (toView . CRChatError (Just user))
ci' <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
withAgent (`xftpDeleteSndFileInternal` aFileId)
toView $ CRSndFileCompleteXFTP user ci' ft
where
@ -3180,11 +3193,11 @@ processAgentMsgSndFile _corrId aFileId msg =
| temporaryAgentError e ->
throwChatError $ CEXFTPSndFile fileId (AgentSndFileId aFileId) e
| otherwise -> do
ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId CIFSSndError
getChatItemByFileId db user fileId
withAgent (`xftpDeleteSndFileInternal` aFileId)
toView $ CRSndFileError user ci
ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId CIFSSndError
getChatItemByFileId db vr user fileId
withAgent (`xftpDeleteSndFileInternal` aFileId)
toView $ CRSndFileError user ci
where
fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text
fileDescrText = safeDecodeUtf8 . strEncode
@ -3229,12 +3242,13 @@ processAgentMsgRcvFile _corrId aFileId msg =
ft@RcvFileTransfer {fileId} <- withStore $ \db -> do
fileId <- getXFTPRcvFileDBId db $ AgentRcvFileId aFileId
getRcvFileTransfer db user fileId
vr <- chatVersionRange
unless (rcvFileCompleteOrCancelled ft) $ case msg of
RFPROG rcvProgress rcvTotal -> do
let status = CIFSRcvTransfer {rcvProgress, rcvTotal}
ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId status
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal
RFDONE xftpPath ->
case liveRcvFileTransferPath ft of
@ -3246,22 +3260,22 @@ processAgentMsgRcvFile _corrId aFileId msg =
liftIO $ do
updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
agentXFTPDeleteRcvFile aFileId fileId
toView $ CRRcvFileComplete user ci
RFERR e
| temporaryAgentError e ->
throwChatError $ CEXFTPRcvFile fileId (AgentRcvFileId aFileId) e
| otherwise -> do
ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId CIFSRcvError
getChatItemByFileId db user fileId
agentXFTPDeleteRcvFile aFileId fileId
toView $ CRRcvFileError user ci e
ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId CIFSRcvError
getChatItemByFileId db vr user fileId
agentXFTPDeleteRcvFile aFileId fileId
toView $ CRRcvFileError user ci e
processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
entity <- withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= updateConnStatus
processAgentMessageConn :: forall m. ChatMonad m => VersionRange -> User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do
entity <- withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus
case agentMessage of
END -> case entity of
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
@ -3407,7 +3421,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
XOk -> pure ()
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
CON ->
withStore' (\db -> getViaGroupMember db user ct) >>= \case
withStore' (\db -> getViaGroupMember db vr user ct) >>= \case
Nothing -> do
-- [incognito] print incognito profile used for this contact
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
@ -3428,7 +3442,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
forM_ groupId_ $ \groupId -> do
groupInfo <- withStore $ \db -> getGroupInfo db user groupId
groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId
subMode <- chatReadVar subscriptionMode
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
gVar <- asks random
@ -3596,7 +3610,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
profileToSend = profileToSendOnAccept user profileMode
void $ sendDirectMessage conn (XGrpLinkMem profileToSend) (GroupId groupId)
sendIntroductions members = do
intros <- withStore' $ \db -> createIntroductions db members m
intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m
shuffledIntros <- liftIO $ shuffleIntros intros
if isCompatibleRange (memberChatVRange' m) batchSendVRange
then do
@ -3886,7 +3900,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
CON -> do
ci <- withStore $ \db -> do
liftIO $ updateSndFileStatus db ft FSConnected
updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
toView $ CRSndFileStart user ci ft
sendFileChunk user ft
SENT msgId -> do
@ -3900,7 +3914,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
getChatRefByFileId db user fileId >>= \case
ChatRef CTDirect _ -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled
_ -> pure ()
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
toView $ CRSndFileRcvCancelled user ci ft
_ -> throwChatError $ CEFileSend fileId err
MSG meta _ _ -> withAckMessage' agentConnId conn meta $ pure ()
@ -3966,7 +3980,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
FileChunkCancel ->
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
ci <- withStore $ \db -> getChatItemByFileId db user fileId
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
toView $ CRRcvFileSndCancelled user ci ft
FileChunk {chunkNo, chunkBytes = chunk} -> do
case integrity of
@ -3989,7 +4003,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete
deleteRcvFileChunks db ft
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
toView $ CRRcvFileComplete user ci
forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn)
RcvChunkDuplicate -> ack $ pure ()
@ -4032,7 +4046,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ct <- acceptContactRequestAsync user cReq incognitoProfile True
toView $ CRAcceptingContactRequest user ct
Just groupId -> do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
if isCompatibleRange chatVRange groupLinkNoContactVRange
then do
@ -4525,14 +4539,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
ci <- withStore $ \db -> getChatItemByFileId db user fileId
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
toView $ CRRcvFileSndCancelled user ci ft
xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInv ct sharedMsgId fileConnReq_ fName msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db user fileId
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId
assertSMPAcceptNotProhibited ci
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
@ -4547,7 +4561,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- receiving inline
_ -> do
event <- withStore $ \db -> do
ci' <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
sft <- createSndDirectInlineFT db ct ft
pure $ CRSndFileStart user ci' sft
toView event
@ -4575,7 +4589,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do
liftIO $ updateSndFileStatus db sft FSComplete
liftIO $ deleteSndFileChunks db sft
updateDirectCIFileStatus db user fileId CIFSSndComplete
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
case file of
Just CIFile {fileProtocol = FPXFTP} -> do
ft <- withStore $ \db -> getFileTransferMeta db user fileId
@ -4620,7 +4634,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
ci <- withStore $ \db -> getChatItemByFileId db user fileId
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
toView $ CRRcvFileSndCancelled user ci ft
else messageError "x.file.cancel: group member attempted to cancel file of another member" -- shouldn't happen now that query includes group member id
(SMDSnd, _) -> messageError "x.file.cancel: group member attempted invalid file cancel"
@ -4628,7 +4642,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> m ()
xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db user fileId
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId
assertSMPAcceptNotProhibited ci
-- TODO check that it's not already accepted
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
@ -4644,7 +4658,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
(_, Just conn) -> do
-- receiving inline
event <- withStore $ \db -> do
ci' <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
sft <- liftIO $ createSndGroupInlineFT db m conn ft
pure $ CRSndFileStart user ci' sft
toView event
@ -4668,7 +4682,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <- withStore $ \db -> createGroupInvitation db user ct inv customUserProfileId
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <-
withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId
if sameGroupLinkId groupLinkId groupLinkId'
then do
subMode <- chatReadVar subscriptionMode
@ -5019,14 +5034,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
associateMemberWithContact :: Contact -> GroupMember -> m Contact
associateMemberWithContact c1 m2@GroupMember {groupId} = do
withStore' $ \db -> associateMemberWithContactRecord db user c1 m2
g <- withStore $ \db -> getGroupInfo db user groupId
g <- withStore $ \db -> getGroupInfo db vr user groupId
toView $ CRContactAndMemberAssociated user c1 g m2 c1
pure c1
associateContactWithMember :: GroupMember -> Contact -> m Contact
associateContactWithMember m1@GroupMember {groupId} c2 = do
c2' <- withStore $ \db -> associateContactWithMemberRecord db user m1 c2
g <- withStore $ \db -> getGroupInfo db user groupId
g <- withStore $ \db -> getGroupInfo db vr user groupId
toView $ CRContactAndMemberAssociated user c2 g m1 c2'
pure c2'
@ -5041,7 +5056,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRContactConnecting user ct
pure conn'
XGrpLinkInv glInv -> do
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db user conn' glInv
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db vr user conn' glInv
toView $ CRGroupLinkConnecting user gInfo host
pure conn'
-- TODO show/log error, other events in SMP confirmation
@ -5441,14 +5456,15 @@ parseChatMessage conn s = do
sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m ()
sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} =
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $ do
vr <- chatVersionRange
withStore' (`createSndFileChunk` ft) >>= \case
Just chunkNo -> sendFileChunkNo ft chunkNo
Nothing -> do
ci <- withStore $ \db -> do
liftIO $ updateSndFileStatus db ft FSComplete
liftIO $ deleteSndFileChunks db ft
updateDirectCIFileStatus db user fileId CIFSSndComplete
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
toView $ CRSndFileComplete user ci ft
closeFileHandle fileId sndFiles
deleteAgentConnectionAsync user acId
@ -5613,8 +5629,8 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do
createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage
createSndMessage chatMsgEvent connOrGroupId = do
gVar <- asks random
ChatConfig {chatVRange} <- asks config
withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage chatVRange)
vr <- chatVersionRange
withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage vr)
where
encodeMessage chatVRange sharedMsgId =
encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent}
@ -5640,8 +5656,8 @@ sendGroupMemberMessages user conn@Connection {connId} events groupId = do
createSndMessages :: m [Either ChatError SndMessage]
createSndMessages = do
gVar <- asks random
ChatConfig {chatVRange} <- asks config
withStoreBatch $ \db -> map (createMsg db gVar chatVRange) (toList events)
vr <- chatVersionRange
withStoreBatch $ \db -> map (createMsg db gVar vr) (toList events)
createMsg db gVar chatVRange evnt = do
r <- runExceptT $ createNewSndMessage db gVar (GroupId groupId) evnt (encodeMessage chatVRange evnt)
pure $ first ChatErrorStore r
@ -5650,7 +5666,7 @@ sendGroupMemberMessages user conn@Connection {connId} events groupId = do
directMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString
directMessage chatMsgEvent = do
ChatConfig {chatVRange} <- asks config
chatVRange <- chatVersionRange
let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}
case r of
ECMEncoded encodedBody -> pure . LB.toStrict $ encodedBody
@ -6103,6 +6119,11 @@ waitChatStarted = do
agentStarted <- asks agentAsync
atomically $ readTVar agentStarted >>= \a -> unless (isJust a) retry
chatVersionRange :: ChatMonad' m => m VersionRange
chatVersionRange = do
ChatConfig {chatVRange} <- asks config
pure chatVRange
chatCommandP :: Parser ChatCommand
chatCommandP =
choice

7
src/Simplex/Chat/Migrations/M20231215_recreate_msg_deliveries.hs
View File

@ -8,6 +8,13 @@ import Database.SQLite.Simple.QQ (sql)
m20231215_recreate_msg_deliveries :: Query
m20231215_recreate_msg_deliveries =
[sql|
DROP VIEW IF EXISTS direct_messages;
DROP VIEW IF EXISTS direct_messages_plain;
DROP VIEW IF EXISTS group_messages;
DROP VIEW IF EXISTS group_messages_plain;
DROP VIEW IF EXISTS all_messages;
DROP VIEW IF EXISTS all_messages_plain;
DROP INDEX msg_delivery_events_msg_delivery_id;
DROP TABLE msg_delivery_events;

4
src/Simplex/Chat/Protocol.hs
View File

@ -52,9 +52,13 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, fstTo
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version)
-- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig.
-- This indirection is needed for backward/forward compatibility testing.
-- Testing with real app versions is still needed, as tests use the current code with different version ranges, not the old code.
currentChatVersion :: Version
currentChatVersion = 5
-- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
supportedChatVRange :: VersionRange
supportedChatVRange = mkVersionRange 1 currentChatVersion

1
src/Simplex/Chat/Remote/Protocol.hs
View File

@ -38,7 +38,6 @@ import Simplex.Chat.Controller
import Simplex.Chat.Remote.Transport
import Simplex.Chat.Remote.Types
import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.Messaging.Agent.Client (agentDRG)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Lazy (LazyByteString)

25
src/Simplex/Chat/Store/Connections.hs
View File

@ -35,9 +35,10 @@ import Simplex.Messaging.Agent.Protocol (ConnId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version (VersionRange)
getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db user@User {userId, userContactId} agentConnId = do
getConnectionEntity :: DB.Connection -> VersionRange -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
c@Connection {connType, entityId} <- getConnection_
case entityId of
Nothing ->
@ -115,7 +116,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
(groupMemberId, userId, userContactId)
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
toGroupAndMember c (groupInfoRow :. memberRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow
let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = Just c})
getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer
@ -154,19 +155,19 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
userContact_ _ = Left SEUserContactLinkNotFound
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
getConnectionEntityByConnReq :: DB.Connection -> VersionRange -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
connId_ <-
maybeFirstRow fromOnly $
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
-- search connection for connection plan:
-- multiple connections can have same via_contact_uri_hash if request was repeated;
-- this function searches for latest connection with contact so that "known contact" plan would be chosen;
-- deleted connections are filtered out to allow re-connecting via same contact address
getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do
getContactConnEntityByConnReqHash :: DB.Connection -> VersionRange -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2) = do
connId_ <-
maybeFirstRow fromOnly $
DB.query
@ -183,14 +184,14 @@ getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) =
)
|]
(userId, cReqHash1, cReqHash2, ConnDeleted)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])
getConnectionsToSubscribe db = do
getConnectionsToSubscribe :: DB.Connection -> VersionRange -> IO ([ConnId], [ConnectionEntity])
getConnectionsToSubscribe db vr = do
aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1"
entities <- forM aConnIds $ \acId -> do
getUserByAConnId db acId >>= \case
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db user acId)
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db vr user acId)
Nothing -> pure Nothing
unsetConnectionToSubscribe db
let connIds = map (\(AgentConnId connId) -> connId) aConnIds

25
src/Simplex/Chat/Store/Files.hs
View File

@ -106,6 +106,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Protocol (SubscriptionMode (..))
import Simplex.Messaging.Version (VersionRange)
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
getLiveSndFileTransfers db User {userId} = do
@ -676,8 +677,8 @@ getRcvFileTransfer_ db userId fileId = do
_ -> pure Nothing
cancelled = fromMaybe False cancelled_
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem
acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath subMode = ExceptT $ do
acceptRcvFileTransfer :: DB.Connection -> VersionRange -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem
acceptRcvFileTransfer db vr user@User {userId} fileId (cmdId, acId) connStatus filePath subMode = ExceptT $ do
currentTs <- getCurrentTime
acceptRcvFT_ db user fileId filePath Nothing currentTs
DB.execute
@ -686,7 +687,7 @@ acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus file
(acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs, subMode == SMOnlyCreate)
connId <- insertedRowId db
setCommandConnId db user cmdId connId
runExceptT $ getChatItemByFileId db user fileId
runExceptT $ getChatItemByFileId db vr user fileId
getContactByFileId :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact
getContactByFileId db user@User {userId} fileId = do
@ -697,19 +698,19 @@ getContactByFileId db user@User {userId} fileId = do
ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $
DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, fileId)
acceptRcvInlineFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db user fileId filePath = do
acceptRcvInlineFT :: DB.Connection -> VersionRange -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db vr user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO ()
startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline =
acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime
xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
xftpAcceptRcvFT db user fileId filePath = do
xftpAcceptRcvFT :: DB.Connection -> VersionRange -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
xftpAcceptRcvFT db vr user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO ()
acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do
@ -929,9 +930,9 @@ getLocalCryptoFile db userId fileId sent =
FileTransferMeta {filePath, xftpSndFile} <- getFileTransferMeta_ db userId fileId
pure $ CryptoFile filePath $ xftpSndFile >>= \XFTPSndFile {cryptoArgs} -> cryptoArgs
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus db user fileId fileStatus = do
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> VersionRange -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus db vr user fileId fileStatus = do
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db vr user fileId
case (cType, testEquality d $ msgDirection @d) of
(SCTDirect, Just Refl) -> do
liftIO $ updateCIFileStatus db user fileId fileStatus

115
src/Simplex/Chat/Store/Groups.hs
View File

@ -127,7 +127,7 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Messages
import Simplex.Chat.Protocol (currentChatVersion, groupForwardVRange, supportedChatVRange)
import Simplex.Chat.Protocol (groupForwardVRange)
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
@ -147,9 +147,9 @@ type GroupMemberRow = ((Int64, Int64, MemberId, Version, Version, GroupMemberRol
type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe Version, Maybe Version, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool) :. (Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences))
toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = JVersionRange supportedChatVRange}
toGroupInfo :: VersionRange -> Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = JVersionRange vr}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
fullGroupPreferences = mergeGroupPreferences groupPreferences
groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences}
@ -251,8 +251,8 @@ setGroupLinkMemberRole :: DB.Connection -> User -> Int64 -> GroupMemberRole -> I
setGroupLinkMemberRole db User {userId} userContactLinkId memberRole =
DB.execute db "UPDATE user_contact_links SET group_link_member_role = ? WHERE user_id = ? AND user_contact_link_id = ?" (memberRole, userId, userContactLinkId)
getGroupAndMember :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupMember)
getGroupAndMember db User {userId, userContactId} groupMemberId =
getGroupAndMember :: DB.Connection -> User -> Int64 -> VersionRange -> ExceptT StoreError IO (GroupInfo, GroupMember)
getGroupAndMember db User {userId, userContactId} groupMemberId vr =
ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $
DB.query
db
@ -288,13 +288,13 @@ getGroupAndMember db User {userId, userContactId} groupMemberId =
where
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow
let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
-- | creates completely new group with a single member - the current user
createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> Maybe Profile -> ExceptT StoreError IO GroupInfo
createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do
createNewGroup :: DB.Connection -> VersionRange -> TVar ChaChaDRG -> User -> GroupProfile -> Maybe Profile -> ExceptT StoreError IO GroupInfo
createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
fullGroupPreferences = mergeGroupPreferences groupPreferences
currentTs <- getCurrentTime
@ -312,18 +312,18 @@ createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = Except
(ldn, userId, profileId, True, currentTs, currentTs, currentTs)
insertedRowId db
memberId <- liftIO $ encodedRandomBytes gVar 12
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser customUserProfileId currentTs supportedChatVRange
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser customUserProfileId currentTs vr
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}
-- | creates a new group record for the group the current user was invited to, or returns an existing one
createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Just hostConn@Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
createGroupInvitation :: DB.Connection -> VersionRange -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activeConn = Just hostConn@Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
liftIO getInvitationGroupId_ >>= \case
Nothing -> createGroupInvitation_
Just gId -> do
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db user gId
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db vr user gId
hostId <- getHostMemberId_ db user gId
let GroupMember {groupMemberId, memberId, memberRole} = membership
MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember
@ -359,7 +359,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo
insertedRowId db
let JVersionRange hostVRange = peerChatVRange hostConn
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs hostVRange
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs supportedChatVRange
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs vr
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId)
@ -430,9 +430,10 @@ createContactMemberInv_ db User {userId, userContactId} groupId invitedByGroupMe
)
pure $ Right incognitoLdn
createGroupInvitedViaLink :: DB.Connection -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupInvitedViaLink :: DB.Connection -> VersionRange -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupInvitedViaLink
db
vr
user@User {userId, userContactId}
Connection {connId, customUserProfileId}
GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile} = do
@ -441,9 +442,9 @@ createGroupInvitedViaLink
hostMemberId <- insertHost_ currentTs groupId
liftIO $ DB.execute db "UPDATE connections SET conn_type = ?, group_member_id = ?, updated_at = ? WHERE connection_id = ?" (ConnMember, hostMemberId, currentTs, connId)
-- using IBUnknown since host is created without contact
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs supportedChatVRange
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs vr
liftIO $ setViaGroupLinkHash db groupId connId
(,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId
(,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db user hostMemberId
where
insertGroup_ currentTs = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
@ -496,9 +497,9 @@ setGroupInvitationChatItemId db User {userId} groupId chatItemId = do
-- TODO return the last connection that is ready, not any last connection
-- requires updating connection status
getGroup :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO Group
getGroup db user groupId = do
gInfo <- getGroupInfo db user groupId
getGroup :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO Group
getGroup db vr user groupId = do
gInfo <- getGroupInfo db vr user groupId
members <- liftIO $ getGroupMembers db user gInfo
pure $ Group gInfo members
@ -551,14 +552,14 @@ deleteGroupProfile_ db userId groupId =
|]
(userId, groupId)
getUserGroups :: DB.Connection -> User -> IO [Group]
getUserGroups db user@User {userId} = do
getUserGroups :: DB.Connection -> VersionRange -> User -> IO [Group]
getUserGroups db vr user@User {userId} = do
groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId)
rights <$> mapM (runExceptT . getGroup db user) groupIds
rights <$> mapM (runExceptT . getGroup db vr user) groupIds
getUserGroupDetails :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
map (toGroupInfo userContactId)
getUserGroupDetails :: DB.Connection -> VersionRange -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ =
map (toGroupInfo vr userContactId)
<$> DB.query
db
[sql|
@ -576,9 +577,9 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
where
search = fromMaybe "" search_
getUserGroupsWithSummary :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)]
getUserGroupsWithSummary db user _contactId_ search_ =
getUserGroupDetails db user _contactId_ search_
getUserGroupsWithSummary :: DB.Connection -> VersionRange -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)]
getUserGroupsWithSummary db vr user _contactId_ search_ =
getUserGroupDetails db vr user _contactId_ search_
>>= mapM (\g@GroupInfo {groupId} -> (g,) <$> getGroupSummary db user groupId)
-- the statuses on non-current members should match memberCurrent' function
@ -619,10 +620,10 @@ checkContactHasGroups :: DB.Connection -> User -> Contact -> IO (Maybe GroupId)
checkContactHasGroups db User {userId} Contact {contactId} =
maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId)
getGroupInfoByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupInfo
getGroupInfoByName db user gName = do
getGroupInfoByName :: DB.Connection -> VersionRange -> User -> GroupName -> ExceptT StoreError IO GroupInfo
getGroupInfoByName db vr user gName = do
gId <- getGroupIdByName db user gName
getGroupInfo db user gId
getGroupInfo db vr user gId
groupMemberQuery :: Query
groupMemberQuery =
@ -708,11 +709,11 @@ getGroupCurrentMembersCount db User {userId} GroupInfo {groupId} = do
(groupId, userId)
pure $ length $ filter memberCurrent' statuses
getGroupInvitation :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
getGroupInvitation db user groupId =
getGroupInvitation :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
getGroupInvitation db vr user groupId =
getConnRec_ user >>= \case
Just connRequest -> do
groupInfo@GroupInfo {membership} <- getGroupInfo db user groupId
groupInfo@GroupInfo {membership} <- getGroupInfo db vr user groupId
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
hostId <- getHostMemberId_ db user groupId
fromMember <- getGroupMember db user groupId hostId
@ -1004,8 +1005,8 @@ updateGroupMemberRole :: DB.Connection -> User -> GroupMember -> GroupMemberRole
updateGroupMemberRole db User {userId} GroupMember {groupMemberId} memRole =
DB.execute db "UPDATE group_members SET member_role = ? WHERE user_id = ? AND group_member_id = ?" (memRole, userId, groupMemberId)
createIntroductions :: DB.Connection -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro]
createIntroductions db members toMember = do
createIntroductions :: DB.Connection -> Version -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro]
createIntroductions db chatV members toMember = do
let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members
if null reMembers
then pure []
@ -1022,7 +1023,7 @@ createIntroductions db members toMember = do
(re_group_member_id, to_group_member_id, intro_status, intro_chat_protocol_version, created_at, updated_at)
VALUES (?,?,?,?,?,?)
|]
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, currentChatVersion, ts, ts)
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, chatV, ts, ts)
introId <- insertedRowId db
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing}
@ -1200,8 +1201,8 @@ createIntroToMemberContact db user@User {userId} GroupMember {memberContactId =
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> VersionRange -> Maybe Int64 -> Int -> UTCTime -> SubscriptionMode -> IO Connection
createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId peerChatVRange viaContact Nothing Nothing
getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
getViaGroupMember db User {userId, userContactId} Contact {contactId} =
getViaGroupMember :: DB.Connection -> VersionRange -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
getViaGroupMember db vr User {userId, userContactId} Contact {contactId} =
maybeFirstRow toGroupAndMember $
DB.query
db
@ -1238,7 +1239,7 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
where
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow
let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
@ -1293,9 +1294,9 @@ updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, grou
(ldn, currentTs, userId, groupId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
getGroupInfo :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db User {userId, userContactId} groupId =
ExceptT . firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $
getGroupInfo :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db vr User {userId, userContactId} groupId =
ExceptT . firstRow (toGroupInfo vr userContactId) (SEGroupNotFound groupId) $
DB.query
db
[sql|
@ -1314,8 +1315,8 @@ getGroupInfo db User {userId, userContactId} groupId =
|]
(groupId, userId, userContactId)
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> VersionRange -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
groupId_ <-
maybeFirstRow fromOnly $
DB.query
@ -1326,10 +1327,10 @@ getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSch
WHERE user_id = ? AND conn_req_contact IN (?,?)
|]
(userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
getGroupInfoByGroupLinkHash :: DB.Connection -> VersionRange -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
groupId_ <-
maybeFirstRow fromOnly $
DB.query
@ -1343,7 +1344,7 @@ getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1
LIMIT 1
|]
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_
getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
getGroupIdByName db User {userId} gName =
@ -1355,8 +1356,8 @@ getGroupMemberIdByName db User {userId} groupId groupMemberName =
ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound groupId groupMemberName) $
DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName)
getActiveMembersByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
getActiveMembersByName db user@User {userId} groupMemberName = do
getActiveMembersByName :: DB.Connection -> VersionRange -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
getActiveMembersByName db vr user@User {userId} groupMemberName = do
groupMemberIds :: [(GroupId, GroupMemberId)] <-
liftIO $
DB.query
@ -1369,7 +1370,7 @@ getActiveMembersByName db user@User {userId} groupMemberName = do
|]
(userId, groupMemberName, GSMemConnected, GSMemComplete, GCUserMember)
possibleMembers <- forM groupMemberIds $ \(groupId, groupMemberId) -> do
groupInfo <- getGroupInfo db user groupId
groupInfo <- getGroupInfo db vr user groupId
groupMember <- getGroupMember db user groupId groupMemberId
pure (groupInfo, groupMember)
pure $ sortOn (Down . ts . fst) possibleMembers
@ -1826,15 +1827,15 @@ createMemberContact
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn
pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False}
getMemberContact :: DB.Connection -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
getMemberContact db user contactId = do
getMemberContact :: DB.Connection -> VersionRange -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
getMemberContact db vr user contactId = do
ct <- getContact db user contactId
let Contact {contactGroupMemberId, activeConn} = ct
case (activeConn, contactGroupMemberId) of
(Just Connection {connId}, Just groupMemberId) -> do
cReq <- getConnReqInv db connId
m@GroupMember {groupId} <- getGroupMemberById db user groupMemberId
g <- getGroupInfo db user groupId
g <- getGroupInfo db vr user groupId
pure (g, m, ct, cReq)
_ ->
throwError $ SEMemberContactGroupMemberNotFound contactId

45
src/Simplex/Chat/Store/Messages.hs
View File

@ -134,6 +134,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version (VersionRange)
import UnliftIO.STM
deleteContactCIs :: DB.Connection -> User -> Contact -> IO ()
@ -461,8 +462,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
getChatPreviews :: DB.Connection -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
getChatPreviews db user withPCC pagination query = do
getChatPreviews :: DB.Connection -> VersionRange -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
getChatPreviews db vr user withPCC pagination query = do
directChats <- findDirectChatPreviews_ db user pagination query
groupChats <- findGroupChatPreviews_ db user pagination query
cReqChats <- getContactRequestChatPreviews_ db user pagination query
@ -483,7 +484,7 @@ getChatPreviews db user withPCC pagination query = do
getChatPreview :: AChatPreviewData -> ExceptT StoreError IO AChat
getChatPreview (ACPD cType cpd) = case cType of
SCTDirect -> getDirectChatPreview_ db user cpd
SCTGroup -> getGroupChatPreview_ db user cpd
SCTGroup -> getGroupChatPreview_ db vr user cpd
SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat
SCTContactConnection -> let (ContactConnectionPD _ chat) = cpd in pure chat
@ -688,9 +689,9 @@ findGroupChatPreviews_ db User {userId} pagination clq =
)
([":user_id" := userId, ":rcv_new" := CISRcvNew, ":search" := search] <> pagParams)
getGroupChatPreview_ :: DB.Connection -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
getGroupChatPreview_ db user (GroupChatPD _ groupId lastItemId_ stats) = do
groupInfo <- getGroupInfo db user groupId
getGroupChatPreview_ :: DB.Connection -> VersionRange -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do
groupInfo <- getGroupInfo db vr user groupId
lastItem <- case lastItemId_ of
Just lastItemId -> (: []) <$> getGroupChatItem db user groupId lastItemId
Nothing -> pure []
@ -874,10 +875,10 @@ getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId co
|]
(userId, contactId, search, beforeChatItemId, count)
getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChat db user groupId pagination search_ = do
getGroupChat :: DB.Connection -> VersionRange -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChat db vr user groupId pagination search_ = do
let search = fromMaybe "" search_
g <- getGroupInfo db user groupId
g <- getGroupInfo db vr user groupId
case pagination of
CPLast count -> getGroupChatLast_ db user g count search
CPAfter afterId count -> getGroupChatAfter_ db user g afterId count search
@ -1185,19 +1186,19 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
getAllChatItems db user@User {userId} pagination search_ = do
getAllChatItems :: DB.Connection -> VersionRange -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
getAllChatItems db vr user@User {userId} pagination search_ = do
itemRefs <-
rights . map toChatItemRef <$> case pagination of
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
mapM (uncurry (getAChatItem db user) >=> liftIO . getACIReactions db) itemRefs
mapM (uncurry (getAChatItem db vr user) >=> liftIO . getACIReactions db) itemRefs
where
search = fromMaybe "" search_
getAChatItem_ itemId = do
chatRef <- getChatRefViaItemId db user itemId
getAChatItem db user chatRef itemId
getAChatItem db vr user chatRef itemId
getAllChatItemsLast_ count =
reverse
<$> DB.query
@ -1713,8 +1714,8 @@ getGroupChatItemIdByText' db User {userId} groupId msg =
|]
(userId, groupId, msg <> "%")
getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem
getChatItemByFileId db user@User {userId} fileId = do
getChatItemByFileId :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO AChatItem
getChatItemByFileId db vr user@User {userId} fileId = do
(chatRef, itemId) <-
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $
DB.query
@ -1727,10 +1728,10 @@ getChatItemByFileId db user@User {userId} fileId = do
LIMIT 1
|]
(userId, fileId)
getAChatItem db user chatRef itemId
getAChatItem db vr user chatRef itemId
getChatItemByGroupId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem
getChatItemByGroupId db user@User {userId} groupId = do
getChatItemByGroupId :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO AChatItem
getChatItemByGroupId db vr user@User {userId} groupId = do
(chatRef, itemId) <-
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $
DB.query
@ -1743,7 +1744,7 @@ getChatItemByGroupId db user@User {userId} groupId = do
LIMIT 1
|]
(userId, groupId)
getAChatItem db user chatRef itemId
getAChatItem db vr user chatRef itemId
getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef
getChatRefViaItemId db User {userId} itemId = do
@ -1755,14 +1756,14 @@ getChatRefViaItemId db User {userId} itemId = do
(Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId
(_, _) -> Left $ SEBadChatItem itemId
getAChatItem :: DB.Connection -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
getAChatItem db user chatRef itemId = case chatRef of
getAChatItem :: DB.Connection -> VersionRange -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
getAChatItem db vr user chatRef itemId = case chatRef of
ChatRef CTDirect contactId -> do
ct <- getContact db user contactId
(CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId
pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci
ChatRef CTGroup groupId -> do
gInfo <- getGroupInfo db user groupId
gInfo <- getGroupInfo db vr user groupId
(CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci
_ -> throwError $ SEChatItemNotFound itemId

35
tests/ChatClient.hs
View File

@ -128,16 +128,43 @@ testCfg =
xftpFileConfig = Nothing
}
testAgentCfgVPrev :: AgentConfig
testAgentCfgVPrev =
testAgentCfg
{ smpAgentVRange = prevRange $ smpAgentVRange testAgentCfg,
smpClientVRange = prevRange $ smpClientVRange testAgentCfg,
e2eEncryptVRange = prevRange $ e2eEncryptVRange testAgentCfg,
smpCfg = (smpCfg testAgentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg testAgentCfg}
}
testAgentCfgV1 :: AgentConfig
testAgentCfgV1 =
testAgentCfg
{ smpClientVRange = mkVersionRange 1 1,
smpAgentVRange = mkVersionRange 1 1,
smpCfg = (smpCfg testAgentCfg) {serverVRange = mkVersionRange 1 1}
{ smpClientVRange = v1Range,
smpAgentVRange = v1Range,
e2eEncryptVRange = v1Range,
smpCfg = (smpCfg testAgentCfg) {serverVRange = v1Range}
}
testCfgVPrev :: ChatConfig
testCfgVPrev =
testCfg
{ chatVRange = prevRange $ chatVRange testCfg,
agentConfig = testAgentCfgVPrev
}
testCfgV1 :: ChatConfig
testCfgV1 = testCfg {agentConfig = testAgentCfgV1}
testCfgV1 =
testCfg
{ chatVRange = v1Range,
agentConfig = testAgentCfgV1
}
prevRange :: VersionRange -> VersionRange
prevRange vr = vr {maxVersion = maxVersion vr - 1}
v1Range :: VersionRange
v1Range = mkVersionRange 1 1
testCfgCreateGroupDirect :: ChatConfig
testCfgCreateGroupDirect =

297
tests/ChatTests/Groups.hs
View File

@ -24,8 +24,9 @@ import Test.Hspec
chatGroupTests :: SpecWith FilePath
chatGroupTests = do
describe "chat groups" $ do
it "add contacts, create group and send/receive messages" testGroup
it "add contacts, create group and send/receive messages, check messages" testGroupCheckMessages
describe "add contacts, create group and send/receive messages" testGroupMatrix
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 "create group with incognito membership" testNewGroupIncognito
it "create and join group with 4 members" testGroup2
it "create and delete group" testGroupDelete
@ -69,6 +70,8 @@ chatGroupTests = do
it "re-join existing group after leaving" testPlanGroupLinkLeaveRejoin
describe "group links without contact" $ do
it "join via group link without creating contact" testGroupLinkNoContact
it "invitees were previously connected as contacts" testGroupLinkNoContactInviteesWereConnected
it "all members were previously connected as contacts" testGroupLinkNoContactAllMembersWereConnected
it "group link member role" testGroupLinkNoContactMemberRole
it "host incognito" testGroupLinkNoContactHostIncognito
it "invitee incognito" testGroupLinkNoContactInviteeIncognito
@ -146,15 +149,19 @@ chatGroupTests = do
testGroup :: HasCallStack => FilePath -> IO ()
testGroup =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> testGroupShared alice bob cath False
\alice bob cath -> testGroupShared alice bob cath False True
testGroupCheckMessages :: HasCallStack => FilePath -> IO ()
testGroupCheckMessages =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> testGroupShared alice bob cath True
\alice bob cath -> testGroupShared alice bob cath True True
testGroupShared :: HasCallStack => TestCC -> TestCC -> TestCC -> Bool -> IO ()
testGroupShared alice bob cath checkMessages = do
testGroupMatrix :: SpecWith FilePath
testGroupMatrix =
versionTestMatrix3 $ \alice bob cath -> testGroupShared alice bob cath False False
testGroupShared :: HasCallStack => TestCC -> TestCC -> TestCC -> Bool -> Bool -> IO ()
testGroupShared alice bob cath checkMessages directConnections = do
connectUsers alice bob
connectUsers alice cath
alice ##> "/g team"
@ -206,7 +213,8 @@ testGroupShared alice bob cath checkMessages = do
(alice <# "#team cath> hey team")
(bob <# "#team cath> hey team")
msgItem2 <- lastItemId alice
bob <##> cath
when directConnections $
bob <##> cath
when checkMessages $ getReadChats msgItem1 msgItem2
-- list groups
alice ##> "/gs"
@ -263,17 +271,34 @@ testGroupShared alice bob cath checkMessages = do
(cath </)
cath ##> "#team hello"
cath <## "you are no longer a member of the group"
bob <##> cath
when directConnections $
bob <##> cath
-- delete contact
alice ##> "/d bob"
alice <## "bob: contact is deleted"
bob <## "alice (Alice) deleted contact with you"
alice `send` "@bob hey"
alice
<### [ "@bob hey",
"member #team bob does not have direct connection, creating",
"peer chat protocol version range incompatible"
]
if directConnections
then
alice
<### [ "@bob hey",
"member #team bob does not have direct connection, creating",
"peer chat protocol version range incompatible"
]
else do
alice
<### [ WithTime "@bob hey",
"member #team bob does not have direct connection, creating",
"contact for member #team bob is created",
"sent invitation to connect directly to member #team bob",
"bob (Bob): contact is connected"
]
bob
<### [ "#team alice is creating direct contact alice with you",
WithTime "alice> hey",
"alice: security code changed",
"alice (Alice): contact is connected"
]
when checkMessages $ threadDelay 1000000
alice #> "#team checking connection"
bob <# "#team alice> checking connection"
@ -2633,11 +2658,16 @@ testPlanGroupLinkLeaveRejoin =
testGroupLinkNoContact :: HasCallStack => FilePath -> IO ()
testGroupLinkNoContact =
testChat2 aliceProfile bobProfile $
\alice bob -> do
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
alice ##> "/g team"
alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team"
alice ##> "/set history #team off"
alice <## "updated group preferences:"
alice <## "Recent history: off"
alice ##> "/create link #team"
gLink <- getGroupLink alice "team" GRMember True
bob ##> ("/c " <> gLink)
@ -2663,10 +2693,196 @@ testGroupLinkNoContact =
bob #> "#team hi there"
alice <# "#team bob> hi there"
cath ##> ("/c " <> gLink)
cath <## "connection request sent!"
concurrentlyN_
[ do
alice <## "cath (Catherine): accepting request to join group #team..."
alice <## "#team: cath joined the group",
do
cath <## "#team: joining the group..."
cath <## "#team: you joined the group"
cath <## "#team: member bob (Bob) is connected",
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
cath #> "#team hey"
alice <# "#team cath> hey"
bob <# "#team cath> hey"
bob #> "#team hi cath"
alice <# "#team bob> hi cath"
cath <# "#team bob> hi cath"
testGroupLinkNoContactInviteesWereConnected :: HasCallStack => FilePath -> IO ()
testGroupLinkNoContactInviteesWereConnected =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
connectUsers bob cath
bob <##> cath
alice ##> "/g team"
alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team"
alice ##> "/set history #team off"
alice <## "updated group preferences:"
alice <## "Recent history: off"
alice ##> "/create link #team"
gLink <- getGroupLink alice "team" GRMember True
bob ##> ("/c " <> gLink)
bob <## "connection request sent!"
alice <## "bob (Bob): accepting request to join group #team..."
concurrentlyN_
[ alice <## "#team: bob joined the group",
do
bob <## "#team: joining the group..."
bob <## "#team: you joined the group"
]
threadDelay 100000
alice #$> ("/_get chat #1 count=100", chat, [(0, "invited via your group link"), (0, "connected")])
alice @@@ [("#team", "connected")]
bob @@@ [("#team", "connected"), ("@cath", "hey")]
alice ##> "/contacts"
bob ##> "/contacts"
bob <## "cath (Catherine)"
alice #> "#team hello"
bob <# "#team alice> hello"
bob #> "#team hi there"
alice <# "#team bob> hi there"
cath ##> ("/c " <> gLink)
cath <## "connection request sent!"
concurrentlyN_
[ do
alice <## "cath (Catherine): accepting request to join group #team..."
alice <## "#team: cath joined the group",
cath
<### [ "#team: joining the group...",
"#team: you joined the group",
"#team: member bob_1 (Bob) is connected",
"contact and member are merged: bob, #team bob_1",
"use @bob <message> to send messages"
],
bob
<### [ "#team: alice added cath_1 (Catherine) to the group (connecting...)",
"#team: new member cath_1 is connected",
"contact and member are merged: cath, #team cath_1",
"use @cath <message> to send messages"
]
]
-- message delivery works
bob <##> cath
alice #> "#team 1"
[bob, cath] *<# "#team alice> 1"
bob #> "#team 2"
[alice, cath] *<# "#team bob> 2"
cath #> "#team 3"
[alice, bob] *<# "#team cath> 3"
testGroupLinkNoContactAllMembersWereConnected :: HasCallStack => FilePath -> IO ()
testGroupLinkNoContactAllMembersWereConnected =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
connectUsers alice bob
alice <##> bob
connectUsers alice cath
alice <##> cath
connectUsers bob cath
bob <##> cath
alice ##> "/g team"
alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team"
alice ##> "/set history #team off"
alice <## "updated group preferences:"
alice <## "Recent history: off"
alice ##> "/create link #team"
gLink <- getGroupLink alice "team" GRMember True
bob ##> ("/c " <> gLink)
bob <## "connection request sent!"
alice <## "bob_1 (Bob): accepting request to join group #team..."
concurrentlyN_
[ do
alice <## "#team: bob_1 joined the group"
alice <## "contact and member are merged: bob, #team bob_1"
alice <## "use @bob <message> to send messages",
do
bob <## "#team: joining the group..."
bob <## "#team: you joined the group"
bob <## "contact and member are merged: alice, #team alice_1"
bob <## "use @alice <message> to send messages"
]
threadDelay 100000
alice #$> ("/_get chat #1 count=100", chat, [(0, "invited via your group link"), (0, "connected")])
alice @@@ [("#team", "connected"), ("@bob", "hey"), ("@cath", "hey")]
bob @@@ [("#team", "connected"), ("@alice", "hey"), ("@cath", "hey")]
alice ##> "/contacts"
alice <## "bob (Bob)"
alice <## "cath (Catherine)"
bob ##> "/contacts"
bob <## "alice (Alice)"
bob <## "cath (Catherine)"
alice #> "#team hello"
bob <# "#team alice> hello"
bob #> "#team hi there"
alice <# "#team bob> hi there"
cath ##> ("/c " <> gLink)
cath <## "connection request sent!"
concurrentlyN_
[ alice
<### [ "cath_1 (Catherine): accepting request to join group #team...",
"#team: cath_1 joined the group",
"contact and member are merged: cath, #team cath_1",
"use @cath <message> to send messages"
],
cath
<### [ "#team: joining the group...",
"#team: you joined the group",
"#team: member bob_1 (Bob) is connected",
"contact and member are merged: bob, #team bob_1",
"use @bob <message> to send messages",
"contact and member are merged: alice, #team alice_1",
"use @alice <message> to send messages"
],
bob
<### [ "#team: alice added cath_1 (Catherine) to the group (connecting...)",
"#team: new member cath_1 is connected",
"contact and member are merged: cath, #team cath_1",
"use @cath <message> to send messages"
]
]
-- message delivery works
alice <##> bob
alice <##> cath
bob <##> cath
alice #> "#team 1"
[bob, cath] *<# "#team alice> 1"
bob #> "#team 2"
[alice, cath] *<# "#team bob> 2"
cath #> "#team 3"
[alice, bob] *<# "#team cath> 3"
testGroupLinkNoContactMemberRole :: HasCallStack => FilePath -> IO ()
testGroupLinkNoContactMemberRole =
testChat2 aliceProfile bobProfile $
\alice bob -> do
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
alice ##> "/g team"
alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team"
@ -2706,6 +2922,43 @@ testGroupLinkNoContactMemberRole =
bob #> "#team hey now"
alice <# "#team bob> hey now"
cath ##> ("/c " <> gLink)
cath <## "connection request sent!"
concurrentlyN_
[ do
alice <## "cath (Catherine): accepting request to join group #team..."
alice <## "#team: cath joined the group",
cath
<### [ "#team: joining the group...",
"#team: you joined the group",
WithTime "#team bob> hey now [>>]",
"#team: member bob (Bob) is connected"
],
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
bob #> "#team hi cath"
alice <# "#team bob> hi cath"
cath <# "#team bob> hi cath"
cath ##> "#team hey"
cath <## "#team: you don't have permission to send messages"
alice ##> "/mr #team cath admin"
alice <## "#team: you changed the role of cath from observer to admin"
cath <## "#team: alice changed your role from observer to admin"
bob <## "#team: alice changed the role of cath from observer to admin"
cath #> "#team hey"
alice <# "#team cath> hey"
bob <# "#team cath> hey"
cath ##> "/mr #team bob admin"
cath <## "#team: you changed the role of bob from member to admin"
bob <## "#team: cath changed your role from member to admin"
alice <## "#team: cath changed the role of bob from member to admin"
testGroupLinkNoContactHostIncognito :: HasCallStack => FilePath -> IO ()
testGroupLinkNoContactHostIncognito =
testChat2 aliceProfile bobProfile $
@ -4292,6 +4545,16 @@ testGroupHistoryPreferenceOff =
r' <- chat <$> getTermLine dan
r' `shouldNotContain` [(0, "hello")]
r' `shouldNotContain` [(0, "hey!")]
-- message delivery works
alice #> "#team 1"
[bob, cath, dan] *<# "#team alice> 1"
bob #> "#team 2"
[alice, cath, dan] *<# "#team bob> 2"
cath #> "#team 3"
[alice, bob, dan] *<# "#team cath> 3"
dan #> "#team 4"
[alice, bob, cath] *<# "#team dan> 4"
where
aliceAddedDan :: HasCallStack => TestCC -> IO ()
aliceAddedDan cc = do

22
tests/ChatTests/Utils.hs
View File

@ -69,20 +69,22 @@ ifCI xrun run d t = do
versionTestMatrix2 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath
versionTestMatrix2 runTest = do
it "v2" $ testChat2 aliceProfile bobProfile runTest
it "current" $ testChat2 aliceProfile bobProfile runTest
it "prev" $ testChatCfg2 testCfgVPrev aliceProfile bobProfile runTest
it "prev to curr" $ runTestCfg2 testCfg testCfgVPrev runTest
it "curr to prev" $ runTestCfg2 testCfgVPrev testCfg runTest
it "v1" $ testChatCfg2 testCfgV1 aliceProfile bobProfile runTest
it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest
it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest
-- versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
-- versionTestMatrix3 runTest = do
-- it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest
-- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest
-- it "v1 to v2" $ runTestCfg3 testCfg testCfgV1 testCfgV1 runTest
-- it "v2+v1 to v2" $ runTestCfg3 testCfg testCfg testCfgV1 runTest
-- it "v2 to v1" $ runTestCfg3 testCfgV1 testCfg testCfg runTest
-- it "v2+v1 to v1" $ runTestCfg3 testCfgV1 testCfg testCfgV1 runTest
versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
versionTestMatrix3 runTest = do
it "current" $ testChat3 aliceProfile bobProfile cathProfile runTest
it "prev" $ testChatCfg3 testCfgVPrev aliceProfile bobProfile cathProfile runTest
it "prev to curr" $ runTestCfg3 testCfg testCfgVPrev testCfgVPrev runTest
it "curr+prev to curr" $ runTestCfg3 testCfg testCfg testCfgVPrev runTest
it "curr to prev" $ runTestCfg3 testCfgVPrev testCfg testCfg runTest
it "curr+prev to prev" $ runTestCfg3 testCfgVPrev testCfg testCfgVPrev runTest
inlineCfg :: Integer -> ChatConfig
inlineCfg n = testCfg {inlineFiles = defaultInlineFilesConfig {sendChunks = 0, offerChunks = n, receiveChunks = n}}

1
website/src/_data/docs_sidebar.json
View File

@ -21,7 +21,6 @@
"DIRECTORY.md",
"ANDROID.md",
"CLI.md",
"SQL.md",
"CONTRIBUTING.md",
"SERVER.md",
"TRANSLATIONS.md",