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

Merge branch 'master' into master-ghc8107

Browse Source
This commit is contained in:
Evgeny Poberezkin 2023-12-26 21:12:36 +00:00
commit de637fab50
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 { if ci.meta.itemDeleted == nil && !ci.isLiveDummy && !live {
menu.append(replyUIAction(ci)) menu.append(replyUIAction(ci))
} }
menu.append(shareUIAction(ci)) let fileSource = getLoadedFileSource(ci.file)
menu.append(copyUIAction(ci)) let fileExists = if let fs = fileSource, FileManager.default.fileExists(atPath: getAppFilePath(fs.filePath).path) { true } else { false }
if let fileSource = getLoadedFileSource(ci.file) { 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 case .image = ci.content.msgContent, let image = getLoadedImage(ci.file) {
if image.imageData != nil { if image.imageData != nil {
menu.append(saveFileAction(fileSource)) 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 -> loadPrevMessages = {
val c = chatModel.getChat(cInfo.id) if (chatModel.chatId.value != activeChat.value?.id) return@ChatLayout
val c = chatModel.getChat(chatModel.chatId.value ?: return@ChatLayout)
val firstId = chatModel.chatItems.firstOrNull()?.id val firstId = chatModel.chatItems.firstOrNull()?.id
if (c != null && firstId != null) { if (c != null && firstId != null) {
withApi { withApi {
@ -440,7 +441,8 @@ fun ChatView(chatId: String, chatModel: ChatModel, onComposed: suspend (chatId:
changeNtfsState = { enabled, currentValue -> toggleNotifications(chat, enabled, chatModel, currentValue) }, changeNtfsState = { enabled, currentValue -> toggleNotifications(chat, enabled, chatModel, currentValue) },
onSearchValueChanged = { value -> onSearchValueChanged = { value ->
if (searchText.value == value) return@ChatLayout 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 { withApi {
apiFindMessages(c, chatModel, value) apiFindMessages(c, chatModel, value)
searchText.value = value searchText.value = value
@ -467,7 +469,7 @@ fun ChatLayout(
back: () -> Unit, back: () -> Unit,
info: () -> Unit, info: () -> Unit,
showMemberInfo: (GroupInfo, GroupMember) -> Unit, showMemberInfo: (GroupInfo, GroupMember) -> Unit,
loadPrevMessages: (ChatInfo) -> Unit, loadPrevMessages: () -> Unit,
deleteMessage: (Long, CIDeleteMode) -> Unit, deleteMessage: (Long, CIDeleteMode) -> Unit,
deleteMessages: (List<Long>) -> Unit, deleteMessages: (List<Long>) -> Unit,
receiveFile: (Long, Boolean) -> Unit, receiveFile: (Long, Boolean) -> Unit,
@ -790,7 +792,7 @@ fun BoxWithConstraintsScope.ChatItemsList(
useLinkPreviews: Boolean, useLinkPreviews: Boolean,
linkMode: SimplexLinkMode, linkMode: SimplexLinkMode,
showMemberInfo: (GroupInfo, GroupMember) -> Unit, showMemberInfo: (GroupInfo, GroupMember) -> Unit,
loadPrevMessages: (ChatInfo) -> Unit, loadPrevMessages: () -> Unit,
deleteMessage: (Long, CIDeleteMode) -> Unit, deleteMessage: (Long, CIDeleteMode) -> Unit,
deleteMessages: (List<Long>) -> Unit, deleteMessages: (List<Long>) -> Unit,
receiveFile: (Long, Boolean) -> Unit, receiveFile: (Long, Boolean) -> Unit,
@ -828,9 +830,7 @@ fun BoxWithConstraintsScope.ChatItemsList(
} }
} }
PreloadItems(listState, ChatPagination.UNTIL_PRELOAD_COUNT, chat, chatItems) { c -> PreloadItems(listState, ChatPagination.UNTIL_PRELOAD_COUNT, loadPrevMessages)
loadPrevMessages(c.chatInfo)
}
Spacer(Modifier.size(8.dp)) Spacer(Modifier.size(8.dp))
val reversedChatItems by remember { derivedStateOf { chatItems.reversed().toList() } } val reversedChatItems by remember { derivedStateOf { chatItems.reversed().toList() } }
@ -1150,24 +1150,32 @@ fun BoxWithConstraintsScope.FloatingButtons(
fun PreloadItems( fun PreloadItems(
listState: LazyListState, listState: LazyListState,
remaining: Int = 10, remaining: Int = 10,
chat: Chat, onLoadMore: () -> Unit,
items: List<*>,
onLoadMore: (chat: Chat) -> Unit,
) { ) {
LaunchedEffect(listState, chat, items) { // Prevent situation when initial load and load more happens one after another after selecting a chat with long scroll position from previous selection
snapshotFlow { listState.layoutInfo } val allowLoad = remember { mutableStateOf(false) }
.map { LaunchedEffect(Unit) {
val totalItemsNumber = it.totalItemsCount snapshotFlow { chatModel.chatId.value }
val lastVisibleItemIndex = (it.visibleItemsInfo.lastOrNull()?.index ?: 0) + 1 .filterNotNull()
if (lastVisibleItemIndex > (totalItemsNumber - remaining) && totalItemsNumber >= ChatPagination.INITIAL_COUNT) .collect {
totalItemsNumber allowLoad.value = listState.layoutInfo.totalItemsCount == listState.layoutInfo.visibleItemsInfo.size
else delay(500)
0 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 } .filter { it > 0 }
.collect { .collect {
onLoadMore(chat) onLoadMore()
} }
} }
} }
@ -1439,7 +1447,7 @@ fun PreviewChatLayout() {
back = {}, back = {},
info = {}, info = {},
showMemberInfo = { _, _ -> }, showMemberInfo = { _, _ -> },
loadPrevMessages = { _ -> }, loadPrevMessages = {},
deleteMessage = { _, _ -> }, deleteMessage = { _, _ -> },
deleteMessages = { _ -> }, deleteMessages = { _ -> },
receiveFile = { _, _ -> }, receiveFile = { _, _ -> },
@ -1512,7 +1520,7 @@ fun PreviewGroupChatLayout() {
back = {}, back = {},
info = {}, info = {},
showMemberInfo = { _, _ -> }, showMemberInfo = { _, _ -> },
loadPrevMessages = { _ -> }, loadPrevMessages = {},
deleteMessage = { _, _ -> }, deleteMessage = { _, _ -> },
deleteMessages = {}, deleteMessages = {},
receiveFile = { _, _ -> }, receiveFile = { _, _ -> },

2
cabal.project
View File

@ -14,7 +14,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package source-repository-package
type: git type: git
location: https://github.com/simplex-chat/simplexmq.git location: https://github.com/simplex-chat/simplexmq.git
tag: 1e15d56e92c0549c7ba6a60d2c9d557b2949b0ff tag: 577e3cf14d3c1e6cb6a45b987ca934ed793dac26
source-repository-package source-repository-package
type: git 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. - your device connected via USB or Wi-Fi to the computer.
## The process: ## The process:
- open SimpleX, go to `Database passphrase & export`, enable `App data backup`. This will make other steps working - 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 - _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: - 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, 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. Use `/help address` for other commands.
![simplex-chat](../images/user-addresses.gif) ![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. - zařízení připojené přes USB nebo Wi-Fi k počítači.
## Postup: ## Postup:
- Otevřete SimpleX, přejděte na `Databáze passphrase & export`, povolte `Zálohování dat aplikace`. Tím se zprovozní další kroky - 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. - _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: - 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). 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`. Pro ostatní příkazy použijte `/help address`.
![simplex-chat](/images/user-addresses.gif) ![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. - votre appareil connecté via USB ou Wi-Fi à l'ordinateur.
## La procédure : ## 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 - 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. - 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 : - 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 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. Utilisez `/help address` pour les autres commandes.
![simplex-chat](/images/user-addresses.gif) ![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/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";

363
src/Simplex/Chat.hs
View File

@ -275,28 +275,28 @@ newChatController
logFilePath = logFile, logFilePath = logFile,
contactMergeEnabled contactMergeEnabled
} }
where where
configServers :: DefaultAgentServers configServers :: DefaultAgentServers
configServers = configServers =
let smp' = fromMaybe (smp (defaultServers :: DefaultAgentServers)) (nonEmpty smpServers) let smp' = fromMaybe (smp (defaultServers :: DefaultAgentServers)) (nonEmpty smpServers)
xftp' = fromMaybe (xftp (defaultServers :: DefaultAgentServers)) (nonEmpty xftpServers) xftp' = fromMaybe (xftp (defaultServers :: DefaultAgentServers)) (nonEmpty xftpServers)
in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig} in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig}
agentServers :: ChatConfig -> IO InitialAgentServers agentServers :: ChatConfig -> IO InitialAgentServers
agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do
users <- withTransaction chatStore getUsers users <- withTransaction chatStore getUsers
smp' <- getUserServers users SPSMP smp' <- getUserServers users SPSMP
xftp' <- getUserServers users SPXFTP xftp' <- getUserServers users SPXFTP
pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg} pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg}
where where
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ProtoServerWithAuth p))) getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ProtoServerWithAuth p)))
getUserServers users protocol = case users of getUserServers users protocol = case users of
[] -> pure $ M.fromList [(1, cfgServers protocol defServers)] [] -> pure $ M.fromList [(1, cfgServers protocol defServers)]
_ -> M.fromList <$> initialServers _ -> M.fromList <$> initialServers
where where
initialServers :: IO [(UserId, NonEmpty (ProtoServerWithAuth p))] initialServers :: IO [(UserId, NonEmpty (ProtoServerWithAuth p))]
initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users
userServers :: User -> IO (NonEmpty (ProtoServerWithAuth p)) userServers :: User -> IO (NonEmpty (ProtoServerWithAuth p))
userServers user' = activeAgentServers config protocol <$> withTransaction chatStore (`getProtocolServers` user') userServers user' = activeAgentServers config protocol <$> withTransaction chatStore (`getProtocolServers` user')
activeAgentServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ProtoServerWithAuth p) activeAgentServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ProtoServerWithAuth p)
activeAgentServers ChatConfig {defaultServers} p = activeAgentServers ChatConfig {defaultServers} p =
@ -355,11 +355,12 @@ startChatController subConns enableExpireCIs startXFTPWorkers = do
subscribeUsers :: forall m. ChatMonad' m => Bool -> [User] -> m () subscribeUsers :: forall m. ChatMonad' m => Bool -> [User] -> m ()
subscribeUsers onlyNeeded users = do subscribeUsers onlyNeeded users = do
let (us, us') = partition activeUser users let (us, us') = partition activeUser users
subscribe us vr <- chatVersionRange
subscribe us' subscribe vr us
subscribe vr us'
where where
subscribe :: [User] -> m () subscribe :: VersionRange -> [User] -> m ()
subscribe = mapM_ $ runExceptT . subscribeUserConnections onlyNeeded Agent.subscribeConnections subscribe vr = mapM_ $ runExceptT . subscribeUserConnections vr onlyNeeded Agent.subscribeConnections
startFilesToReceive :: forall m. ChatMonad' m => [User] -> m () startFilesToReceive :: forall m. ChatMonad' m => [User] -> m ()
startFilesToReceive users = do startFilesToReceive users = do
@ -436,7 +437,11 @@ parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
-- | Chat API commands interpreted in context of a local zone -- | Chat API commands interpreted in context of a local zone
processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse 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 ShowActiveUser -> withUser' $ pure . CRActiveUser
CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do
forM_ profile $ \Profile {displayName} -> checkValidName displayName forM_ profile $ \Profile {displayName} -> checkValidName displayName
@ -606,7 +611,7 @@ processChatCommand = \case
. M.assocs . M.assocs
<$> withConnection st (readTVarIO . DB.slow) <$> withConnection st (readTVarIO . DB.slow)
APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do 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) unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRApiChats user previews pure $ CRApiChats user previews
APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of 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) directChat <- withStore (\db -> getDirectChat db user cId pagination search)
pure $ CRApiChat user (AChat SCTDirect directChat) pure $ CRApiChat user (AChat SCTDirect directChat)
CTGroup -> do 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) pure $ CRApiChat user (AChat SCTGroup groupChat)
CTContactRequest -> pure $ chatCmdError (Just user) "not implemented" CTContactRequest -> pure $ chatCmdError (Just user) "not implemented"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIGetChatItems pagination search -> withUser $ \user -> do 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 pure $ CRChatItems user Nothing chatItems
APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do
(aci@(AChatItem cType dir _ ci), versions) <- withStore $ \db -> (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 let itemVersions = if null versions then maybeToList $ mkItemVersion ci else versions
memberDeliveryStatuses <- case (cType, dir) of memberDeliveryStatuses <- case (cType, dir) of
(SCTGroup, SMDSnd) -> do (SCTGroup, SMDSnd) -> do
@ -698,7 +703,7 @@ processChatCommand = \case
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
quoteData _ = throwChatError CEInvalidQuote quoteData _ = throwChatError CEInvalidQuote
CTGroup -> do CTGroup -> do
g@(Group gInfo _) <- withStore $ \db -> getGroup db user chatId g@(Group gInfo _) <- withStore $ \db -> getGroup db vr user chatId
assertUserGroupRole gInfo GRAuthor assertUserGroupRole gInfo GRAuthor
send g send g
where where
@ -803,7 +808,7 @@ processChatCommand = \case
_ -> throwChatError CEInvalidChatItemUpdate _ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
CTGroup -> do 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 assertUserGroupRole gInfo GRAuthor
cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId
case cci of case cci of
@ -839,7 +844,7 @@ processChatCommand = \case
else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete (CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
CTGroup -> do 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 CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}} <- withStore $ \db -> getGroupChatItem db user chatId itemId
case (mode, msgDir, itemSharedMsgId, editable) of case (mode, msgDir, itemSharedMsgId, editable) of
(CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime (CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime
@ -851,7 +856,7 @@ processChatCommand = \case
CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do 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 CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withStore $ \db -> getGroupChatItem db user gId itemId
case (chatDir, itemSharedMsgId) of case (chatDir, itemSharedMsgId) of
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do (CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do
@ -880,7 +885,7 @@ processChatCommand = \case
pure $ CRChatItemReaction user add r pure $ CRChatItemReaction user add r
_ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID"
CTGroup -> 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 (Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do
unless (groupFeatureAllowed SGFReactions g) $ unless (groupFeatureAllowed SGFReactions g) $
throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions))
@ -939,7 +944,7 @@ processChatCommand = \case
ok user ok user
CTGroup -> do CTGroup -> do
withStore $ \db -> do withStore $ \db -> do
Group {groupInfo} <- getGroup db user chatId Group {groupInfo} <- getGroup db vr user chatId
liftIO $ updateGroupUnreadChat db user groupInfo unreadChat liftIO $ updateGroupUnreadChat db user groupInfo unreadChat
ok user ok user
_ -> pure $ chatCmdError (Just user) "not supported" _ -> pure $ chatCmdError (Just user) "not supported"
@ -964,7 +969,7 @@ processChatCommand = \case
withStore' $ \db -> deletePendingContactConnection db userId chatId withStore' $ \db -> deletePendingContactConnection db userId chatId
pure $ CRContactConnectionDeleted user conn pure $ CRContactConnectionDeleted user conn
CTGroup -> do 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 let isOwner = memberRole (membership :: GroupMember) == GROwner
canDelete = isOwner || not (memberCurrent membership) canDelete = isOwner || not (memberCurrent membership)
unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
@ -1007,7 +1012,7 @@ processChatCommand = \case
withStore' $ \db -> deleteContactCIs db user ct withStore' $ \db -> deleteContactCIs db user ct
pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct) pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct)
CTGroup -> do CTGroup -> do
gInfo <- withStore $ \db -> getGroupInfo db user chatId gInfo <- withStore $ \db -> getGroupInfo db vr user chatId
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
deleteFilesAndConns user filesInfo deleteFilesAndConns user filesInfo
withStore' $ \db -> deleteGroupCIs db user gInfo withStore' $ \db -> deleteGroupCIs db user gInfo
@ -1151,7 +1156,7 @@ processChatCommand = \case
user_ <- withStore' (`getUserByAConnId` agentConnId) user_ <- withStore' (`getUserByAConnId` agentConnId)
connEntity_ <- connEntity_ <-
pure user_ $>>= \user -> 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} pure CRNtfMessages {user_, connEntity_, msgTs = msgTs', ntfMessages = map ntfMsgInfo msgs}
APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
ChatConfig {defaultServers} <- asks config ChatConfig {defaultServers} <- asks config
@ -1214,7 +1219,7 @@ processChatCommand = \case
ok user ok user
CTGroup -> do CTGroup -> do
ms <- withStore $ \db -> do ms <- withStore $ \db -> do
Group _ ms <- getGroup db user chatId Group _ ms <- getGroup db vr user chatId
liftIO $ updateGroupSettings db user chatId chatSettings liftIO $ updateGroupSettings db user chatId chatSettings
pure ms pure ms
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId -> forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
@ -1240,10 +1245,10 @@ processChatCommand = \case
connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct) connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct)
pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile) pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile)
APIGroupInfo gId -> withUser $ \user -> do 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 pure $ CRGroupInfo user g s
APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do 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) connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m)
pure $ CRGroupMemberInfo user g m connectionStats pure $ CRGroupMemberInfo user g m connectionStats
APISwitchContact contactId -> withUser $ \user -> do APISwitchContact contactId -> withUser $ \user -> do
@ -1254,7 +1259,7 @@ processChatCommand = \case
pure $ CRContactSwitchStarted user ct connectionStats pure $ CRContactSwitchStarted user ct connectionStats
Nothing -> throwChatError $ CEContactNotActive ct Nothing -> throwChatError $ CEContactNotActive ct
APISwitchGroupMember gId gMemberId -> withUser $ \user -> do 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 case memberConnId m of
Just connId -> do Just connId -> do
connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId) connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId)
@ -1268,7 +1273,7 @@ processChatCommand = \case
pure $ CRContactSwitchAborted user ct connectionStats pure $ CRContactSwitchAborted user ct connectionStats
Nothing -> throwChatError $ CEContactNotActive ct Nothing -> throwChatError $ CEContactNotActive ct
APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do 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 case memberConnId m of
Just connId -> do Just connId -> do
connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId
@ -1283,7 +1288,7 @@ processChatCommand = \case
pure $ CRContactRatchetSyncStarted user ct cStats pure $ CRContactRatchetSyncStarted user ct cStats
Nothing -> throwChatError $ CEContactNotActive ct Nothing -> throwChatError $ CEContactNotActive ct
APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> withChatLock "syncGroupMemberRatchet" $ do 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 case memberConnId m of
Just connId -> do Just connId -> do
cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force
@ -1305,7 +1310,7 @@ processChatCommand = \case
pure $ CRContactCode user ct' code pure $ CRContactCode user ct' code
Nothing -> throwChatError $ CEContactNotActive ct Nothing -> throwChatError $ CEContactNotActive ct
APIGetGroupMemberCode gId gMemberId -> withUser $ \user -> do 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 case activeConn of
Just conn@Connection {connId} -> do Just conn@Connection {connId} -> do
code <- getConnectionCode $ aConnId conn code <- getConnectionCode $ aConnId conn
@ -1487,7 +1492,7 @@ processChatCommand = \case
let chatRef = ChatRef CTDirect ctId let chatRef = ChatRef CTDirect ctId
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc
Left _ -> Left _ ->
withStore' (\db -> runExceptT $ getActiveMembersByName db user name) >>= \case withStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case
Right [(gInfo, member)] -> do Right [(gInfo, member)] -> do
let GroupInfo {localDisplayName = gName} = gInfo let GroupInfo {localDisplayName = gName} = gInfo
GroupMember {localDisplayName = mName} = member GroupMember {localDisplayName = mName} = member
@ -1507,7 +1512,7 @@ processChatCommand = \case
let mc = MCText msg let mc = MCText msg
case memberContactId m of case memberContactId m of
Nothing -> do Nothing -> do
gInfo <- withStore $ \db -> getGroupInfo db user gId gInfo <- withStore $ \db -> getGroupInfo db vr user gId
toView $ CRNoMemberContactCreating user gInfo m toView $ CRNoMemberContactCreating user gInfo m
processChatCommand (APICreateMemberContact gId mId) >>= \case processChatCommand (APICreateMemberContact gId mId) >>= \case
cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do
@ -1567,13 +1572,13 @@ processChatCommand = \case
gVar <- asks random gVar <- asks random
-- [incognito] generate incognito profile for group membership -- [incognito] generate incognito profile for group membership
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing 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 pure $ CRGroupCreated user groupInfo
NewGroup incognito gProfile -> withUser $ \User {userId} -> NewGroup incognito gProfile -> withUser $ \User {userId} ->
processChatCommand $ APINewGroup userId incognito gProfile processChatCommand $ APINewGroup userId incognito gProfile
APIAddMember groupId contactId memRole -> withUser $ \user -> withChatLock "addMember" $ do 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 -- 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_ assertDirectAllowed user MDSnd contact XGrpInv_
let Group gInfo members = group let Group gInfo members = group
Contact {localDisplayName = cName} = contact Contact {localDisplayName = cName} = contact
@ -1603,7 +1608,7 @@ processChatCommand = \case
APIJoinGroup groupId -> withUser $ \user@User {userId} -> do APIJoinGroup groupId -> withUser $ \user@User {userId} -> do
withChatLock "joinGroup" . procCmd $ do withChatLock "joinGroup" . procCmd $ do
(invitation, ct) <- withStore $ \db -> 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 (inv,) <$> getContactViaMember db user fromMember
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
Contact {activeConn} = ct Contact {activeConn} = ct
@ -1621,14 +1626,14 @@ processChatCommand = \case
Nothing -> throwChatError $ CEContactNotActive ct Nothing -> throwChatError $ CEContactNotActive ct
where where
updateCIGroupInvitationStatus user = do 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 case (cInfo, content) of
(DirectChat ct, CIRcvGroupInvitation ciGroupInv memRole) -> do (DirectChat ct, CIRcvGroupInvitation ciGroupInv memRole) -> do
let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = CIGISAccepted} memRole let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = CIGISAccepted} memRole
updateDirectChatItemView user ct itemId aciContent False Nothing updateDirectChatItemView user ct itemId aciContent False Nothing
_ -> pure () -- prohibited _ -> pure () -- prohibited
APIMemberRole groupId memberId memRole -> withUser $ \user -> do 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 if memberId == groupMemberId' membership
then changeMemberRole user gInfo members membership $ SGEUserRole memRole then changeMemberRole user gInfo members membership $ SGEUserRole memRole
else case find ((== memberId) . groupMemberId') members of else case find ((== memberId) . groupMemberId') members of
@ -1652,7 +1657,7 @@ processChatCommand = \case
toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole} pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole}
APIRemoveMember groupId memberId -> withUser $ \user -> do 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 case find ((== memberId) . groupMemberId') members of
Nothing -> throwChatError CEGroupMemberNotFound Nothing -> throwChatError CEGroupMemberNotFound
Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do
@ -1671,7 +1676,7 @@ processChatCommand = \case
deleteOrUpdateMemberRecord user m deleteOrUpdateMemberRecord user m
pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved} pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved}
APILeaveGroup groupId -> withUser $ \user@User {userId} -> do 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 withChatLock "leaveGroup" . procCmd $ do
(msg, _) <- sendGroupMessage user gInfo members XGrpLeave (msg, _) <- sendGroupMessage user gInfo members XGrpLeave
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft)
@ -1683,7 +1688,7 @@ processChatCommand = \case
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft
pure $ CRLeftMemberUser user gInfo {membership = membership {memberStatus = GSMemLeft}} pure $ CRLeftMemberUser user gInfo {membership = membership {memberStatus = GSMemLeft}}
APIListMembers groupId -> withUser $ \user -> 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 AddMember gName cName memRole -> withUser $ \user -> do
(groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName (groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName
processChatCommand $ APIAddMember groupId contactId memRole processChatCommand $ APIAddMember groupId contactId memRole
@ -1705,23 +1710,23 @@ processChatCommand = \case
groupId <- withStore $ \db -> getGroupIdByName db user gName groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIListMembers groupId processChatCommand $ APIListMembers groupId
APIListGroups userId contactId_ search_ -> withUserId userId $ \user -> 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 ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do
ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName
processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_ processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_
APIUpdateGroupProfile groupId p' -> withUser $ \user -> do 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' runUpdateGroupProfile user g p'
UpdateGroupNames gName GroupProfile {displayName, fullName} -> UpdateGroupNames gName GroupProfile {displayName, fullName} ->
updateGroupProfileByName gName $ \p -> p {displayName, fullName} updateGroupProfileByName gName $ \p -> p {displayName, fullName}
ShowGroupProfile gName -> withUser $ \user -> ShowGroupProfile gName -> withUser $ \user ->
CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db user gName) CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db vr user gName)
UpdateGroupDescription gName description -> UpdateGroupDescription gName description ->
updateGroupProfileByName gName $ \p -> p {description} updateGroupProfileByName gName $ \p -> p {description}
ShowGroupDescription gName -> withUser $ \user -> 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 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 assertUserGroupRole gInfo GRAdmin
when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole
groupLinkId <- GroupLinkId <$> drgRandomBytes 16 groupLinkId <- GroupLinkId <$> drgRandomBytes 16
@ -1731,22 +1736,22 @@ processChatCommand = \case
withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode
pure $ CRGroupLinkCreated user gInfo cReq mRole pure $ CRGroupLinkCreated user gInfo cReq mRole
APIGroupLinkMemberRole groupId mRole' -> withUser $ \user -> withChatLock "groupLinkMemberRole " $ do 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 (groupLinkId, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
assertUserGroupRole gInfo GRAdmin assertUserGroupRole gInfo GRAdmin
when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole' when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole'
when (mRole' /= mRole) $ withStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole' when (mRole' /= mRole) $ withStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole'
pure $ CRGroupLink user gInfo groupLink mRole' pure $ CRGroupLink user gInfo groupLink mRole'
APIDeleteGroupLink groupId -> withUser $ \user -> withChatLock "deleteGroupLink" $ do 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 deleteGroupLink' user gInfo
pure $ CRGroupLinkDeleted user gInfo pure $ CRGroupLinkDeleted user gInfo
APIGetGroupLink groupId -> withUser $ \user -> do 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 (_, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
pure $ CRGroupLink user gInfo groupLink mRole pure $ CRGroupLink user gInfo groupLink mRole
APICreateMemberContact gId gMemberId -> withUser $ \user -> do 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 assertUserGroupRole g GRAuthor
unless (groupFeatureAllowed SGFDirectMessages g) $ throwChatError $ CECommandError "direct messages not allowed" unless (groupFeatureAllowed SGFDirectMessages g) $ throwChatError $ CECommandError "direct messages not allowed"
case memberConn m of case memberConn m of
@ -1762,7 +1767,7 @@ processChatCommand = \case
pure $ CRNewMemberContact user ct g m pure $ CRNewMemberContact user ct g m
_ -> throwChatError CEGroupMemberNotActive _ -> throwChatError CEGroupMemberNotActive
APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do 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" when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent"
case memberConn m of case memberConn m of
Just mConn -> do Just mConn -> do
@ -1794,7 +1799,7 @@ processChatCommand = \case
processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc
LastChats count_ -> withUser' $ \user -> do LastChats count_ -> withUser' $ \user -> do
let count = fromMaybe 5000 count_ 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) unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRChats previews pure $ CRChats previews
LastMessages (Just chatName) count search -> withUser $ \user -> do LastMessages (Just chatName) count search -> withUser $ \user -> do
@ -1802,22 +1807,22 @@ processChatCommand = \case
chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search
pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp) pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp)
LastMessages Nothing count search -> withUser $ \user -> do 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 pure $ CRChatItems user Nothing chatItems
LastChatItemId (Just chatName) index -> withUser $ \user -> do LastChatItemId (Just chatName) index -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing) chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing)
pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp) pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp)
LastChatItemId Nothing index -> withUser $ \user -> do 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) pure $ CRChatItemId user (fmap aChatItemId . listToMaybe $ chatItems)
ShowChatItem (Just itemId) -> withUser $ \user -> do ShowChatItem (Just itemId) -> withUser $ \user -> do
chatItem <- withStore $ \db -> do chatItem <- withStore $ \db -> do
chatRef <- getChatRefViaItemId db user itemId chatRef <- getChatRefViaItemId db user itemId
getAChatItem db user chatRef itemId getAChatItem db vr user chatRef itemId
pure $ CRChatItems user Nothing ((: []) chatItem) pure $ CRChatItems user Nothing ((: []) chatItem)
ShowChatItem Nothing -> withUser $ \user -> do 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 pure $ CRChatItems user Nothing chatItems
ShowChatItemInfo chatName msg -> withUser $ \user -> do ShowChatItemInfo chatName msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
@ -1859,19 +1864,19 @@ processChatCommand = \case
| not (null fts) && all fileCancelledOrCompleteSMP fts -> | not (null fts) && all fileCancelledOrCompleteSMP fts ->
throwChatError $ CEFileCancel fileId "file transfer is complete" throwChatError $ CEFileCancel fileId "file transfer is complete"
| otherwise -> do | otherwise -> do
fileAgentConnIds <- cancelSndFile user ftm fts True fileAgentConnIds <- cancelSndFile user ftm fts True
deleteAgentConnectionsAsync user fileAgentConnIds deleteAgentConnectionsAsync user fileAgentConnIds
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
withStore (\db -> getChatRefByFileId db user fileId) >>= \case withStore (\db -> getChatRefByFileId db user fileId) >>= \case
ChatRef CTDirect contactId -> do ChatRef CTDirect contactId -> do
contact <- withStore $ \db -> getContact db user contactId contact <- withStore $ \db -> getContact db user contactId
void . sendDirectContactMessage contact $ XFileCancel sharedMsgId void . sendDirectContactMessage contact $ XFileCancel sharedMsgId
ChatRef CTGroup groupId -> do ChatRef CTGroup groupId -> do
Group gInfo ms <- withStore $ \db -> getGroup db user groupId Group gInfo ms <- withStore $ \db -> getGroup db vr user groupId
void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
ci <- withStore $ \db -> getChatItemByFileId db user fileId ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
pure $ CRSndFileCancelled user ci ftm fts pure $ CRSndFileCancelled user ci ftm fts
where where
fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} = fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} =
s == FSCancelled || (s == FSComplete && isNothing xftpSndFile) s == FSCancelled || (s == FSComplete && isNothing xftpSndFile)
@ -1879,25 +1884,25 @@ processChatCommand = \case
| cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled" | cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled"
| rcvFileComplete fileStatus -> throwChatError $ CEFileCancel fileId "file transfer is complete" | rcvFileComplete fileStatus -> throwChatError $ CEFileCancel fileId "file transfer is complete"
| otherwise -> case xftpRcvFile of | otherwise -> case xftpRcvFile of
Nothing -> do Nothing -> do
cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user) cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user)
ci <- withStore $ \db -> getChatItemByFileId db user fileId ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
pure $ CRRcvFileCancelled user ci ftr pure $ CRRcvFileCancelled user ci ftr
Just XFTPRcvFile {agentRcvFileId} -> do Just XFTPRcvFile {agentRcvFileId} -> do
forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do
fsFilePath <- toFSFilePath filePath fsFilePath <- toFSFilePath filePath
liftIO $ removeFile fsFilePath `catchAll_` pure () liftIO $ removeFile fsFilePath `catchAll_` pure ()
forM_ agentRcvFileId $ \(AgentRcvFileId aFileId) -> forM_ agentRcvFileId $ \(AgentRcvFileId aFileId) ->
withAgent (`xftpDeleteRcvFile` aFileId) withAgent (`xftpDeleteRcvFile` aFileId)
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ do liftIO $ do
updateCIFileStatus db user fileId CIFSRcvInvitation updateCIFileStatus db user fileId CIFSRcvInvitation
updateRcvFileStatus db fileId FSNew updateRcvFileStatus db fileId FSNew
updateRcvFileAgentId db fileId Nothing updateRcvFileAgentId db fileId Nothing
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
pure $ CRRcvFileCancelled user ci ftr pure $ CRRcvFileCancelled user ci ftr
FileStatus fileId -> withUser $ \user -> do 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 case file of
Just CIFile {fileProtocol = FPXFTP} -> Just CIFile {fileProtocol = FPXFTP} ->
pure $ CRFileTransferStatusXFTP user ci pure $ CRFileTransferStatusXFTP user ci
@ -2198,7 +2203,7 @@ processChatCommand = \case
updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse
updateGroupProfileByName gName update = withUser $ \user -> do updateGroupProfileByName gName update = withUser $ \user -> do
g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> 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 runUpdateGroupProfile user g $ update p
withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
withCurrentCall ctId action = do withCurrentCall ctId action = do
@ -2313,15 +2318,16 @@ processChatCommand = \case
ctId <- getContactIdByName db user name ctId <- getContactIdByName db user name
Contact {chatSettings} <- getContact db user ctId Contact {chatSettings} <- getContact db user ctId
pure (ctId, chatSettings) pure (ctId, chatSettings)
CTGroup -> withStore $ \db -> do CTGroup ->
gId <- getGroupIdByName db user name withStore $ \db -> do
GroupInfo {chatSettings} <- getGroupInfo db user gId gId <- getGroupIdByName db user name
pure (gId, chatSettings) GroupInfo {chatSettings} <- getGroupInfo db vr user gId
pure (gId, chatSettings)
_ -> throwChatError $ CECommandError "not supported" _ -> throwChatError $ CECommandError "not supported"
processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings
connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan
connectPlan user (ACR SCMInvitation cReq) = do 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 Nothing -> pure $ CPInvitationLink ILPOk
Just (RcvDirectMsgConnection conn ct_) -> do Just (RcvDirectMsgConnection conn ct_) -> do
let Connection {connStatus, contactConnInitiated} = conn let Connection {connStatus, contactConnInitiated} = conn
@ -2351,7 +2357,7 @@ processChatCommand = \case
withStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case withStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case
Just _ -> pure $ CPContactAddress CAPOwnLink Just _ -> pure $ CPContactAddress CAPOwnLink
Nothing -> Nothing ->
withStore' (\db -> getContactConnEntityByConnReqHash db user cReqHashes) >>= \case withStore' (\db -> getContactConnEntityByConnReqHash db vr user cReqHashes) >>= \case
Nothing -> Nothing ->
withStore' (\db -> getContactWithoutConnViaAddress db user cReqSchemas) >>= \case withStore' (\db -> getContactWithoutConnViaAddress db user cReqSchemas) >>= \case
Nothing -> pure $ CPContactAddress CAPOk Nothing -> pure $ CPContactAddress CAPOk
@ -2364,11 +2370,11 @@ processChatCommand = \case
Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
-- group link -- group link
Just _ -> Just _ ->
withStore' (\db -> getGroupInfoByUserContactLinkConnReq db user cReqSchemas) >>= \case withStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case
Just g -> pure $ CPGroupLink (GLPOwnLink g) Just g -> pure $ CPGroupLink (GLPOwnLink g)
Nothing -> do Nothing -> do
connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db user cReqHashes connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes
gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db user cReqHashes gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes
case (gInfo_, connEnt_) of case (gInfo_, connEnt_) of
(Nothing, Nothing) -> pure $ CPGroupLink GLPOk (Nothing, Nothing) -> pure $ CPGroupLink GLPOk
(Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> pure $ CPGroupLink GLPConnectingConfirmReconnect (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 unless (fileStatus == RFSNew) $ case fileStatus of
RFSCancelled _ -> throwChatError $ CEFileCancelled fName RFSCancelled _ -> throwChatError $ CEFileCancelled fName
_ -> throwChatError $ CEFileAlreadyReceiving fName _ -> throwChatError $ CEFileAlreadyReceiving fName
vr <- chatVersionRange
case (xftpRcvFile, fileConnReq) of case (xftpRcvFile, fileConnReq) of
-- direct file protocol -- direct file protocol
(Nothing, Just connReq) -> do (Nothing, Just connReq) -> do
@ -2606,14 +2613,14 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
dm <- directMessage $ XFileAcpt fName dm <- directMessage $ XFileAcpt fName
connIds <- joinAgentConnectionAsync user True connReq dm subMode connIds <- joinAgentConnectionAsync user True connReq dm subMode
filePath <- getRcvFilePath fileId filePath_ fName True 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 -- XFTP
(Just XFTPRcvFile {}, _) -> do (Just XFTPRcvFile {}, _) -> do
filePath <- getRcvFilePath fileId filePath_ fName False filePath <- getRcvFilePath fileId filePath_ fName False
(ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do (ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do
-- marking file as accepted and reading description in the same transaction -- marking file as accepted and reading description in the same transaction
-- to prevent race condition with appending description -- to prevent race condition with appending description
ci <- xftpAcceptRcvFT db user fileId filePath ci <- xftpAcceptRcvFT db vr user fileId filePath
rfd <- getRcvFileDescrByRcvFileId db fileId rfd <- getRcvFileDescrByRcvFileId db fileId
pure (ci, rfd) pure (ci, rfd)
receiveViaCompleteFD user fileId rfd cryptoArgs receiveViaCompleteFD user fileId rfd cryptoArgs
@ -2637,10 +2644,11 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
acceptFile cmdFunction send = do acceptFile cmdFunction send = do
filePath <- getRcvFilePath fileId filePath_ fName True filePath <- getRcvFilePath fileId filePath_ fName True
inline <- receiveInline inline <- receiveInline
vr <- chatVersionRange
if if
| inline -> do | inline -> do
-- accepting inline -- 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 sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
send $ XFileAcptInv sharedMsgId Nothing fName send $ XFileAcptInv sharedMsgId Nothing fName
pure ci pure ci
@ -2649,7 +2657,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
-- accepting via a new connection -- accepting via a new connection
subMode <- chatReadVar subscriptionMode subMode <- chatReadVar subscriptionMode
connIds <- createAgentConnectionAsync user cmdFunction True SCMInvitation subMode 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 :: m Bool
receiveInline = do receiveInline = do
ChatConfig {fileChunkSize, inlineFiles = InlineFilesConfig {receiveChunks, offerChunks}} <- asks config 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 :: ChatMonad m => User -> FileTransferId -> m ()
startReceivingFile user fileId = do startReceivingFile user fileId = do
vr <- chatVersionRange
ci <- withStoreCtx (Just "startReceivingFile, updateRcvFileStatus ...") $ \db -> do ci <- withStoreCtx (Just "startReceivingFile, updateRcvFileStatus ...") $ \db -> do
liftIO $ updateRcvFileStatus db fileId FSConnected liftIO $ updateRcvFileStatus db fileId FSConnected
liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1 liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
toView $ CRRcvFileStart user ci toView $ CRRcvFileStart user ci
getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> Bool -> m FilePath 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 ())) type AgentBatchSubscribe m = AgentClient -> [ConnId] -> ExceptT AgentErrorType m (Map ConnId (Either AgentErrorType ()))
subscribeUserConnections :: forall m. ChatMonad m => Bool -> AgentBatchSubscribe m -> User -> m () subscribeUserConnections :: forall m. ChatMonad m => VersionRange -> Bool -> AgentBatchSubscribe m -> User -> m ()
subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do subscribeUserConnections vr onlyNeeded agentBatchSubscribe user@User {userId} = do
-- get user connections -- get user connections
ce <- asks $ subscriptionEvents . config ce <- asks $ subscriptionEvents . config
(conns, cts, ucs, gs, ms, sfts, rfts, pcs) <- (conns, cts, ucs, gs, ms, sfts, rfts, pcs) <-
if onlyNeeded if onlyNeeded
then do 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 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) pure (conns, cts, ucs, [], ms, sfts, rfts, pcs)
else do else do
@ -2846,7 +2855,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
getContactConns :: m ([ConnId], Map ConnId Contact) getContactConns :: m ([ConnId], Map ConnId Contact)
getContactConns = do getContactConns = do
cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") getUserContacts 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) pure (connIds, M.fromList $ zip connIds cts)
getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact) getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact)
getUserContactLinkConns = do getUserContactLinkConns = do
@ -2855,7 +2864,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
pure (connIds, M.fromList $ zip connIds ucs) pure (connIds, M.fromList $ zip connIds ucs)
getGroupMemberConns :: m ([Group], [ConnId], Map ConnId GroupMember) getGroupMemberConns :: m ([Group], [ConnId], Map ConnId GroupMember)
getGroupMemberConns = do 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 let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) (filter (not . memberRemoved) ms)) gs
pure (gs, map fst mPairs, M.fromList mPairs) pure (gs, map fst mPairs, M.fromList mPairs)
getSndFileTransferConns :: m ([ConnId], Map ConnId SndFileTransfer) getSndFileTransferConns :: m ([ConnId], Map ConnId SndFileTransfer)
@ -3030,12 +3039,13 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do
ts <- liftIO getCurrentTime ts <- liftIO getCurrentTime
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts
waitChatStarted waitChatStarted
vr <- chatVersionRange
case cType of case cType of
CTDirect -> do CTDirect -> do
(ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId (ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
deleteDirectCI user ct ci True True >>= toView deleteDirectCI user ct ci True True >>= toView
CTGroup -> do 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 deletedTs <- liftIO getCurrentTime
deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView
_ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType" _ -> 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 :: forall m. ChatMonad m => User -> Int64 -> Bool -> m ()
expireChatItems user@User {userId} ttl sync = do expireChatItems user@User {userId} ttl sync = do
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
vr <- chatVersionRange
let expirationDate = addUTCTime (-1 * fromIntegral ttl) currentTs 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 -- 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 createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs
contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user) contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user)
loop contacts $ processContact expirationDate 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 loop groups $ processGroup expirationDate createdAtCutoff
where where
loop :: [a] -> (a -> m ()) -> m () loop :: [a] -> (a -> m ()) -> m ()
@ -3089,9 +3100,10 @@ processAgentMessage _ connId (DEL_RCVQ srv qId err_) =
toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_ toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_
processAgentMessage _ connId DEL_CONN = processAgentMessage _ connId DEL_CONN =
toView $ CRAgentConnDeleted (AgentConnId connId) toView $ CRAgentConnDeleted (AgentConnId connId)
processAgentMessage corrId connId msg = processAgentMessage corrId connId msg = do
vr <- chatVersionRange
withStore' (`getUserByAConnId` AgentConnId connId) >>= \case 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) _ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone -> m () 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 (ft@FileTransferMeta {fileId, cancelled}, sfts) <- withStore $ \db -> do
fileId <- getXFTPSndFileDBId db user $ AgentSndFileId aFileId fileId <- getXFTPSndFileDBId db user $ AgentSndFileId aFileId
getSndFileTransfer db user fileId getSndFileTransfer db user fileId
vr <- chatVersionRange
unless cancelled $ case msg of unless cancelled $ case msg of
SFPROG sndProgress sndTotal -> do SFPROG sndProgress sndTotal -> do
let status = CIFSSndTransfer {sndProgress, sndTotal} let status = CIFSSndTransfer {sndProgress, sndTotal}
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId status liftIO $ updateCIFileStatus db user fileId status
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal
SFDONE sndDescr rfds -> do SFDONE sndDescr rfds -> do
withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr) withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
ci@(AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) <- 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 case (msgId_, itemDeleted) of
(Just sharedMsgId, Nothing) -> do (Just sharedMsgId, Nothing) -> do
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send" 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)) forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchChatError` (toView . CRChatError (Just user))
ci' <- withStore $ \db -> do ci' <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
withAgent (`xftpDeleteSndFileInternal` aFileId) withAgent (`xftpDeleteSndFileInternal` aFileId)
toView $ CRSndFileCompleteXFTP user ci' ft toView $ CRSndFileCompleteXFTP user ci' ft
where where
@ -3180,11 +3193,11 @@ processAgentMsgSndFile _corrId aFileId msg =
| temporaryAgentError e -> | temporaryAgentError e ->
throwChatError $ CEXFTPSndFile fileId (AgentSndFileId aFileId) e throwChatError $ CEXFTPSndFile fileId (AgentSndFileId aFileId) e
| otherwise -> do | otherwise -> do
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId CIFSSndError liftIO $ updateFileCancelled db user fileId CIFSSndError
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
withAgent (`xftpDeleteSndFileInternal` aFileId) withAgent (`xftpDeleteSndFileInternal` aFileId)
toView $ CRSndFileError user ci toView $ CRSndFileError user ci
where where
fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text
fileDescrText = safeDecodeUtf8 . strEncode fileDescrText = safeDecodeUtf8 . strEncode
@ -3229,12 +3242,13 @@ processAgentMsgRcvFile _corrId aFileId msg =
ft@RcvFileTransfer {fileId} <- withStore $ \db -> do ft@RcvFileTransfer {fileId} <- withStore $ \db -> do
fileId <- getXFTPRcvFileDBId db $ AgentRcvFileId aFileId fileId <- getXFTPRcvFileDBId db $ AgentRcvFileId aFileId
getRcvFileTransfer db user fileId getRcvFileTransfer db user fileId
vr <- chatVersionRange
unless (rcvFileCompleteOrCancelled ft) $ case msg of unless (rcvFileCompleteOrCancelled ft) $ case msg of
RFPROG rcvProgress rcvTotal -> do RFPROG rcvProgress rcvTotal -> do
let status = CIFSRcvTransfer {rcvProgress, rcvTotal} let status = CIFSRcvTransfer {rcvProgress, rcvTotal}
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId status liftIO $ updateCIFileStatus db user fileId status
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal
RFDONE xftpPath -> RFDONE xftpPath ->
case liveRcvFileTransferPath ft of case liveRcvFileTransferPath ft of
@ -3246,22 +3260,22 @@ processAgentMsgRcvFile _corrId aFileId msg =
liftIO $ do liftIO $ do
updateRcvFileStatus db fileId FSComplete updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete updateCIFileStatus db user fileId CIFSRcvComplete
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
agentXFTPDeleteRcvFile aFileId fileId agentXFTPDeleteRcvFile aFileId fileId
toView $ CRRcvFileComplete user ci toView $ CRRcvFileComplete user ci
RFERR e RFERR e
| temporaryAgentError e -> | temporaryAgentError e ->
throwChatError $ CEXFTPRcvFile fileId (AgentRcvFileId aFileId) e throwChatError $ CEXFTPRcvFile fileId (AgentRcvFileId aFileId) e
| otherwise -> do | otherwise -> do
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId CIFSRcvError liftIO $ updateFileCancelled db user fileId CIFSRcvError
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
agentXFTPDeleteRcvFile aFileId fileId agentXFTPDeleteRcvFile aFileId fileId
toView $ CRRcvFileError user ci e toView $ CRRcvFileError user ci e
processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m () processAgentMessageConn :: forall m. ChatMonad m => VersionRange -> User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do
entity <- withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= updateConnStatus entity <- withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus
case agentMessage of case agentMessage of
END -> case entity of END -> case entity of
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
@ -3407,7 +3421,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
XOk -> pure () XOk -> pure ()
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok" _ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
CON -> CON ->
withStore' (\db -> getViaGroupMember db user ct) >>= \case withStore' (\db -> getViaGroupMember db vr user ct) >>= \case
Nothing -> do Nothing -> do
-- [incognito] print incognito profile used for this contact -- [incognito] print incognito profile used for this contact
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) 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) ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
forM_ groupId_ $ \groupId -> do forM_ groupId_ $ \groupId -> do
groupInfo <- withStore $ \db -> getGroupInfo db user groupId groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId
subMode <- chatReadVar subscriptionMode subMode <- chatReadVar subscriptionMode
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
gVar <- asks random gVar <- asks random
@ -3596,7 +3610,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
profileToSend = profileToSendOnAccept user profileMode profileToSend = profileToSendOnAccept user profileMode
void $ sendDirectMessage conn (XGrpLinkMem profileToSend) (GroupId groupId) void $ sendDirectMessage conn (XGrpLinkMem profileToSend) (GroupId groupId)
sendIntroductions members = do sendIntroductions members = do
intros <- withStore' $ \db -> createIntroductions db members m intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m
shuffledIntros <- liftIO $ shuffleIntros intros shuffledIntros <- liftIO $ shuffleIntros intros
if isCompatibleRange (memberChatVRange' m) batchSendVRange if isCompatibleRange (memberChatVRange' m) batchSendVRange
then do then do
@ -3886,7 +3900,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
CON -> do CON -> do
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateSndFileStatus db ft FSConnected 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 toView $ CRSndFileStart user ci ft
sendFileChunk user ft sendFileChunk user ft
SENT msgId -> do SENT msgId -> do
@ -3900,7 +3914,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
getChatRefByFileId db user fileId >>= \case getChatRefByFileId db user fileId >>= \case
ChatRef CTDirect _ -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled ChatRef CTDirect _ -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled
_ -> pure () _ -> pure ()
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
toView $ CRSndFileRcvCancelled user ci ft toView $ CRSndFileRcvCancelled user ci ft
_ -> throwChatError $ CEFileSend fileId err _ -> throwChatError $ CEFileSend fileId err
MSG meta _ _ -> withAckMessage' agentConnId conn meta $ pure () MSG meta _ _ -> withAckMessage' agentConnId conn meta $ pure ()
@ -3966,7 +3980,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
FileChunkCancel -> FileChunkCancel ->
unless (rcvFileCompleteOrCancelled ft) $ do unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) 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 toView $ CRRcvFileSndCancelled user ci ft
FileChunk {chunkNo, chunkBytes = chunk} -> do FileChunk {chunkNo, chunkBytes = chunk} -> do
case integrity of case integrity of
@ -3989,7 +4003,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
updateRcvFileStatus db fileId FSComplete updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete updateCIFileStatus db user fileId CIFSRcvComplete
deleteRcvFileChunks db ft deleteRcvFileChunks db ft
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
toView $ CRRcvFileComplete user ci toView $ CRRcvFileComplete user ci
forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn) forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn)
RcvChunkDuplicate -> ack $ pure () RcvChunkDuplicate -> ack $ pure ()
@ -4032,7 +4046,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ct <- acceptContactRequestAsync user cReq incognitoProfile True ct <- acceptContactRequestAsync user cReq incognitoProfile True
toView $ CRAcceptingContactRequest user ct toView $ CRAcceptingContactRequest user ct
Just groupId -> do Just groupId -> do
gInfo <- withStore $ \db -> getGroupInfo db user groupId gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
if isCompatibleRange chatVRange groupLinkNoContactVRange if isCompatibleRange chatVRange groupLinkNoContactVRange
then do then do
@ -4525,14 +4539,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ft <- withStore (\db -> getRcvFileTransfer db user fileId) ft <- withStore (\db -> getRcvFileTransfer db user fileId)
unless (rcvFileCompleteOrCancelled ft) $ do unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) 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 toView $ CRRcvFileSndCancelled user ci ft
xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m () xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInv ct sharedMsgId fileConnReq_ fName msgMeta = do xFileAcptInv ct sharedMsgId fileConnReq_ fName msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId 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 assertSMPAcceptNotProhibited ci
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId) 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 -- [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 -- receiving inline
_ -> do _ -> do
event <- withStore $ \db -> 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 sft <- createSndDirectInlineFT db ct ft
pure $ CRSndFileStart user ci' sft pure $ CRSndFileStart user ci' sft
toView event toView event
@ -4575,7 +4589,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do
liftIO $ updateSndFileStatus db sft FSComplete liftIO $ updateSndFileStatus db sft FSComplete
liftIO $ deleteSndFileChunks db sft liftIO $ deleteSndFileChunks db sft
updateDirectCIFileStatus db user fileId CIFSSndComplete updateDirectCIFileStatus db vr user fileId CIFSSndComplete
case file of case file of
Just CIFile {fileProtocol = FPXFTP} -> do Just CIFile {fileProtocol = FPXFTP} -> do
ft <- withStore $ \db -> getFileTransferMeta db user fileId 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) ft <- withStore (\db -> getRcvFileTransfer db user fileId)
unless (rcvFileCompleteOrCancelled ft) $ do unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) 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 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 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" (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 -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> m ()
xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId 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 assertSMPAcceptNotProhibited ci
-- TODO check that it's not already accepted -- TODO check that it's not already accepted
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId) 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 (_, Just conn) -> do
-- receiving inline -- receiving inline
event <- withStore $ \db -> do 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 sft <- liftIO $ createSndGroupInlineFT db m conn ft
pure $ CRSndFileStart user ci' sft pure $ CRSndFileStart user ci' sft
toView event toView event
@ -4668,7 +4682,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c) when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile -- [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' if sameGroupLinkId groupLinkId groupLinkId'
then do then do
subMode <- chatReadVar subscriptionMode subMode <- chatReadVar subscriptionMode
@ -5019,14 +5034,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
associateMemberWithContact :: Contact -> GroupMember -> m Contact associateMemberWithContact :: Contact -> GroupMember -> m Contact
associateMemberWithContact c1 m2@GroupMember {groupId} = do associateMemberWithContact c1 m2@GroupMember {groupId} = do
withStore' $ \db -> associateMemberWithContactRecord db user c1 m2 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 toView $ CRContactAndMemberAssociated user c1 g m2 c1
pure c1 pure c1
associateContactWithMember :: GroupMember -> Contact -> m Contact associateContactWithMember :: GroupMember -> Contact -> m Contact
associateContactWithMember m1@GroupMember {groupId} c2 = do associateContactWithMember m1@GroupMember {groupId} c2 = do
c2' <- withStore $ \db -> associateContactWithMemberRecord db user m1 c2 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' toView $ CRContactAndMemberAssociated user c2 g m1 c2'
pure c2' pure c2'
@ -5041,7 +5056,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRContactConnecting user ct toView $ CRContactConnecting user ct
pure conn' pure conn'
XGrpLinkInv glInv -> do 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 toView $ CRGroupLinkConnecting user gInfo host
pure conn' pure conn'
-- TODO show/log error, other events in SMP confirmation -- TODO show/log error, other events in SMP confirmation
@ -5441,14 +5456,15 @@ parseChatMessage conn s = do
sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m () sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m ()
sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} = 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 withStore' (`createSndFileChunk` ft) >>= \case
Just chunkNo -> sendFileChunkNo ft chunkNo Just chunkNo -> sendFileChunkNo ft chunkNo
Nothing -> do Nothing -> do
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateSndFileStatus db ft FSComplete liftIO $ updateSndFileStatus db ft FSComplete
liftIO $ deleteSndFileChunks db ft liftIO $ deleteSndFileChunks db ft
updateDirectCIFileStatus db user fileId CIFSSndComplete updateDirectCIFileStatus db vr user fileId CIFSSndComplete
toView $ CRSndFileComplete user ci ft toView $ CRSndFileComplete user ci ft
closeFileHandle fileId sndFiles closeFileHandle fileId sndFiles
deleteAgentConnectionAsync user acId deleteAgentConnectionAsync user acId
@ -5613,8 +5629,8 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do
createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage
createSndMessage chatMsgEvent connOrGroupId = do createSndMessage chatMsgEvent connOrGroupId = do
gVar <- asks random gVar <- asks random
ChatConfig {chatVRange} <- asks config vr <- chatVersionRange
withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage chatVRange) withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage vr)
where where
encodeMessage chatVRange sharedMsgId = encodeMessage chatVRange sharedMsgId =
encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent} 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 :: m [Either ChatError SndMessage]
createSndMessages = do createSndMessages = do
gVar <- asks random gVar <- asks random
ChatConfig {chatVRange} <- asks config vr <- chatVersionRange
withStoreBatch $ \db -> map (createMsg db gVar chatVRange) (toList events) withStoreBatch $ \db -> map (createMsg db gVar vr) (toList events)
createMsg db gVar chatVRange evnt = do createMsg db gVar chatVRange evnt = do
r <- runExceptT $ createNewSndMessage db gVar (GroupId groupId) evnt (encodeMessage chatVRange evnt) r <- runExceptT $ createNewSndMessage db gVar (GroupId groupId) evnt (encodeMessage chatVRange evnt)
pure $ first ChatErrorStore r 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 :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString
directMessage chatMsgEvent = do directMessage chatMsgEvent = do
ChatConfig {chatVRange} <- asks config chatVRange <- chatVersionRange
let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent} let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}
case r of case r of
ECMEncoded encodedBody -> pure . LB.toStrict $ encodedBody ECMEncoded encodedBody -> pure . LB.toStrict $ encodedBody
@ -6103,6 +6119,11 @@ waitChatStarted = do
agentStarted <- asks agentAsync agentStarted <- asks agentAsync
atomically $ readTVar agentStarted >>= \a -> unless (isJust a) retry 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 :: Parser ChatCommand
chatCommandP = chatCommandP =
choice 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 :: Query
m20231215_recreate_msg_deliveries = m20231215_recreate_msg_deliveries =
[sql| [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 INDEX msg_delivery_events_msg_delivery_id;
DROP TABLE msg_delivery_events; 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.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version) 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 :: Version
currentChatVersion = 5 currentChatVersion = 5
-- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
supportedChatVRange :: VersionRange supportedChatVRange :: VersionRange
supportedChatVRange = mkVersionRange 1 currentChatVersion 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.Transport
import Simplex.Chat.Remote.Types import Simplex.Chat.Remote.Types
import Simplex.FileTransfer.Description (FileDigest (..)) import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.Messaging.Agent.Client (agentDRG)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Lazy (LazyByteString) 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 Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Util (eitherToMaybe) import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version (VersionRange)
getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity getConnectionEntity :: DB.Connection -> VersionRange -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db user@User {userId, userContactId} agentConnId = do getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
c@Connection {connType, entityId} <- getConnection_ c@Connection {connType, entityId} <- getConnection_
case entityId of case entityId of
Nothing -> Nothing ->
@ -115,7 +116,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
(groupMemberId, userId, userContactId) (groupMemberId, userId, userContactId)
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember) toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
toGroupAndMember c (groupInfoRow :. memberRow) = toGroupAndMember c (groupInfoRow :. memberRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = Just c}) in (groupInfo, (member :: GroupMember) {activeConn = Just c})
getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer 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_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
userContact_ _ = Left SEUserContactLinkNotFound userContact_ _ = Left SEUserContactLinkNotFound
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity) getConnectionEntityByConnReq :: DB.Connection -> VersionRange -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do getConnectionEntityByConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
connId_ <- connId_ <-
maybeFirstRow fromOnly $ maybeFirstRow fromOnly $
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2) 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: -- search connection for connection plan:
-- multiple connections can have same via_contact_uri_hash if request was repeated; -- 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; -- 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 -- deleted connections are filtered out to allow re-connecting via same contact address
getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity) getContactConnEntityByConnReqHash :: DB.Connection -> VersionRange -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2) = do
connId_ <- connId_ <-
maybeFirstRow fromOnly $ maybeFirstRow fromOnly $
DB.query DB.query
@ -183,14 +184,14 @@ getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) =
) )
|] |]
(userId, cReqHash1, cReqHash2, ConnDeleted) (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.Connection -> VersionRange -> IO ([ConnId], [ConnectionEntity])
getConnectionsToSubscribe db = do getConnectionsToSubscribe db vr = do
aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1" aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1"
entities <- forM aConnIds $ \acId -> do entities <- forM aConnIds $ \acId -> do
getUserByAConnId db acId >>= \case getUserByAConnId db acId >>= \case
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db user acId) Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db vr user acId)
Nothing -> pure Nothing Nothing -> pure Nothing
unsetConnectionToSubscribe db unsetConnectionToSubscribe db
let connIds = map (\(AgentConnId connId) -> connId) aConnIds 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 Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Protocol (SubscriptionMode (..)) import Simplex.Messaging.Protocol (SubscriptionMode (..))
import Simplex.Messaging.Version (VersionRange)
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
getLiveSndFileTransfers db User {userId} = do getLiveSndFileTransfers db User {userId} = do
@ -676,8 +677,8 @@ getRcvFileTransfer_ db userId fileId = do
_ -> pure Nothing _ -> pure Nothing
cancelled = fromMaybe False cancelled_ cancelled = fromMaybe False cancelled_
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem acceptRcvFileTransfer :: DB.Connection -> VersionRange -> 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 vr user@User {userId} fileId (cmdId, acId) connStatus filePath subMode = ExceptT $ do
currentTs <- getCurrentTime currentTs <- getCurrentTime
acceptRcvFT_ db user fileId filePath Nothing currentTs acceptRcvFT_ db user fileId filePath Nothing currentTs
DB.execute 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) (acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs, subMode == SMOnlyCreate)
connId <- insertedRowId db connId <- insertedRowId db
setCommandConnId db user cmdId connId 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.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact
getContactByFileId db user@User {userId} fileId = do getContactByFileId db user@User {userId} fileId = do
@ -697,19 +698,19 @@ getContactByFileId db user@User {userId} fileId = do
ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $ ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $
DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, 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.Connection -> VersionRange -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db user fileId filePath = do acceptRcvInlineFT db vr user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime 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.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO ()
startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline = startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline =
acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime
xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem xftpAcceptRcvFT :: DB.Connection -> VersionRange -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
xftpAcceptRcvFT db user fileId filePath = do xftpAcceptRcvFT db vr user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime 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.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO ()
acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do 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 FileTransferMeta {filePath, xftpSndFile} <- getFileTransferMeta_ db userId fileId
pure $ CryptoFile filePath $ xftpSndFile >>= \XFTPSndFile {cryptoArgs} -> cryptoArgs pure $ CryptoFile filePath $ xftpSndFile >>= \XFTPSndFile {cryptoArgs} -> cryptoArgs
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> VersionRange -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus db user fileId fileStatus = do updateDirectCIFileStatus db vr user fileId fileStatus = do
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db vr user fileId
case (cType, testEquality d $ msgDirection @d) of case (cType, testEquality d $ msgDirection @d) of
(SCTDirect, Just Refl) -> do (SCTDirect, Just Refl) -> do
liftIO $ updateCIFileStatus db user fileId fileStatus 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 (NamedParam (..), Only (..), Query (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql) import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Messages 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.Direct
import Simplex.Chat.Store.Shared import Simplex.Chat.Store.Shared
import Simplex.Chat.Types 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)) 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 :: VersionRange -> Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) = 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 supportedChatVRange} let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = JVersionRange vr}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
fullGroupPreferences = mergeGroupPreferences groupPreferences fullGroupPreferences = mergeGroupPreferences groupPreferences
groupProfile = GroupProfile {displayName, fullName, description, image, 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 = 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) 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.Connection -> User -> Int64 -> VersionRange -> ExceptT StoreError IO (GroupInfo, GroupMember)
getGroupAndMember db User {userId, userContactId} groupMemberId = getGroupAndMember db User {userId, userContactId} groupMemberId vr =
ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $ ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $
DB.query DB.query
db db
@ -288,13 +288,13 @@ getGroupAndMember db User {userId, userContactId} groupMemberId =
where where
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
toGroupAndMember (groupInfoRow :. memberRow :. connRow) = toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
-- | creates completely new group with a single member - the current user -- | 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.Connection -> VersionRange -> TVar ChaChaDRG -> User -> GroupProfile -> Maybe Profile -> ExceptT StoreError IO GroupInfo
createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
fullGroupPreferences = mergeGroupPreferences groupPreferences fullGroupPreferences = mergeGroupPreferences groupPreferences
currentTs <- getCurrentTime currentTs <- getCurrentTime
@ -312,18 +312,18 @@ createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = Except
(ldn, userId, profileId, True, currentTs, currentTs, currentTs) (ldn, userId, profileId, True, currentTs, currentTs, currentTs)
insertedRowId db insertedRowId db
memberId <- liftIO $ encodedRandomBytes gVar 12 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} 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} 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 -- | 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 :: DB.Connection -> VersionRange -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName 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 vr user@User {userId} contact@Contact {contactId, activeConn = Just hostConn@Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
liftIO getInvitationGroupId_ >>= \case liftIO getInvitationGroupId_ >>= \case
Nothing -> createGroupInvitation_ Nothing -> createGroupInvitation_
Just gId -> do 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 hostId <- getHostMemberId_ db user gId
let GroupMember {groupMemberId, memberId, memberRole} = membership let GroupMember {groupMemberId, memberId, memberRole} = membership
MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember
@ -359,7 +359,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo
insertedRowId db insertedRowId db
let JVersionRange hostVRange = peerChatVRange hostConn let JVersionRange hostVRange = peerChatVRange hostConn
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs hostVRange 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} 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) 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 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 createGroupInvitedViaLink
db db
vr
user@User {userId, userContactId} user@User {userId, userContactId}
Connection {connId, customUserProfileId} Connection {connId, customUserProfileId}
GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile} = do GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile} = do
@ -441,9 +442,9 @@ createGroupInvitedViaLink
hostMemberId <- insertHost_ currentTs groupId 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) 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 -- 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 liftIO $ setViaGroupLinkHash db groupId connId
(,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId (,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db user hostMemberId
where where
insertGroup_ currentTs = ExceptT $ do insertGroup_ currentTs = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile 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 -- TODO return the last connection that is ready, not any last connection
-- requires updating connection status -- requires updating connection status
getGroup :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO Group getGroup :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO Group
getGroup db user groupId = do getGroup db vr user groupId = do
gInfo <- getGroupInfo db user groupId gInfo <- getGroupInfo db vr user groupId
members <- liftIO $ getGroupMembers db user gInfo members <- liftIO $ getGroupMembers db user gInfo
pure $ Group gInfo members pure $ Group gInfo members
@ -551,14 +552,14 @@ deleteGroupProfile_ db userId groupId =
|] |]
(userId, groupId) (userId, groupId)
getUserGroups :: DB.Connection -> User -> IO [Group] getUserGroups :: DB.Connection -> VersionRange -> User -> IO [Group]
getUserGroups db user@User {userId} = do getUserGroups db vr user@User {userId} = do
groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId) 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.Connection -> VersionRange -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
getUserGroupDetails db User {userId, userContactId} _contactId_ search_ = getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ =
map (toGroupInfo userContactId) map (toGroupInfo vr userContactId)
<$> DB.query <$> DB.query
db db
[sql| [sql|
@ -576,9 +577,9 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
where where
search = fromMaybe "" search_ search = fromMaybe "" search_
getUserGroupsWithSummary :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)] getUserGroupsWithSummary :: DB.Connection -> VersionRange -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)]
getUserGroupsWithSummary db user _contactId_ search_ = getUserGroupsWithSummary db vr user _contactId_ search_ =
getUserGroupDetails db user _contactId_ search_ getUserGroupDetails db vr user _contactId_ search_
>>= mapM (\g@GroupInfo {groupId} -> (g,) <$> getGroupSummary db user groupId) >>= mapM (\g@GroupInfo {groupId} -> (g,) <$> getGroupSummary db user groupId)
-- the statuses on non-current members should match memberCurrent' function -- 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} = 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) 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.Connection -> VersionRange -> User -> GroupName -> ExceptT StoreError IO GroupInfo
getGroupInfoByName db user gName = do getGroupInfoByName db vr user gName = do
gId <- getGroupIdByName db user gName gId <- getGroupIdByName db user gName
getGroupInfo db user gId getGroupInfo db vr user gId
groupMemberQuery :: Query groupMemberQuery :: Query
groupMemberQuery = groupMemberQuery =
@ -708,11 +709,11 @@ getGroupCurrentMembersCount db User {userId} GroupInfo {groupId} = do
(groupId, userId) (groupId, userId)
pure $ length $ filter memberCurrent' statuses pure $ length $ filter memberCurrent' statuses
getGroupInvitation :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation getGroupInvitation :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
getGroupInvitation db user groupId = getGroupInvitation db vr user groupId =
getConnRec_ user >>= \case getConnRec_ user >>= \case
Just connRequest -> do Just connRequest -> do
groupInfo@GroupInfo {membership} <- getGroupInfo db user groupId groupInfo@GroupInfo {membership} <- getGroupInfo db vr user groupId
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
hostId <- getHostMemberId_ db user groupId hostId <- getHostMemberId_ db user groupId
fromMember <- getGroupMember db user groupId hostId fromMember <- getGroupMember db user groupId hostId
@ -1004,8 +1005,8 @@ updateGroupMemberRole :: DB.Connection -> User -> GroupMember -> GroupMemberRole
updateGroupMemberRole db User {userId} GroupMember {groupMemberId} memRole = 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) 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.Connection -> Version -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro]
createIntroductions db members toMember = do createIntroductions db chatV members toMember = do
let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members
if null reMembers if null reMembers
then pure [] 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) (re_group_member_id, to_group_member_id, intro_status, intro_chat_protocol_version, created_at, updated_at)
VALUES (?,?,?,?,?,?) VALUES (?,?,?,?,?,?)
|] |]
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, currentChatVersion, ts, ts) (groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, chatV, ts, ts)
introId <- insertedRowId db introId <- insertedRowId db
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing} 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.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 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.Connection -> VersionRange -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
getViaGroupMember db User {userId, userContactId} Contact {contactId} = getViaGroupMember db vr User {userId, userContactId} Contact {contactId} =
maybeFirstRow toGroupAndMember $ maybeFirstRow toGroupAndMember $
DB.query DB.query
db db
@ -1238,7 +1239,7 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
where where
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
toGroupAndMember (groupInfoRow :. memberRow :. connRow) = toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
@ -1293,9 +1294,9 @@ updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, grou
(ldn, currentTs, userId, groupId) (ldn, currentTs, userId, groupId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) 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.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db User {userId, userContactId} groupId = getGroupInfo db vr User {userId, userContactId} groupId =
ExceptT . firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $ ExceptT . firstRow (toGroupInfo vr userContactId) (SEGroupNotFound groupId) $
DB.query DB.query
db db
[sql| [sql|
@ -1314,8 +1315,8 @@ getGroupInfo db User {userId, userContactId} groupId =
|] |]
(groupId, userId, userContactId) (groupId, userId, userContactId)
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo) getGroupInfoByUserContactLinkConnReq :: DB.Connection -> VersionRange -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
groupId_ <- groupId_ <-
maybeFirstRow fromOnly $ maybeFirstRow fromOnly $
DB.query DB.query
@ -1326,10 +1327,10 @@ getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSch
WHERE user_id = ? AND conn_req_contact IN (?,?) WHERE user_id = ? AND conn_req_contact IN (?,?)
|] |]
(userId, cReqSchema1, cReqSchema2) (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.Connection -> VersionRange -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
groupId_ <- groupId_ <-
maybeFirstRow fromOnly $ maybeFirstRow fromOnly $
DB.query DB.query
@ -1343,7 +1344,7 @@ getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1
LIMIT 1 LIMIT 1
|] |]
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) (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.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
getGroupIdByName db User {userId} gName = getGroupIdByName db User {userId} gName =
@ -1355,8 +1356,8 @@ getGroupMemberIdByName db User {userId} groupId groupMemberName =
ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound 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) 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.Connection -> VersionRange -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
getActiveMembersByName db user@User {userId} groupMemberName = do getActiveMembersByName db vr user@User {userId} groupMemberName = do
groupMemberIds :: [(GroupId, GroupMemberId)] <- groupMemberIds :: [(GroupId, GroupMemberId)] <-
liftIO $ liftIO $
DB.query DB.query
@ -1369,7 +1370,7 @@ getActiveMembersByName db user@User {userId} groupMemberName = do
|] |]
(userId, groupMemberName, GSMemConnected, GSMemComplete, GCUserMember) (userId, groupMemberName, GSMemConnected, GSMemComplete, GCUserMember)
possibleMembers <- forM groupMemberIds $ \(groupId, groupMemberId) -> do possibleMembers <- forM groupMemberIds $ \(groupId, groupMemberId) -> do
groupInfo <- getGroupInfo db user groupId groupInfo <- getGroupInfo db vr user groupId
groupMember <- getGroupMember db user groupId groupMemberId groupMember <- getGroupMember db user groupId groupMemberId
pure (groupInfo, groupMember) pure (groupInfo, groupMember)
pure $ sortOn (Down . ts . fst) possibleMembers pure $ sortOn (Down . ts . fst) possibleMembers
@ -1826,15 +1827,15 @@ createMemberContact
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn 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} 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.Connection -> VersionRange -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
getMemberContact db user contactId = do getMemberContact db vr user contactId = do
ct <- getContact db user contactId ct <- getContact db user contactId
let Contact {contactGroupMemberId, activeConn} = ct let Contact {contactGroupMemberId, activeConn} = ct
case (activeConn, contactGroupMemberId) of case (activeConn, contactGroupMemberId) of
(Just Connection {connId}, Just groupMemberId) -> do (Just Connection {connId}, Just groupMemberId) -> do
cReq <- getConnReqInv db connId cReq <- getConnReqInv db connId
m@GroupMember {groupId} <- getGroupMemberById db user groupMemberId m@GroupMember {groupId} <- getGroupMemberById db user groupMemberId
g <- getGroupInfo db user groupId g <- getGroupInfo db vr user groupId
pure (g, m, ct, cReq) pure (g, m, ct, cReq)
_ -> _ ->
throwError $ SEMemberContactGroupMemberNotFound contactId 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 qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Util (eitherToMaybe) import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version (VersionRange)
import UnliftIO.STM import UnliftIO.STM
deleteContactCIs :: DB.Connection -> User -> Contact -> IO () deleteContactCIs :: DB.Connection -> User -> Contact -> IO ()
@ -461,8 +462,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
getChatPreviews :: DB.Connection -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat] getChatPreviews :: DB.Connection -> VersionRange -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
getChatPreviews db user withPCC pagination query = do getChatPreviews db vr user withPCC pagination query = do
directChats <- findDirectChatPreviews_ db user pagination query directChats <- findDirectChatPreviews_ db user pagination query
groupChats <- findGroupChatPreviews_ db user pagination query groupChats <- findGroupChatPreviews_ db user pagination query
cReqChats <- getContactRequestChatPreviews_ 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 :: AChatPreviewData -> ExceptT StoreError IO AChat
getChatPreview (ACPD cType cpd) = case cType of getChatPreview (ACPD cType cpd) = case cType of
SCTDirect -> getDirectChatPreview_ db user cpd SCTDirect -> getDirectChatPreview_ db user cpd
SCTGroup -> getGroupChatPreview_ db user cpd SCTGroup -> getGroupChatPreview_ db vr user cpd
SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat
SCTContactConnection -> let (ContactConnectionPD _ 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) ([":user_id" := userId, ":rcv_new" := CISRcvNew, ":search" := search] <> pagParams)
getGroupChatPreview_ :: DB.Connection -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat getGroupChatPreview_ :: DB.Connection -> VersionRange -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
getGroupChatPreview_ db user (GroupChatPD _ groupId lastItemId_ stats) = do getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do
groupInfo <- getGroupInfo db user groupId groupInfo <- getGroupInfo db vr user groupId
lastItem <- case lastItemId_ of lastItem <- case lastItemId_ of
Just lastItemId -> (: []) <$> getGroupChatItem db user groupId lastItemId Just lastItemId -> (: []) <$> getGroupChatItem db user groupId lastItemId
Nothing -> pure [] Nothing -> pure []
@ -874,10 +875,10 @@ getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId co
|] |]
(userId, contactId, search, beforeChatItemId, count) (userId, contactId, search, beforeChatItemId, count)
getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup) getGroupChat :: DB.Connection -> VersionRange -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChat db user groupId pagination search_ = do getGroupChat db vr user groupId pagination search_ = do
let search = fromMaybe "" search_ let search = fromMaybe "" search_
g <- getGroupInfo db user groupId g <- getGroupInfo db vr user groupId
case pagination of case pagination of
CPLast count -> getGroupChatLast_ db user g count search CPLast count -> getGroupChatLast_ db user g count search
CPAfter afterId count -> getGroupChatAfter_ db user g afterId 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 :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem] getAllChatItems :: DB.Connection -> VersionRange -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
getAllChatItems db user@User {userId} pagination search_ = do getAllChatItems db vr user@User {userId} pagination search_ = do
itemRefs <- itemRefs <-
rights . map toChatItemRef <$> case pagination of rights . map toChatItemRef <$> case pagination of
CPLast count -> liftIO $ getAllChatItemsLast_ count CPLast count -> liftIO $ getAllChatItemsLast_ count
CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId
CPBefore beforeId count -> liftIO . getAllChatItemsBefore_ beforeId count . aChatItemTs =<< getAChatItem_ beforeId 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 where
search = fromMaybe "" search_ search = fromMaybe "" search_
getAChatItem_ itemId = do getAChatItem_ itemId = do
chatRef <- getChatRefViaItemId db user itemId chatRef <- getChatRefViaItemId db user itemId
getAChatItem db user chatRef itemId getAChatItem db vr user chatRef itemId
getAllChatItemsLast_ count = getAllChatItemsLast_ count =
reverse reverse
<$> DB.query <$> DB.query
@ -1713,8 +1714,8 @@ getGroupChatItemIdByText' db User {userId} groupId msg =
|] |]
(userId, groupId, msg <> "%") (userId, groupId, msg <> "%")
getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem getChatItemByFileId :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO AChatItem
getChatItemByFileId db user@User {userId} fileId = do getChatItemByFileId db vr user@User {userId} fileId = do
(chatRef, itemId) <- (chatRef, itemId) <-
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $ ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $
DB.query DB.query
@ -1727,10 +1728,10 @@ getChatItemByFileId db user@User {userId} fileId = do
LIMIT 1 LIMIT 1
|] |]
(userId, fileId) (userId, fileId)
getAChatItem db user chatRef itemId getAChatItem db vr user chatRef itemId
getChatItemByGroupId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem getChatItemByGroupId :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO AChatItem
getChatItemByGroupId db user@User {userId} groupId = do getChatItemByGroupId db vr user@User {userId} groupId = do
(chatRef, itemId) <- (chatRef, itemId) <-
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $ ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $
DB.query DB.query
@ -1743,7 +1744,7 @@ getChatItemByGroupId db user@User {userId} groupId = do
LIMIT 1 LIMIT 1
|] |]
(userId, groupId) (userId, groupId)
getAChatItem db user chatRef itemId getAChatItem db vr user chatRef itemId
getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef
getChatRefViaItemId db User {userId} itemId = do getChatRefViaItemId db User {userId} itemId = do
@ -1755,14 +1756,14 @@ getChatRefViaItemId db User {userId} itemId = do
(Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId (Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId
(_, _) -> Left $ SEBadChatItem itemId (_, _) -> Left $ SEBadChatItem itemId
getAChatItem :: DB.Connection -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem getAChatItem :: DB.Connection -> VersionRange -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
getAChatItem db user chatRef itemId = case chatRef of getAChatItem db vr user chatRef itemId = case chatRef of
ChatRef CTDirect contactId -> do ChatRef CTDirect contactId -> do
ct <- getContact db user contactId ct <- getContact db user contactId
(CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId (CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId
pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci
ChatRef CTGroup groupId -> do ChatRef CTGroup groupId -> do
gInfo <- getGroupInfo db user groupId gInfo <- getGroupInfo db vr user groupId
(CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId (CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci
_ -> throwError $ SEChatItemNotFound itemId _ -> throwError $ SEChatItemNotFound itemId

35
tests/ChatClient.hs
View File

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

297
tests/ChatTests/Groups.hs
View File

@ -24,8 +24,9 @@ import Test.Hspec
chatGroupTests :: SpecWith FilePath chatGroupTests :: SpecWith FilePath
chatGroupTests = do chatGroupTests = do
describe "chat groups" $ do describe "chat groups" $ do
it "add contacts, create group and send/receive messages" testGroup describe "add contacts, create group and send/receive messages" testGroupMatrix
it "add contacts, create group and send/receive messages, check messages" testGroupCheckMessages 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 group with incognito membership" testNewGroupIncognito
it "create and join group with 4 members" testGroup2 it "create and join group with 4 members" testGroup2
it "create and delete group" testGroupDelete it "create and delete group" testGroupDelete
@ -69,6 +70,8 @@ chatGroupTests = do
it "re-join existing group after leaving" testPlanGroupLinkLeaveRejoin it "re-join existing group after leaving" testPlanGroupLinkLeaveRejoin
describe "group links without contact" $ do describe "group links without contact" $ do
it "join via group link without creating contact" testGroupLinkNoContact 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 "group link member role" testGroupLinkNoContactMemberRole
it "host incognito" testGroupLinkNoContactHostIncognito it "host incognito" testGroupLinkNoContactHostIncognito
it "invitee incognito" testGroupLinkNoContactInviteeIncognito it "invitee incognito" testGroupLinkNoContactInviteeIncognito
@ -146,15 +149,19 @@ chatGroupTests = do
testGroup :: HasCallStack => FilePath -> IO () testGroup :: HasCallStack => FilePath -> IO ()
testGroup = testGroup =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $ 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 :: HasCallStack => FilePath -> IO ()
testGroupCheckMessages = testGroupCheckMessages =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $ 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 () testGroupMatrix :: SpecWith FilePath
testGroupShared alice bob cath checkMessages = do 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 bob
connectUsers alice cath connectUsers alice cath
alice ##> "/g team" alice ##> "/g team"
@ -206,7 +213,8 @@ testGroupShared alice bob cath checkMessages = do
(alice <# "#team cath> hey team") (alice <# "#team cath> hey team")
(bob <# "#team cath> hey team") (bob <# "#team cath> hey team")
msgItem2 <- lastItemId alice msgItem2 <- lastItemId alice
bob <##> cath when directConnections $
bob <##> cath
when checkMessages $ getReadChats msgItem1 msgItem2 when checkMessages $ getReadChats msgItem1 msgItem2
-- list groups -- list groups
alice ##> "/gs" alice ##> "/gs"
@ -263,17 +271,34 @@ testGroupShared alice bob cath checkMessages = do
(cath </) (cath </)
cath ##> "#team hello" cath ##> "#team hello"
cath <## "you are no longer a member of the group" cath <## "you are no longer a member of the group"
bob <##> cath when directConnections $
bob <##> cath
-- delete contact -- delete contact
alice ##> "/d bob" alice ##> "/d bob"
alice <## "bob: contact is deleted" alice <## "bob: contact is deleted"
bob <## "alice (Alice) deleted contact with you" bob <## "alice (Alice) deleted contact with you"
alice `send` "@bob hey" alice `send` "@bob hey"
alice if directConnections
<### [ "@bob hey", then
"member #team bob does not have direct connection, creating", alice
"peer chat protocol version range incompatible" <### [ "@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 when checkMessages $ threadDelay 1000000
alice #> "#team checking connection" alice #> "#team checking connection"
bob <# "#team alice> checking connection" bob <# "#team alice> checking connection"
@ -2633,11 +2658,16 @@ testPlanGroupLinkLeaveRejoin =
testGroupLinkNoContact :: HasCallStack => FilePath -> IO () testGroupLinkNoContact :: HasCallStack => FilePath -> IO ()
testGroupLinkNoContact = testGroupLinkNoContact =
testChat2 aliceProfile bobProfile $ testChat3 aliceProfile bobProfile cathProfile $
\alice bob -> do \alice bob cath -> do
alice ##> "/g team" alice ##> "/g team"
alice <## "group #team is created" alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team" 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" alice ##> "/create link #team"
gLink <- getGroupLink alice "team" GRMember True gLink <- getGroupLink alice "team" GRMember True
bob ##> ("/c " <> gLink) bob ##> ("/c " <> gLink)
@ -2663,10 +2693,196 @@ testGroupLinkNoContact =
bob #> "#team hi there" bob #> "#team hi there"
alice <# "#team bob> 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 :: HasCallStack => FilePath -> IO ()
testGroupLinkNoContactMemberRole = testGroupLinkNoContactMemberRole =
testChat2 aliceProfile bobProfile $ testChat3 aliceProfile bobProfile cathProfile $
\alice bob -> do \alice bob cath -> do
alice ##> "/g team" alice ##> "/g team"
alice <## "group #team is created" alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team" alice <## "to add members use /a team <name> or /create link #team"
@ -2706,6 +2922,43 @@ testGroupLinkNoContactMemberRole =
bob #> "#team hey now" bob #> "#team hey now"
alice <# "#team bob> 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 :: HasCallStack => FilePath -> IO ()
testGroupLinkNoContactHostIncognito = testGroupLinkNoContactHostIncognito =
testChat2 aliceProfile bobProfile $ testChat2 aliceProfile bobProfile $
@ -4292,6 +4545,16 @@ testGroupHistoryPreferenceOff =
r' <- chat <$> getTermLine dan r' <- chat <$> getTermLine dan
r' `shouldNotContain` [(0, "hello")] r' `shouldNotContain` [(0, "hello")]
r' `shouldNotContain` [(0, "hey!")] 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 where
aliceAddedDan :: HasCallStack => TestCC -> IO () aliceAddedDan :: HasCallStack => TestCC -> IO ()
aliceAddedDan cc = do 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 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath
versionTestMatrix2 runTest = do 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" $ testChatCfg2 testCfgV1 aliceProfile bobProfile runTest
it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest
it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest
-- versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
-- versionTestMatrix3 runTest = do versionTestMatrix3 runTest = do
-- it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest it "current" $ testChat3 aliceProfile bobProfile cathProfile runTest
it "prev" $ testChatCfg3 testCfgVPrev aliceProfile bobProfile cathProfile runTest
-- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest it "prev to curr" $ runTestCfg3 testCfg testCfgVPrev testCfgVPrev runTest
-- it "v1 to v2" $ runTestCfg3 testCfg testCfgV1 testCfgV1 runTest it "curr+prev to curr" $ runTestCfg3 testCfg testCfg testCfgVPrev runTest
-- it "v2+v1 to v2" $ runTestCfg3 testCfg testCfg testCfgV1 runTest it "curr to prev" $ runTestCfg3 testCfgVPrev testCfg testCfg runTest
-- it "v2 to v1" $ runTestCfg3 testCfgV1 testCfg testCfg runTest it "curr+prev to prev" $ runTestCfg3 testCfgVPrev testCfg testCfgVPrev runTest
-- it "v2+v1 to v1" $ runTestCfg3 testCfgV1 testCfg testCfgV1 runTest
inlineCfg :: Integer -> ChatConfig inlineCfg :: Integer -> ChatConfig
inlineCfg n = testCfg {inlineFiles = defaultInlineFilesConfig {sendChunks = 0, offerChunks = n, receiveChunks = n}} 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", "DIRECTORY.md",
"ANDROID.md", "ANDROID.md",
"CLI.md", "CLI.md",
"SQL.md",
"CONTRIBUTING.md", "CONTRIBUTING.md",
"SERVER.md", "SERVER.md",
"TRANSLATIONS.md", "TRANSLATIONS.md",