From e7089d4c2fde09dd00e07d5c2c9f5271ac9ee67d Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 17 Jun 2023 09:58:35 +0100 Subject: [PATCH 1/9] mobile: allow hiding profile when SimpleX lock is disabled (#2586) --- .../app/views/usersettings/UserProfilesView.kt | 11 ++++------- .../Views/UserSettings/UserProfilesView.swift | 5 ++--- .../cs.xcloc/Localized Contents/cs.xliff | 12 +++++++----- .../de.xcloc/Localized Contents/de.xliff | 12 +++++++----- .../en.xcloc/Localized Contents/en.xliff | 13 ++++++++----- .../es.xcloc/Localized Contents/es.xliff | 12 +++++++----- .../fr.xcloc/Localized Contents/fr.xliff | 12 +++++++----- .../it.xcloc/Localized Contents/it.xliff | 12 +++++++----- .../ja.xcloc/Localized Contents/ja.xliff | 12 +++++++----- .../nl.xcloc/Localized Contents/nl.xliff | 12 +++++++----- .../pl.xcloc/Localized Contents/pl.xliff | 12 +++++++----- .../ru.xcloc/Localized Contents/ru.xliff | 12 +++++++----- .../zh-Hans.xcloc/Localized Contents/zh-Hans.xliff | 12 +++++++----- apps/ios/cs.lproj/Localizable.strings | 2 +- apps/ios/de.lproj/Localizable.strings | 2 +- apps/ios/es.lproj/Localizable.strings | 2 +- apps/ios/fr.lproj/Localizable.strings | 2 +- apps/ios/it.lproj/Localizable.strings | 2 +- apps/ios/ja.lproj/Localizable.strings | 2 +- apps/ios/nl.lproj/Localizable.strings | 2 +- apps/ios/pl.lproj/Localizable.strings | 2 +- apps/ios/ru.lproj/Localizable.strings | 2 +- apps/ios/zh-Hans.lproj/Localizable.strings | 2 +- 23 files changed, 94 insertions(+), 75 deletions(-) diff --git a/apps/android/app/src/main/java/chat/simplex/app/views/usersettings/UserProfilesView.kt b/apps/android/app/src/main/java/chat/simplex/app/views/usersettings/UserProfilesView.kt index 98c1519320..997d0b9f02 100644 --- a/apps/android/app/src/main/java/chat/simplex/app/views/usersettings/UserProfilesView.kt +++ b/apps/android/app/src/main/java/chat/simplex/app/views/usersettings/UserProfilesView.kt @@ -38,14 +38,13 @@ fun UserProfilesView(m: ChatModel, search: MutableState, profileHidden: val searchTextOrPassword = rememberSaveable { search } val users by remember { derivedStateOf { m.users.map { it.user } } } val filteredUsers by remember { derivedStateOf { filteredUsers(m, searchTextOrPassword.value) } } - UserProfilesView( + UserProfilesLayout( users = users, filteredUsers = filteredUsers, profileHidden = profileHidden, searchTextOrPassword = searchTextOrPassword, showHiddenProfilesNotice = m.controller.appPrefs.showHiddenProfilesNotice, visibleUsersCount = visibleUsersCount(m), - prefPerformLA = m.controller.appPrefs.performLA.get(), addUser = { ModalManager.shared.showModalCloseable { close -> CreateProfile(m, close) @@ -137,13 +136,12 @@ fun UserProfilesView(m: ChatModel, search: MutableState, profileHidden: } @Composable -private fun UserProfilesView( +private fun UserProfilesLayout( users: List, filteredUsers: List, searchTextOrPassword: MutableState, profileHidden: MutableState, visibleUsersCount: Int, - prefPerformLA: Boolean, showHiddenProfilesNotice: SharedPreference, addUser: () -> Unit, activateUser: (User) -> Unit, @@ -171,7 +169,7 @@ private fun UserProfilesView( SectionView { for (user in filteredUsers) { - UserView(user, users, visibleUsersCount, prefPerformLA, activateUser, removeUser, unhideUser, muteUser, unmuteUser, showHiddenProfile) + UserView(user, users, visibleUsersCount, activateUser, removeUser, unhideUser, muteUser, unmuteUser, showHiddenProfile) SectionDivider() } if (searchTextOrPassword.value.trim().isEmpty()) { @@ -205,7 +203,6 @@ private fun UserView( user: User, users: List, visibleUsersCount: Int, - prefPerformLA: Boolean, activateUser: (User) -> Unit, removeUser: (User) -> Unit, unhideUser: (User) -> Unit, @@ -225,7 +222,7 @@ private fun UserView( unhideUser(user) }) } else { - if (visibleUsersCount > 1 && prefPerformLA) { + if (visibleUsersCount > 1) { ItemAction(stringResource(R.string.user_hide), painterResource(R.drawable.ic_lock), onClick = { showMenu.value = false showHiddenProfile(user) diff --git a/apps/ios/Shared/Views/UserSettings/UserProfilesView.swift b/apps/ios/Shared/Views/UserSettings/UserProfilesView.swift index 0c1225da9b..f6c7bf37e8 100644 --- a/apps/ios/Shared/Views/UserSettings/UserProfilesView.swift +++ b/apps/ios/Shared/Views/UserSettings/UserProfilesView.swift @@ -9,7 +9,6 @@ import SimpleXChat struct UserProfilesView: View { @EnvironmentObject private var m: ChatModel @Environment(\.editMode) private var editMode - @AppStorage(DEFAULT_PERFORM_LA) private var prefPerformLA = false @AppStorage(DEFAULT_SHOW_HIDDEN_PROFILES_NOTICE) private var showHiddenProfilesNotice = true @AppStorage(DEFAULT_SHOW_MUTE_PROFILE_ALERT) private var showMuteProfileAlert = true @State private var showDeleteConfirmation = false @@ -157,7 +156,7 @@ struct UserProfilesView: View { case .hiddenProfilesNotice: return Alert( title: Text("Make profile private!"), - message: Text("You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled."), + message: Text("You can hide or mute a user profile - swipe it to the right."), primaryButton: .default(Text("Don't show again")) { showHiddenProfilesNotice = false }, @@ -338,7 +337,7 @@ struct UserProfilesView: View { } .tint(.green) } else { - if visibleUsersCount > 1 && prefPerformLA { + if visibleUsersCount > 1 { Button("Hide") { selectedUser = user } diff --git a/apps/ios/SimpleX Localizations/cs.xcloc/Localized Contents/cs.xliff b/apps/ios/SimpleX Localizations/cs.xcloc/Localized Contents/cs.xliff index 5c7e0f8a16..03eb28ac25 100644 --- a/apps/ios/SimpleX Localizations/cs.xcloc/Localized Contents/cs.xliff +++ b/apps/ios/SimpleX Localizations/cs.xcloc/Localized Contents/cs.xliff @@ -4002,6 +4002,10 @@ Přeskočené zprávy No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody Někdo @@ -4758,11 +4762,9 @@ Chcete-li se připojit, požádejte svůj kontakt o vytvoření dalšího odkazu Můžete vytvořit později No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - Profil uživatele můžete skrýt nebo ztlumit - přejeďte prstem doprava. -SimpleX zámek musí být povolen. + + You can hide or mute a user profile - swipe it to the right. + Profil uživatele můžete skrýt nebo ztlumit - přejeďte prstem doprava. No comment provided by engineer. diff --git a/apps/ios/SimpleX Localizations/de.xcloc/Localized Contents/de.xliff b/apps/ios/SimpleX Localizations/de.xcloc/Localized Contents/de.xliff index d8dbb08e8a..1d863cc197 100644 --- a/apps/ios/SimpleX Localizations/de.xcloc/Localized Contents/de.xliff +++ b/apps/ios/SimpleX Localizations/de.xcloc/Localized Contents/de.xliff @@ -4002,6 +4002,10 @@ Übersprungene Nachrichten No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody Jemand @@ -4758,11 +4762,9 @@ Bitten Sie Ihren Kontakt darum einen weiteren Verbindungs-Link zu erzeugen, um s Sie können dies später erstellen No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - Sie können ein Benutzerprofil verbergen oder stummschalten - wischen Sie es nach rechts. -Dafür muss die SimpleX Sperre aktiviert sein. + + You can hide or mute a user profile - swipe it to the right. + Sie können ein Benutzerprofil verbergen oder stummschalten - wischen Sie es nach rechts. No comment provided by engineer. diff --git a/apps/ios/SimpleX Localizations/en.xcloc/Localized Contents/en.xliff b/apps/ios/SimpleX Localizations/en.xcloc/Localized Contents/en.xliff index 023f507387..af65f8fb08 100644 --- a/apps/ios/SimpleX Localizations/en.xcloc/Localized Contents/en.xliff +++ b/apps/ios/SimpleX Localizations/en.xcloc/Localized Contents/en.xliff @@ -4002,6 +4002,11 @@ Skipped messages No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody Somebody @@ -4758,11 +4763,9 @@ To connect, please ask your contact to create another connection link and check You can create it later No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. + + You can hide or mute a user profile - swipe it to the right. + You can hide or mute a user profile - swipe it to the right. No comment provided by engineer. diff --git a/apps/ios/SimpleX Localizations/es.xcloc/Localized Contents/es.xliff b/apps/ios/SimpleX Localizations/es.xcloc/Localized Contents/es.xliff index 95cd6b972a..c0e6caf3ff 100644 --- a/apps/ios/SimpleX Localizations/es.xcloc/Localized Contents/es.xliff +++ b/apps/ios/SimpleX Localizations/es.xcloc/Localized Contents/es.xliff @@ -4002,6 +4002,10 @@ Mensajes omitidos No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody Alguien @@ -4759,11 +4763,9 @@ Para conectarte, pide a tu contacto que cree otro enlace de conexión y comprueb Puedes crearlo más tarde No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - Puedes ocultar o silenciar un perfil de usuario: deslízalo hacia la derecha. -Bloqueo SimpleX debe estar activado. + + You can hide or mute a user profile - swipe it to the right. + Puedes ocultar o silenciar un perfil de usuario: deslízalo hacia la derecha. No comment provided by engineer. diff --git a/apps/ios/SimpleX Localizations/fr.xcloc/Localized Contents/fr.xliff b/apps/ios/SimpleX Localizations/fr.xcloc/Localized Contents/fr.xliff index 332ab0422f..ae457b029d 100644 --- a/apps/ios/SimpleX Localizations/fr.xcloc/Localized Contents/fr.xliff +++ b/apps/ios/SimpleX Localizations/fr.xcloc/Localized Contents/fr.xliff @@ -4002,6 +4002,10 @@ Messages manqués No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody Quelqu'un @@ -4758,11 +4762,9 @@ Pour vous connecter, veuillez demander à votre contact de créer un autre lien Vous pouvez la créer plus tard No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - Vous pouvez masquer ou mettre en sourdine un profil d'utilisateur - faites-le glisser vers la droite. -SimpleX Lock doit être activé. + + You can hide or mute a user profile - swipe it to the right. + Vous pouvez masquer ou mettre en sourdine un profil d'utilisateur - faites-le glisser vers la droite. No comment provided by engineer. diff --git a/apps/ios/SimpleX Localizations/it.xcloc/Localized Contents/it.xliff b/apps/ios/SimpleX Localizations/it.xcloc/Localized Contents/it.xliff index ce622228ee..e72bdd3626 100644 --- a/apps/ios/SimpleX Localizations/it.xcloc/Localized Contents/it.xliff +++ b/apps/ios/SimpleX Localizations/it.xcloc/Localized Contents/it.xliff @@ -4002,6 +4002,10 @@ Messaggi saltati No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody Qualcuno @@ -4758,11 +4762,9 @@ Per connetterti, chiedi al tuo contatto di creare un altro link di connessione e Puoi crearlo più tardi No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - Puoi nascondere o silenziare un profilo utente - scorrilo verso destra. -SimpleX Lock deve essere attivato. + + You can hide or mute a user profile - swipe it to the right. + Puoi nascondere o silenziare un profilo utente - scorrilo verso destra. No comment provided by engineer. diff --git a/apps/ios/SimpleX Localizations/ja.xcloc/Localized Contents/ja.xliff b/apps/ios/SimpleX Localizations/ja.xcloc/Localized Contents/ja.xliff index 18d8359928..2e22257d01 100644 --- a/apps/ios/SimpleX Localizations/ja.xcloc/Localized Contents/ja.xliff +++ b/apps/ios/SimpleX Localizations/ja.xcloc/Localized Contents/ja.xliff @@ -4000,6 +4000,10 @@ 飛ばしたメッセージ No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody 誰か @@ -4756,11 +4760,9 @@ To connect, please ask your contact to create another connection link and check 後からでも作成できます No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - ユーザープロファイルを右にスワイプすると、非表示またはミュートにすることができます。 -SimpleXロックが有効になっている必要があります。 + + You can hide or mute a user profile - swipe it to the right. + ユーザープロファイルを右にスワイプすると、非表示またはミュートにすることができます。 No comment provided by engineer. diff --git a/apps/ios/SimpleX Localizations/nl.xcloc/Localized Contents/nl.xliff b/apps/ios/SimpleX Localizations/nl.xcloc/Localized Contents/nl.xliff index 349f0c1ca8..d6b98e7c79 100644 --- a/apps/ios/SimpleX Localizations/nl.xcloc/Localized Contents/nl.xliff +++ b/apps/ios/SimpleX Localizations/nl.xcloc/Localized Contents/nl.xliff @@ -4002,6 +4002,10 @@ Overgeslagen berichten No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody Iemand @@ -4758,11 +4762,9 @@ Om verbinding te maken, vraagt u uw contactpersoon om een andere verbinding link U kan het later maken No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - U kunt een gebruikers profiel verbergen of dempen - veeg het naar rechts. -SimpleX Lock moet ingeschakeld zijn. + + You can hide or mute a user profile - swipe it to the right. + U kunt een gebruikers profiel verbergen of dempen - veeg het naar rechts. No comment provided by engineer. diff --git a/apps/ios/SimpleX Localizations/pl.xcloc/Localized Contents/pl.xliff b/apps/ios/SimpleX Localizations/pl.xcloc/Localized Contents/pl.xliff index fabc58d013..8e41d51764 100644 --- a/apps/ios/SimpleX Localizations/pl.xcloc/Localized Contents/pl.xliff +++ b/apps/ios/SimpleX Localizations/pl.xcloc/Localized Contents/pl.xliff @@ -4002,6 +4002,10 @@ Pominięte wiadomości No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody Ktoś @@ -4758,11 +4762,9 @@ Aby się połączyć, poproś Twój kontakt o utworzenie kolejnego linku połąc Możesz go utworzyć później No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - Możesz ukryć lub wyciszyć profil użytkownika - przesuń palcem w prawo. -Funkcja blokady SimpleX musi być włączona. + + You can hide or mute a user profile - swipe it to the right. + Możesz ukryć lub wyciszyć profil użytkownika - przesuń palcem w prawo. No comment provided by engineer. diff --git a/apps/ios/SimpleX Localizations/ru.xcloc/Localized Contents/ru.xliff b/apps/ios/SimpleX Localizations/ru.xcloc/Localized Contents/ru.xliff index c8faa7b6c8..34749b9e5f 100644 --- a/apps/ios/SimpleX Localizations/ru.xcloc/Localized Contents/ru.xliff +++ b/apps/ios/SimpleX Localizations/ru.xcloc/Localized Contents/ru.xliff @@ -4002,6 +4002,10 @@ Пропущенные сообщения No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody Контакт @@ -4758,11 +4762,9 @@ To connect, please ask your contact to create another connection link and check Вы можете создать его позже No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - Вы можете скрыть профиль или выключить уведомления - потяните его вправо. -Блокировка SimpleX должна быть включена. + + You can hide or mute a user profile - swipe it to the right. + Вы можете скрыть профиль или выключить уведомления - потяните его вправо. No comment provided by engineer. diff --git a/apps/ios/SimpleX Localizations/zh-Hans.xcloc/Localized Contents/zh-Hans.xliff b/apps/ios/SimpleX Localizations/zh-Hans.xcloc/Localized Contents/zh-Hans.xliff index 0b032e2852..8c8c7aa2f0 100644 --- a/apps/ios/SimpleX Localizations/zh-Hans.xcloc/Localized Contents/zh-Hans.xliff +++ b/apps/ios/SimpleX Localizations/zh-Hans.xcloc/Localized Contents/zh-Hans.xliff @@ -4002,6 +4002,10 @@ 已跳过消息 No comment provided by engineer. + + Some non-fatal errors occurred during import - you may see Chat console for more details. + No comment provided by engineer. + Somebody 某人 @@ -4758,11 +4762,9 @@ To connect, please ask your contact to create another connection link and check 您可以以后创建它 No comment provided by engineer. - - You can hide or mute a user profile - swipe it to the right. -SimpleX Lock must be enabled. - 您可以隐藏或静音用户个人资料——只需向右滑动。 -必须启用 SimpleX Lock。 + + You can hide or mute a user profile - swipe it to the right. + 您可以隐藏或静音用户个人资料——只需向右滑动。 No comment provided by engineer. diff --git a/apps/ios/cs.lproj/Localizable.strings b/apps/ios/cs.lproj/Localizable.strings index 1a70b7cdc7..0939e9db5a 100644 --- a/apps/ios/cs.lproj/Localizable.strings +++ b/apps/ios/cs.lproj/Localizable.strings @@ -3203,7 +3203,7 @@ "You can create it later" = "Můžete vytvořit později"; /* No comment provided by engineer. */ -"You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled." = "Profil uživatele můžete skrýt nebo ztlumit - přejeďte prstem doprava.\nSimpleX zámek musí být povolen."; +"You can hide or mute a user profile - swipe it to the right." = "Profil uživatele můžete skrýt nebo ztlumit - přejeďte prstem doprava."; /* notification body */ "You can now send messages to %@" = "Nyní můžete posílat zprávy %@"; diff --git a/apps/ios/de.lproj/Localizable.strings b/apps/ios/de.lproj/Localizable.strings index 6f815f0626..cef8b62936 100644 --- a/apps/ios/de.lproj/Localizable.strings +++ b/apps/ios/de.lproj/Localizable.strings @@ -3203,7 +3203,7 @@ "You can create it later" = "Sie können dies später erstellen"; /* No comment provided by engineer. */ -"You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled." = "Sie können ein Benutzerprofil verbergen oder stummschalten - wischen Sie es nach rechts.\nDafür muss die SimpleX Sperre aktiviert sein."; +"You can hide or mute a user profile - swipe it to the right." = "Sie können ein Benutzerprofil verbergen oder stummschalten - wischen Sie es nach rechts."; /* notification body */ "You can now send messages to %@" = "Sie können nun Nachrichten an %@ versenden"; diff --git a/apps/ios/es.lproj/Localizable.strings b/apps/ios/es.lproj/Localizable.strings index ddcf9c7e8e..48288bc63c 100644 --- a/apps/ios/es.lproj/Localizable.strings +++ b/apps/ios/es.lproj/Localizable.strings @@ -3203,7 +3203,7 @@ "You can create it later" = "Puedes crearlo más tarde"; /* No comment provided by engineer. */ -"You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled." = "Puedes ocultar o silenciar un perfil de usuario: deslízalo hacia la derecha.\nBloqueo SimpleX debe estar activado."; +"You can hide or mute a user profile - swipe it to the right." = "Puedes ocultar o silenciar un perfil de usuario: deslízalo hacia la derecha."; /* notification body */ "You can now send messages to %@" = "Ya puedes enviar mensajes a %@"; diff --git a/apps/ios/fr.lproj/Localizable.strings b/apps/ios/fr.lproj/Localizable.strings index 49021c4be8..b9cc5f8e10 100644 --- a/apps/ios/fr.lproj/Localizable.strings +++ b/apps/ios/fr.lproj/Localizable.strings @@ -3203,7 +3203,7 @@ "You can create it later" = "Vous pouvez la créer plus tard"; /* No comment provided by engineer. */ -"You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled." = "Vous pouvez masquer ou mettre en sourdine un profil d'utilisateur - faites-le glisser vers la droite.\nSimpleX Lock doit être activé."; +"You can hide or mute a user profile - swipe it to the right." = "Vous pouvez masquer ou mettre en sourdine un profil d'utilisateur - faites-le glisser vers la droite."; /* notification body */ "You can now send messages to %@" = "Vous pouvez maintenant envoyer des messages à %@"; diff --git a/apps/ios/it.lproj/Localizable.strings b/apps/ios/it.lproj/Localizable.strings index a4975a404c..fcd888ebbf 100644 --- a/apps/ios/it.lproj/Localizable.strings +++ b/apps/ios/it.lproj/Localizable.strings @@ -3200,7 +3200,7 @@ "You can create it later" = "Puoi crearlo più tardi"; /* No comment provided by engineer. */ -"You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled." = "Puoi nascondere o silenziare un profilo utente - scorrilo verso destra.\nSimpleX Lock deve essere attivato."; +"You can hide or mute a user profile - swipe it to the right." = "Puoi nascondere o silenziare un profilo utente - scorrilo verso destra."; /* notification body */ "You can now send messages to %@" = "Ora puoi inviare messaggi a %@"; diff --git a/apps/ios/ja.lproj/Localizable.strings b/apps/ios/ja.lproj/Localizable.strings index 255d5f4654..e1768da252 100644 --- a/apps/ios/ja.lproj/Localizable.strings +++ b/apps/ios/ja.lproj/Localizable.strings @@ -3194,7 +3194,7 @@ "You can create it later" = "後からでも作成できます"; /* No comment provided by engineer. */ -"You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled." = "ユーザープロファイルを右にスワイプすると、非表示またはミュートにすることができます。\nSimpleXロックが有効になっている必要があります。"; +"You can hide or mute a user profile - swipe it to the right." = "ユーザープロファイルを右にスワイプすると、非表示またはミュートにすることができます。"; /* notification body */ "You can now send messages to %@" = "%@ にメッセージを送信できるようになりました"; diff --git a/apps/ios/nl.lproj/Localizable.strings b/apps/ios/nl.lproj/Localizable.strings index 381369d3d2..8c01806437 100644 --- a/apps/ios/nl.lproj/Localizable.strings +++ b/apps/ios/nl.lproj/Localizable.strings @@ -3203,7 +3203,7 @@ "You can create it later" = "U kan het later maken"; /* No comment provided by engineer. */ -"You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled." = "U kunt een gebruikers profiel verbergen of dempen - veeg het naar rechts.\nSimpleX Lock moet ingeschakeld zijn."; +"You can hide or mute a user profile - swipe it to the right." = "U kunt een gebruikers profiel verbergen of dempen - veeg het naar rechts."; /* notification body */ "You can now send messages to %@" = "Je kunt nu berichten sturen naar %@"; diff --git a/apps/ios/pl.lproj/Localizable.strings b/apps/ios/pl.lproj/Localizable.strings index d134e82113..27540849e3 100644 --- a/apps/ios/pl.lproj/Localizable.strings +++ b/apps/ios/pl.lproj/Localizable.strings @@ -3203,7 +3203,7 @@ "You can create it later" = "Możesz go utworzyć później"; /* No comment provided by engineer. */ -"You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled." = "Możesz ukryć lub wyciszyć profil użytkownika - przesuń palcem w prawo.\nFunkcja blokady SimpleX musi być włączona."; +"You can hide or mute a user profile - swipe it to the right." = "Możesz ukryć lub wyciszyć profil użytkownika - przesuń palcem w prawo."; /* notification body */ "You can now send messages to %@" = "Możesz teraz wysyłać wiadomości do %@"; diff --git a/apps/ios/ru.lproj/Localizable.strings b/apps/ios/ru.lproj/Localizable.strings index d77d910bbb..360d363f0e 100644 --- a/apps/ios/ru.lproj/Localizable.strings +++ b/apps/ios/ru.lproj/Localizable.strings @@ -3200,7 +3200,7 @@ "You can create it later" = "Вы можете создать его позже"; /* No comment provided by engineer. */ -"You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled." = "Вы можете скрыть профиль или выключить уведомления - потяните его вправо.\nБлокировка SimpleX должна быть включена."; +"You can hide or mute a user profile - swipe it to the right." = "Вы можете скрыть профиль или выключить уведомления - потяните его вправо."; /* notification body */ "You can now send messages to %@" = "Вы теперь можете отправлять сообщения %@"; diff --git a/apps/ios/zh-Hans.lproj/Localizable.strings b/apps/ios/zh-Hans.lproj/Localizable.strings index 996011688e..3276265636 100644 --- a/apps/ios/zh-Hans.lproj/Localizable.strings +++ b/apps/ios/zh-Hans.lproj/Localizable.strings @@ -3203,7 +3203,7 @@ "You can create it later" = "您可以以后创建它"; /* No comment provided by engineer. */ -"You can hide or mute a user profile - swipe it to the right.\nSimpleX Lock must be enabled." = "您可以隐藏或静音用户个人资料——只需向右滑动。\n必须启用 SimpleX Lock。"; +"You can hide or mute a user profile - swipe it to the right." = "您可以隐藏或静音用户个人资料——只需向右滑动。"; /* notification body */ "You can now send messages to %@" = "您现在可以给 %@ 发送消息"; From 53d77b25ed530ac581ee8fe6b9c5b420c2c383bb Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 17 Jun 2023 10:34:04 +0100 Subject: [PATCH 2/9] core: count successes and failures for batch operations, only log errors in info log-level (#2585) * core: count successes and failures for batch operations, only log errors in info log-level * correction Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --- apps/simplex-broadcast-bot/Options.hs | 1 + src/Simplex/Chat.hs | 37 +++++++++++++++------------ src/Simplex/Chat/Controller.hs | 6 +++-- src/Simplex/Chat/View.hs | 28 ++++++++++++++------ tests/ChatTests/Direct.hs | 10 ++++---- tests/ChatTests/Profiles.hs | 31 ++++++++++++---------- 6 files changed, 69 insertions(+), 44 deletions(-) diff --git a/apps/simplex-broadcast-bot/Options.hs b/apps/simplex-broadcast-bot/Options.hs index f15035fa16..994884760d 100644 --- a/apps/simplex-broadcast-bot/Options.hs +++ b/apps/simplex-broadcast-bot/Options.hs @@ -106,6 +106,7 @@ mkChatOpts BroadcastBotOpts {coreOptions} = optFilesFolder = Nothing, showReactions = False, allowInstantFiles = True, + autoAcceptFileSize = 0, muteNotifications = True, maintenance = False } diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 5fe76b9293..cd2d5ca702 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1231,7 +1231,7 @@ processChatCommand = \case let p' = (fromLocalProfile p :: Profile) {contactLink = Nothing} r <- updateProfile_ user p' $ withStore' $ \db -> setUserProfileContactLink db user Nothing let user' = case r of - CRUserProfileUpdated u' _ _ -> u' + CRUserProfileUpdated u' _ _ _ _ -> u' _ -> user pure $ CRUserContactLinkDeleted user' DeleteMyAddress -> withUser $ \User {userId} -> @@ -1264,17 +1264,19 @@ processChatCommand = \case SendLiveMessage chatName msg -> sendTextMessage chatName msg True SendMessageBroadcast msg -> withUser $ \user -> do contacts <- withStore' (`getUserContacts` user) + let cts = filter (\ct -> isReady ct && directOrUsed ct) contacts + ChatConfig {logLevel} <- asks config withChatLock "sendMessageBroadcast" . procCmd $ do - let mc = MCText msg - cts = filter (\ct -> isReady ct && directOrUsed ct) contacts - forM_ cts $ \ct -> - void - ( do - (sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing)) - saveSndChatItem user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) - ) - `catchError` (toView . CRChatError (Just user)) - CRBroadcastSent user mc (length cts) <$> liftIO getCurrentTime + (successes, failures) <- foldM (sendAndCount user logLevel) (0, 0) cts + timestamp <- liftIO getCurrentTime + pure CRBroadcastSent {user, msgContent = mc, successes, failures, timestamp} + where + mc = MCText msg + sendAndCount user ll (s, f) ct = + (sendToContact user ct $> (s + 1, f)) `catchError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> (s, f + 1) + sendToContact user ct = do + (sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing)) + void $ saveSndChatItem user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do contactId <- withStore $ \db -> getContactIdByName db user cName quotedItemId <- withStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg @@ -1596,6 +1598,7 @@ processChatCommand = \case UpdateProfileImage image -> withUser $ \user@User {profile} -> do let p = (fromLocalProfile profile :: Profile) {image} updateProfile user p + ShowProfileImage -> withUser $ \user@User {profile} -> pure $ CRUserProfileImage user $ fromLocalProfile profile SetUserFeature (ACF f) allowed -> withUser $ \user@User {profile} -> do let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user} updateProfile user p @@ -1756,10 +1759,11 @@ processChatCommand = \case user' <- updateUser asks currentUser >>= atomically . (`writeTVar` Just user') withChatLock "updateProfile" . procCmd $ do - forM_ contacts $ \ct -> do - processContact user' ct `catchError` (toView . CRChatError (Just user)) - pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' + ChatConfig {logLevel} <- asks config + (successes, failures) <- foldM (processAndCount user' logLevel) (0, 0) contacts + pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' successes failures where + processAndCount user' ll (s, f) ct = (processContact user' ct $> (s + 1, f)) `catchError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> (s, f + 1) processContact user' ct = do let mergedProfile = userProfileToSend user Nothing $ Just ct ct' = updateMergedPreferences user' ct @@ -4970,8 +4974,9 @@ chatCommandP = ("/reject " <|> "/rc ") *> char_ '@' *> (RejectContact <$> displayName), ("/markdown" <|> "/m") $> ChatHelp HSMarkdown, ("/welcome" <|> "/w") $> Welcome, - "/profile_image " *> (UpdateProfileImage . Just . ImageData <$> imageP), - "/profile_image" $> UpdateProfileImage Nothing, + "/set profile image " *> (UpdateProfileImage . Just . ImageData <$> imageP), + "/delete profile image" $> UpdateProfileImage Nothing, + "/show profile image" $> ShowProfileImage, ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> profileNames), ("/profile" <|> "/p") $> ShowProfile, "/set voice #" *> (SetGroupFeature (AGF SGFVoice) <$> displayName <*> (A.space *> strP)), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 3b4d499b30..a95e1835e3 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -374,6 +374,7 @@ data ChatCommand | ShowProfile -- UserId (not used in UI) | UpdateProfile ContactName Text -- UserId (not used in UI) | UpdateProfileImage (Maybe ImageData) -- UserId (not used in UI) + | ShowProfileImage | SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI) | SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed) | SetGroupFeature AGroupFeature GroupName GroupFeatureEnabled @@ -421,7 +422,7 @@ data ChatResponse | CRChatItemReaction {user :: User, added :: Bool, reaction :: ACIReaction} | CRChatItemDeleted {user :: User, deletedChatItem :: AChatItem, toChatItem :: Maybe AChatItem, byUser :: Bool, timed :: Bool} | CRChatItemDeletedNotFound {user :: User, contact :: Contact, sharedMsgId :: SharedMsgId} - | CRBroadcastSent User MsgContent Int UTCTime + | CRBroadcastSent {user :: User, msgContent :: MsgContent, successes :: Int, failures :: Int, timestamp :: UTCTime} | CRMsgIntegrityError {user :: User, msgError :: MsgErrorType} | CRCmdAccepted {corr :: CorrId} | CRCmdOk {user_ :: Maybe User} @@ -477,7 +478,8 @@ data ChatResponse | CRSndFileCompleteXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta} | CRSndFileCancelledXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta} | CRSndFileError {user :: User, chatItem :: AChatItem} - | CRUserProfileUpdated {user :: User, fromProfile :: Profile, toProfile :: Profile} + | CRUserProfileUpdated {user :: User, fromProfile :: Profile, toProfile :: Profile, successes :: Int, failures :: Int} + | CRUserProfileImage {user :: User, profile :: Profile} | CRContactAliasUpdated {user :: User, toContact :: Contact} | CRConnectionAliasUpdated {user :: User, toConnection :: PendingContactConnection} | CRContactPrefsUpdated {user :: User, fromContact :: Contact, toContact :: Contact} diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 0b78c46256..b4ecd228fa 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -47,7 +47,6 @@ import qualified Simplex.FileTransfer.Protocol as XFTP import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..)) import Simplex.Messaging.Agent.Protocol -import Simplex.Messaging.Agent.Store (canAbortRcvSwitch) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -98,7 +97,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, testView} liveItems ts CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction chat reaction $ viewItemReaction showReactions chat reaction added ts tz CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"] - CRBroadcastSent u mc n t -> ttyUser u $ viewSentBroadcast mc n ts tz t + CRBroadcastSent u mc s f t -> ttyUser u $ viewSentBroadcast mc s f ts tz t CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr CRCmdAccepted _ -> [] CRCmdOk u_ -> ttyUser' u_ ["ok"] @@ -152,7 +151,8 @@ responseToView user_ ChatConfig {logLevel, showReactions, testView} liveItems ts CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts CRRcvFileCancelled u _ ft -> ttyUser u $ receivingFile_ "cancelled" ft - CRUserProfileUpdated u p p' -> ttyUser u $ viewUserProfileUpdated p p' + CRUserProfileUpdated u p p' s f -> ttyUser u $ viewUserProfileUpdated p p' s f + CRUserProfileImage u p -> ttyUser u $ viewUserProfileImage p CRContactPrefsUpdated {user = u, fromContact, toContact} -> ttyUser u $ viewUserContactPrefsUpdated u fromContact toContact CRContactAliasUpdated u c -> ttyUser u $ viewContactAliasUpdated c CRConnectionAliasUpdated u c -> ttyUser u $ viewConnectionAliasUpdated c @@ -983,8 +983,8 @@ viewSwitchPhase = \case SPSecured -> "secured new address" SPCompleted -> "changed address" -viewUserProfileUpdated :: Profile -> Profile -> [StyledString] -viewUserProfileUpdated Profile {displayName = n, fullName, image, contactLink, preferences} Profile {displayName = n', fullName = fullName', image = image', contactLink = contactLink', preferences = prefs'} = +viewUserProfileUpdated :: Profile -> Profile -> Int -> Int -> [StyledString] +viewUserProfileUpdated Profile {displayName = n, fullName, image, contactLink, preferences} Profile {displayName = n', fullName = fullName', image = image', contactLink = contactLink', preferences = prefs'} s f = profileUpdated <> viewPrefsUpdated preferences prefs' where profileUpdated @@ -993,7 +993,15 @@ viewUserProfileUpdated Profile {displayName = n, fullName, image, contactLink, p | n == n' && fullName == fullName' = [if isNothing image' then "profile image removed" else "profile image updated"] | n == n' = ["user full name " <> (if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName') <> notified] | otherwise = ["user profile is changed to " <> ttyFullName n' fullName' <> notified] - notified = " (your contacts are notified)" + notified = " (your " <> sShow s <> " contacts are notified" <> failures <> ")" + failures + | f > 0 = ", " <> sShow f <> " failures" + | otherwise = "" + +viewUserProfileImage :: Profile -> [StyledString] +viewUserProfileImage Profile {image} = case image of + Just (ImageData img) -> ["Profile image:", plain img] + _ -> ["No profile image"] viewUserContactPrefsUpdated :: User -> Contact -> Contact -> [StyledString] viewUserContactPrefsUpdated user ct ct'@Contact {mergedPreferences = cups} @@ -1163,8 +1171,12 @@ viewSentMessage to quote mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive Just False -> ttyTo "[LIVE] " _ -> "" -viewSentBroadcast :: MsgContent -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString] -viewSentBroadcast mc n ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow n <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc) +viewSentBroadcast :: MsgContent -> Int -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString] +viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow s <> failures <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc) + where + failures + | f > 0 = ", " <> sShow f <> " failures" + | otherwise = "" viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString] viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts tz = case filePath of diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 9590b5e13e..63882ee20d 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -899,8 +899,8 @@ testMaintenanceModeWithFiles tmp = do testDatabaseEncryption :: HasCallStack => FilePath -> IO () testDatabaseEncryption tmp = do - withNewTestChat tmp "bob" bobProfile $ \b -> withTestOutput b $ \bob -> do - withNewTestChatOpts tmp testOpts {maintenance = True} "alice" aliceProfile $ \a -> withTestOutput a $ \alice -> do + withNewTestChat tmp "bob" bobProfile $ \bob -> do + withNewTestChatOpts tmp testOpts {maintenance = True} "alice" aliceProfile $ \alice -> do alice ##> "/_start" alice <## "chat started" connectUsers alice bob @@ -918,7 +918,7 @@ testDatabaseEncryption tmp = do alice <## "ok" alice ##> "/_start" alice <## "error: chat store changed, please restart chat" - withTestChatOpts tmp (getTestOpts True "mykey") "alice" $ \a -> withTestOutput a $ \alice -> do + withTestChatOpts tmp (getTestOpts True "mykey") "alice" $ \alice -> do alice ##> "/_start" alice <## "chat started" testChatWorking alice bob @@ -930,7 +930,7 @@ testDatabaseEncryption tmp = do alice <## "ok" alice ##> "/_db encryption {\"currentKey\":\"nextkey\",\"newKey\":\"anotherkey\"}" alice <## "ok" - withTestChatOpts tmp (getTestOpts True "anotherkey") "alice" $ \a -> withTestOutput a $ \alice -> do + withTestChatOpts tmp (getTestOpts True "anotherkey") "alice" $ \alice -> do alice ##> "/_start" alice <## "chat started" testChatWorking alice bob @@ -938,7 +938,7 @@ testDatabaseEncryption tmp = do alice <## "chat stopped" alice ##> "/db decrypt anotherkey" alice <## "ok" - withTestChat tmp "alice" $ \a -> withTestOutput a $ \alice -> do + withTestChat tmp "alice" $ \alice -> do testChatWorking alice bob testMuteContact :: HasCallStack => FilePath -> IO () diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index ccb638fb18..2b142cb5e3 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -61,19 +61,19 @@ testUpdateProfile = alice <## "(the updated profile will be sent to all your contacts)" alice ##> "/p alice" concurrentlyN_ - [ alice <## "user full name removed (your contacts are notified)", + [ alice <## "user full name removed (your 2 contacts are notified)", bob <## "contact alice removed full name", cath <## "contact alice removed full name" ] alice ##> "/p alice Alice Jones" concurrentlyN_ - [ alice <## "user full name changed to Alice Jones (your contacts are notified)", + [ alice <## "user full name changed to Alice Jones (your 2 contacts are notified)", bob <## "contact alice updated full name: Alice Jones", cath <## "contact alice updated full name: Alice Jones" ] cath ##> "/p cate" concurrentlyN_ - [ cath <## "user profile is changed to cate (your contacts are notified)", + [ cath <## "user profile is changed to cate (your 2 contacts are notified)", do alice <## "contact cath changed to cate" alice <## "use @cate to send messages", @@ -83,7 +83,7 @@ testUpdateProfile = ] cath ##> "/p cat Cate" concurrentlyN_ - [ cath <## "user profile is changed to cat (Cate) (your contacts are notified)", + [ cath <## "user profile is changed to cat (Cate) (your 2 contacts are notified)", do alice <## "contact cate changed to cat (Cate)" alice <## "use @cat to send messages", @@ -97,12 +97,17 @@ testUpdateProfileImage = testChat2 aliceProfile bobProfile $ \alice bob -> do connectUsers alice bob - alice ##> "/profile_image data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=" + alice ##> "/set profile image data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=" alice <## "profile image updated" - alice ##> "/profile_image" + alice ##> "/show profile image" + alice <## "Profile image:" + alice <## "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=" + alice ##> "/delete profile image" alice <## "profile image removed" + alice ##> "/show profile image" + alice <## "No profile image" alice ##> "/_profile 1 {\"displayName\": \"alice2\", \"fullName\": \"\"}" - alice <## "user profile is changed to alice2 (your contacts are notified)" + alice <## "user profile is changed to alice2 (your 1 contacts are notified)" bob <## "contact alice changed to alice2" bob <## "use @alice2 to send messages" (bob "/p bob" - bob <## "user full name removed (your contacts are notified)" + bob <## "user full name removed (your 0 contacts are notified)" bob ##> ("/c " <> cLink) bob <## "connection request sent!" alice <## "bob wants to connect to you!" @@ -335,13 +340,13 @@ testDeduplicateContactRequestsProfileChange = testChat3 aliceProfile bobProfile alice @@@ [("<@bob", "")] bob ##> "/p bob Bob Ross" - bob <## "user full name changed to Bob Ross (your contacts are notified)" + bob <## "user full name changed to Bob Ross (your 0 contacts are notified)" bob ##> ("/c " <> cLink) alice <#? bob alice @@@ [("<@bob", "")] bob ##> "/p robert Robert" - bob <## "user profile is changed to robert (Robert) (your contacts are notified)" + bob <## "user profile is changed to robert (Robert) (your 0 contacts are notified)" bob ##> ("/c " <> cLink) alice <#? bob alice @@@ [("<@robert", "")] @@ -513,7 +518,7 @@ testConnectIncognitoInvitationLink = testChat3 aliceProfile bobProfile cathProfi -- bob is not notified on profile change alice ##> "/p alice" concurrentlyN_ - [ alice <## "user full name removed (your contacts are notified)", + [ alice <## "user full name removed (your 1 contacts are notified)", cath <## "contact alice removed full name" ] alice ?#> ("@" <> bobIncognito <> " do you see that I've changed profile?") @@ -874,7 +879,7 @@ testCantSeeGlobalPrefsUpdateIncognito = testChat3 aliceProfile bobProfile cathPr ] alice <## "cath (Catherine): contact is connected" alice ##> "/_profile 1 {\"displayName\": \"alice\", \"fullName\": \"\", \"preferences\": {\"fullDelete\": {\"allow\": \"always\"}}}" - alice <## "user full name removed (your contacts are notified)" + alice <## "user full name removed (your 1 contacts are notified)" alice <## "updated preferences:" alice <## "Full deletion allowed: always" (alice ("/_get chat @2 count=100", chat, startFeatures <> [(0, "Voice messages: enabled for you"), (1, "voice message (00:10)"), (0, "Voice messages: off")]) (bob "/_profile 1 {\"displayName\": \"bob\", \"fullName\": \"\", \"preferences\": {\"voice\": {\"allow\": \"yes\"}}}" - bob <## "user full name removed (your contacts are notified)" + bob <## "user full name removed (your 1 contacts are notified)" bob <## "updated preferences:" bob <## "Voice messages allowed: yes" bob #$> ("/_get chat @2 count=100", chat, startFeatures <> [(0, "Voice messages: enabled for you"), (1, "voice message (00:10)"), (0, "Voice messages: off"), (1, "Voice messages: enabled")]) From 9fbcc2b5bbd5633b2234ce638f190819bf3ac92a Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 17 Jun 2023 11:03:22 +0100 Subject: [PATCH 3/9] core: rename module (#2587) --- apps/simplex-bot-advanced/Main.hs | 2 +- apps/simplex-broadcast-bot/Main.hs | 2 +- simplex-chat.cabal | 2 +- src/Simplex/Chat.hs | 2 +- src/Simplex/Chat/Bot.hs | 2 +- src/Simplex/Chat/Controller.hs | 2 +- src/Simplex/Chat/Messages.hs | 2 +- src/Simplex/Chat/Messages/{ChatItemContent.hs => CIContent.hs} | 2 +- src/Simplex/Chat/Store.hs | 2 +- src/Simplex/Chat/Terminal/Input.hs | 2 +- src/Simplex/Chat/View.hs | 2 +- 11 files changed, 11 insertions(+), 11 deletions(-) rename src/Simplex/Chat/Messages/{ChatItemContent.hs => CIContent.hs} (99%) diff --git a/apps/simplex-bot-advanced/Main.hs b/apps/simplex-bot-advanced/Main.hs index 95814a598d..f30438c384 100644 --- a/apps/simplex-bot-advanced/Main.hs +++ b/apps/simplex-bot-advanced/Main.hs @@ -14,7 +14,7 @@ import Simplex.Chat.Bot import Simplex.Chat.Controller import Simplex.Chat.Core import Simplex.Chat.Messages -import Simplex.Chat.Messages.ChatItemContent +import Simplex.Chat.Messages.CIContent import Simplex.Chat.Options import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Types diff --git a/apps/simplex-broadcast-bot/Main.hs b/apps/simplex-broadcast-bot/Main.hs index ae8e4f2782..966971633f 100644 --- a/apps/simplex-broadcast-bot/Main.hs +++ b/apps/simplex-broadcast-bot/Main.hs @@ -16,7 +16,7 @@ import Simplex.Chat.Bot import Simplex.Chat.Controller import Simplex.Chat.Core import Simplex.Chat.Messages -import Simplex.Chat.Messages.ChatItemContent +import Simplex.Chat.Messages.CIContent import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Terminal (terminalChatConfig) diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 6d9b3030d9..abe3763a90 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -33,7 +33,7 @@ library Simplex.Chat.Help Simplex.Chat.Markdown Simplex.Chat.Messages - Simplex.Chat.Messages.ChatItemContent + Simplex.Chat.Messages.CIContent Simplex.Chat.Migrations.M20220101_initial Simplex.Chat.Migrations.M20220122_v1_1 Simplex.Chat.Migrations.M20220205_chat_item_status diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index cd2d5ca702..705b61b046 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -53,7 +53,7 @@ import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Markdown import Simplex.Chat.Messages -import Simplex.Chat.Messages.ChatItemContent +import Simplex.Chat.Messages.CIContent import Simplex.Chat.Options import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index 2c837907eb..05a755fd87 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -16,7 +16,7 @@ import qualified Data.Text as T import Simplex.Chat.Controller import Simplex.Chat.Core import Simplex.Chat.Messages -import Simplex.Chat.Messages.ChatItemContent +import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Store import Simplex.Chat.Types (Contact (..), IsContact (..), User (..)) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index a95e1835e3..e2680bee60 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -42,7 +42,7 @@ import qualified Paths_simplex_chat as SC import Simplex.Chat.Call import Simplex.Chat.Markdown (MarkdownList) import Simplex.Chat.Messages -import Simplex.Chat.Messages.ChatItemContent +import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol import Simplex.Chat.Store (AutoAccept, StoreError, UserContactLink) import Simplex.Chat.Types diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 67e605d067..05cc6909b1 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -32,7 +32,7 @@ import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics (Generic) import Simplex.Chat.Markdown -import Simplex.Chat.Messages.ChatItemContent +import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..)) diff --git a/src/Simplex/Chat/Messages/ChatItemContent.hs b/src/Simplex/Chat/Messages/CIContent.hs similarity index 99% rename from src/Simplex/Chat/Messages/ChatItemContent.hs rename to src/Simplex/Chat/Messages/CIContent.hs index e83aea8182..030f28074a 100644 --- a/src/Simplex/Chat/Messages/ChatItemContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -11,7 +11,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} -module Simplex.Chat.Messages.ChatItemContent where +module Simplex.Chat.Messages.CIContent where import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index dd5e05d513..242cafd9fd 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -330,7 +330,7 @@ import GHC.Generics (Generic) import Simplex.Chat.Call import Simplex.Chat.Markdown import Simplex.Chat.Messages -import Simplex.Chat.Messages.ChatItemContent +import Simplex.Chat.Messages.CIContent import Simplex.Chat.Migrations.M20220101_initial import Simplex.Chat.Migrations.M20220122_v1_1 import Simplex.Chat.Migrations.M20220205_chat_item_status diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 37644ad5e9..ed6c3203d2 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -31,7 +31,7 @@ import GHC.Weak (deRefWeak) import Simplex.Chat import Simplex.Chat.Controller import Simplex.Chat.Messages -import Simplex.Chat.Messages.ChatItemContent +import Simplex.Chat.Messages.CIContent import Simplex.Chat.Styled import Simplex.Chat.Terminal.Output import Simplex.Chat.Types (User (..)) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index b4ecd228fa..eb30fd14f3 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -38,7 +38,7 @@ import Simplex.Chat.Controller import Simplex.Chat.Help import Simplex.Chat.Markdown import Simplex.Chat.Messages hiding (NewChatItem (..)) -import Simplex.Chat.Messages.ChatItemContent +import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..)) import Simplex.Chat.Styled From e1370e8f3c148f2e0dc357f1ad40834288fcecbb Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 18 Jun 2023 10:20:11 +0100 Subject: [PATCH 4/9] core: split Store.hs to multiple files for faster re-compilation (#2589) * core: split Store.hs to multiple files for faster re-compilation * remove unused compiler pragmas --- simplex-chat.cabal | 8 + src/Simplex/Chat.hs | 7 + src/Simplex/Chat/Mobile.hs | 1 + src/Simplex/Chat/Store.hs | 5611 +------------------------ src/Simplex/Chat/Store/Connections.hs | 142 + src/Simplex/Chat/Store/Direct.hs | 689 +++ src/Simplex/Chat/Store/Files.hs | 868 ++++ src/Simplex/Chat/Store/Groups.hs | 1295 ++++++ src/Simplex/Chat/Store/Messages.hs | 1805 ++++++++ src/Simplex/Chat/Store/Migrations.hs | 151 + src/Simplex/Chat/Store/Profiles.hs | 537 +++ src/Simplex/Chat/Store/Shared.hs | 332 ++ tests/ChatClient.hs | 1 + tests/ChatTests/Utils.hs | 2 +- tests/MobileTests.hs | 1 + 15 files changed, 5843 insertions(+), 5607 deletions(-) create mode 100644 src/Simplex/Chat/Store/Connections.hs create mode 100644 src/Simplex/Chat/Store/Direct.hs create mode 100644 src/Simplex/Chat/Store/Files.hs create mode 100644 src/Simplex/Chat/Store/Groups.hs create mode 100644 src/Simplex/Chat/Store/Messages.hs create mode 100644 src/Simplex/Chat/Store/Migrations.hs create mode 100644 src/Simplex/Chat/Store/Profiles.hs create mode 100644 src/Simplex/Chat/Store/Shared.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index abe3763a90..b2ba047ce4 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -107,6 +107,14 @@ library Simplex.Chat.ProfileGenerator Simplex.Chat.Protocol Simplex.Chat.Store + Simplex.Chat.Store.Connections + Simplex.Chat.Store.Direct + Simplex.Chat.Store.Files + Simplex.Chat.Store.Groups + Simplex.Chat.Store.Messages + Simplex.Chat.Store.Migrations + Simplex.Chat.Store.Profiles + Simplex.Chat.Store.Shared Simplex.Chat.Styled Simplex.Chat.Terminal Simplex.Chat.Terminal.Input diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 705b61b046..c186c26d22 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -58,6 +58,13 @@ import Simplex.Chat.Options import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol import Simplex.Chat.Store +import Simplex.Chat.Store.Connections +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Files +import Simplex.Chat.Store.Groups +import Simplex.Chat.Store.Messages +import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.FileTransfer.Client.Main (maxFileSize) import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index eab0cf4d67..85900a6d72 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -37,6 +37,7 @@ import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList) import Simplex.Chat.Mobile.WebRTC import Simplex.Chat.Options import Simplex.Chat.Store +import Simplex.Chat.Store.Profiles import Simplex.Chat.Types import Simplex.Messaging.Agent.Env.SQLite (createAgentStore) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError) diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 242cafd9fd..4e3c4ab90e 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -1,22 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - module Simplex.Chat.Store ( SQLiteStore, StoreError (..), @@ -26,5602 +7,20 @@ module Simplex.Chat.Store migrations, -- used in tests chatStoreFile, agentStoreFile, - createUserRecord, - createUserRecordAt, - getUsersInfo, - getUsers, - setActiveUser, - getSetActiveUser, - getUser, - getUserIdByName, - getUserByAConnId, - getUserByASndFileId, - getUserByARcvFileId, - getUserByContactId, - getUserByGroupId, - getUserByFileId, - getUserByContactRequestId, - getUserFileInfo, - deleteUserRecord, - updateUserPrivacy, - createDirectConnection, - createConnReqConnection, - getProfileById, - getConnReqContactXContactId, - createDirectContact, - deleteContactConnectionsAndFiles, - deleteContact, - deleteContactWithoutGroups, - setContactDeleted, - getDeletedContacts, - getContactByName, - getContact, - getContactIdByName, - updateUserProfile, - setUserProfileContactLink, - updateContactProfile, - updateContactUserPreferences, - updateContactAlias, - updateContactConnectionAlias, - updateContactUsed, - updateContactUnreadChat, - updateGroupUnreadChat, - setConnectionVerified, - incConnectionAuthErrCounter, - setConnectionAuthErrCounter, - getUserContacts, - getUserContactProfiles, - createUserContactLink, - getUserAddressConnections, - getUserContactLinks, - deleteUserAddress, - getUserAddress, - getUserContactLinkById, - updateUserAddressAutoAccept, - createGroupLink, - getGroupLinkConnection, - deleteGroupLink, - getGroupLink, - getGroupLinkId, - setGroupLinkMemberRole, - createOrUpdateContactRequest, - getContactRequest', - getContactRequest, - getContactRequestIdByName, - deleteContactRequest, - createAcceptedContact, - getLiveSndFileTransfers, - getLiveRcvFileTransfers, - getPendingSndChunks, - getPendingContactConnections, - getContactConnections, - getConnectionEntity, - getConnectionById, - getConnectionsContacts, - getGroupAndMember, - updateConnectionStatus, - createNewGroup, - createGroupInvitation, - setGroupInvitationChatItemId, - getGroup, - getGroupInfo, - updateGroupProfile, - getGroupIdByName, - getGroupMemberIdByName, - getGroupInfoByName, - getGroupMember, - getGroupMemberById, - getGroupMembers, - getGroupMembersForExpiration, - deleteGroupConnectionsAndFiles, - deleteGroupItemsAndMembers, - deleteGroup, - getUserGroups, - getUserGroupDetails, - getContactGroupPreferences, - checkContactHasGroups, - getGroupInvitation, - createNewContactMember, - createNewContactMemberAsync, - getContactViaMember, - setNewContactMemberConnRequest, - getMemberInvitation, - createMemberConnection, - createMemberConnectionAsync, - updateGroupMemberStatus, - updateGroupMemberStatusById, - createNewGroupMember, - checkGroupMemberHasItems, - deleteGroupMember, - deleteGroupMemberConnection, - updateGroupMemberRole, - createIntroductions, - updateIntroStatus, - saveIntroInvitation, - createIntroReMember, - createIntroToMemberContact, - saveMemberInvitation, - getViaGroupMember, - getViaGroupContact, - getMatchingContacts, - randomBytes, - createSentProbe, - createSentProbeHash, - deleteSentProbe, - matchReceivedProbe, - matchReceivedProbeHash, - matchSentProbe, - mergeContactRecords, - createSndDirectFileTransfer, - createSndDirectFTConnection, - createSndGroupFileTransfer, - createSndGroupFileTransferConnection, - createSndDirectInlineFT, - createSndGroupInlineFT, - updateSndDirectFTDelivery, - updateSndGroupFTDelivery, - getSndFTViaMsgDelivery, - createSndFileTransferXFTP, - createSndFTDescrXFTP, - setSndFTPrivateSndDescr, - updateSndFTDescrXFTP, - createExtraSndFTDescrs, - updateSndFTDeliveryXFTP, - setSndFTAgentDeleted, - getXFTPSndFileDBId, - getXFTPRcvFileDBId, - updateFileCancelled, - updateCIFileStatus, - getSharedMsgIdByFileId, - getFileIdBySharedMsgId, - getGroupFileIdBySharedMsgId, - getDirectFileIdBySharedMsgId, - getChatRefByFileId, - updateSndFileStatus, - createSndFileChunk, - updateSndFileChunkMsg, - updateSndFileChunkSent, - deleteSndFileChunks, - createRcvFileTransfer, - createRcvGroupFileTransfer, - appendRcvFD, - getRcvFileDescrByFileId, - updateRcvFileAgentId, - getRcvFileTransferById, - getRcvFileTransfer, - acceptRcvFileTransfer, - getContactByFileId, - acceptRcvInlineFT, - startRcvInlineFT, - xftpAcceptRcvFT, - setRcvFileToReceive, - getRcvFilesToReceive, - setRcvFTAgentDeleted, - updateRcvFileStatus, - createRcvFileChunk, - updatedRcvFileChunkStored, - deleteRcvFileChunks, - updateFileTransferChatItemId, - getFileTransfer, - getFileTransferProgress, - getFileTransferMeta, - getSndFileTransfer, - getSndFileTransfers, - getContactFileInfo, - deleteContactCIs, - getGroupFileInfo, - deleteGroupCIs, - createNewSndMessage, - createSndMsgDelivery, - createNewMessageAndRcvMsgDelivery, - createSndMsgDeliveryEvent, - createRcvMsgDeliveryEvent, - createPendingGroupMessage, - getPendingGroupMessages, - deletePendingGroupMessage, - deleteOldMessages, - updateChatTs, - createNewSndChatItem, - createNewRcvChatItem, - createNewChatItemNoMsg, - getChatPreviews, - getDirectChat, - getGroupChat, - getAllChatItems, - getAChatItem, - getChatRefViaItemId, - getChatItemVersions, - getDirectCIReactions, - getDirectReactions, - setDirectReaction, - getGroupCIReactions, - getGroupReactions, - setGroupReaction, - getChatItemIdByAgentMsgId, - getDirectChatItem, - getDirectChatItemBySharedMsgId, - getDirectChatItemByAgentMsgId, - getDirectChatItemsLast, - getGroupChatItem, - getGroupChatItemBySharedMsgId, - getGroupMemberCIBySharedMsgId, - getGroupMemberChatItemLast, - getDirectChatItemIdByText, - getDirectChatItemIdByText', - getGroupChatItemIdByText, - getGroupChatItemIdByText', - getChatItemByFileId, - getChatItemByGroupId, - updateDirectChatItemStatus, - updateDirectCIFileStatus, - updateDirectChatItem, - updateDirectChatItem', - addInitialAndNewCIVersions, - createChatItemVersion, - deleteDirectChatItem, - markDirectChatItemDeleted, - updateGroupChatItem, - deleteGroupChatItem, - updateGroupChatItemModerated, - markGroupChatItemDeleted, - updateDirectChatItemsRead, - getDirectUnreadTimedItems, - setDirectChatItemDeleteAt, - updateGroupChatItemsRead, - getGroupUnreadTimedItems, - setGroupChatItemDeleteAt, - getProtocolServers, - overwriteProtocolServers, - createCall, - deleteCalls, - getCalls, - createCommand, - setCommandConnId, - deleteCommand, - updateCommandStatus, - getCommandDataByCorrId, - setConnConnReqInv, - getXGrpMemIntroContDirect, - getXGrpMemIntroContGroup, - getTimedItems, - getChatItemTTL, - setChatItemTTL, - getContactExpiredFileInfo, - deleteContactExpiredCIs, - getGroupExpiredFileInfo, - deleteGroupExpiredCIs, - getPendingContactConnection, - deletePendingContactConnection, - updateContactSettings, - updateGroupSettings, withTransaction, ) where -import Control.Applicative ((<|>)) -import Control.Concurrent.STM (stateTVar) -import Control.Exception (Exception) -import qualified Control.Exception as E -import Control.Monad.Except -import Crypto.Random (ChaChaDRG, randomBytesGenerate) -import Data.Aeson (ToJSON) -import qualified Data.Aeson as J -import Data.Bifunctor (first) -import qualified Data.ByteString.Base64 as B64 -import Data.ByteString.Char8 (ByteString) -import Data.Either (fromRight, rights) -import Data.Functor (($>)) -import Data.Int (Int64) -import Data.List (sortOn) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as L -import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe) -import Data.Ord (Down (..)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Data.Time (addUTCTime) -import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay) -import Data.Type.Equality -import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), SQLError, (:.) (..)) -import qualified Database.SQLite.Simple as DB -import Database.SQLite.Simple.QQ (sql) -import GHC.Generics (Generic) -import Simplex.Chat.Call -import Simplex.Chat.Markdown -import Simplex.Chat.Messages -import Simplex.Chat.Messages.CIContent -import Simplex.Chat.Migrations.M20220101_initial -import Simplex.Chat.Migrations.M20220122_v1_1 -import Simplex.Chat.Migrations.M20220205_chat_item_status -import Simplex.Chat.Migrations.M20220210_deduplicate_contact_requests -import Simplex.Chat.Migrations.M20220224_messages_fks -import Simplex.Chat.Migrations.M20220301_smp_servers -import Simplex.Chat.Migrations.M20220302_profile_images -import Simplex.Chat.Migrations.M20220304_msg_quotes -import Simplex.Chat.Migrations.M20220321_chat_item_edited -import Simplex.Chat.Migrations.M20220404_files_status_fields -import Simplex.Chat.Migrations.M20220514_profiles_user_id -import Simplex.Chat.Migrations.M20220626_auto_reply -import Simplex.Chat.Migrations.M20220702_calls -import Simplex.Chat.Migrations.M20220715_groups_chat_item_id -import Simplex.Chat.Migrations.M20220811_chat_items_indices -import Simplex.Chat.Migrations.M20220812_incognito_profiles -import Simplex.Chat.Migrations.M20220818_chat_notifications -import Simplex.Chat.Migrations.M20220822_groups_host_conn_custom_user_profile_id -import Simplex.Chat.Migrations.M20220823_delete_broken_group_event_chat_items -import Simplex.Chat.Migrations.M20220824_profiles_local_alias -import Simplex.Chat.Migrations.M20220909_commands -import Simplex.Chat.Migrations.M20220926_connection_alias -import Simplex.Chat.Migrations.M20220928_settings -import Simplex.Chat.Migrations.M20221001_shared_msg_id_indices -import Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items -import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id -import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id -import Simplex.Chat.Migrations.M20221012_inline_files -import Simplex.Chat.Migrations.M20221019_unread_chat -import Simplex.Chat.Migrations.M20221021_auto_accept__group_links -import Simplex.Chat.Migrations.M20221024_contact_used -import Simplex.Chat.Migrations.M20221025_chat_settings -import Simplex.Chat.Migrations.M20221029_group_link_id -import Simplex.Chat.Migrations.M20221112_server_password -import Simplex.Chat.Migrations.M20221115_server_cfg -import Simplex.Chat.Migrations.M20221129_delete_group_feature_items -import Simplex.Chat.Migrations.M20221130_delete_item_deleted -import Simplex.Chat.Migrations.M20221209_verified_connection -import Simplex.Chat.Migrations.M20221210_idxs -import Simplex.Chat.Migrations.M20221211_group_description -import Simplex.Chat.Migrations.M20221212_chat_items_timed -import Simplex.Chat.Migrations.M20221214_live_message -import Simplex.Chat.Migrations.M20221222_chat_ts -import Simplex.Chat.Migrations.M20221223_idx_chat_items_item_status -import Simplex.Chat.Migrations.M20221230_idxs -import Simplex.Chat.Migrations.M20230107_connections_auth_err_counter -import Simplex.Chat.Migrations.M20230111_users_agent_user_id -import Simplex.Chat.Migrations.M20230117_fkey_indexes -import Simplex.Chat.Migrations.M20230118_recreate_smp_servers -import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx -import Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id -import Simplex.Chat.Migrations.M20230303_group_link_role -import Simplex.Chat.Migrations.M20230317_hidden_profiles -import Simplex.Chat.Migrations.M20230318_file_description -import Simplex.Chat.Migrations.M20230321_agent_file_deleted -import Simplex.Chat.Migrations.M20230328_files_protocol -import Simplex.Chat.Migrations.M20230402_protocol_servers -import Simplex.Chat.Migrations.M20230411_extra_xftp_file_descriptions -import Simplex.Chat.Migrations.M20230420_rcv_files_to_receive -import Simplex.Chat.Migrations.M20230422_profile_contact_links -import Simplex.Chat.Migrations.M20230504_recreate_msg_delivery_events_cleanup_messages -import Simplex.Chat.Migrations.M20230505_chat_item_versions -import Simplex.Chat.Migrations.M20230511_reactions -import Simplex.Chat.Migrations.M20230519_item_deleted_ts -import Simplex.Chat.Migrations.M20230526_indexes -import Simplex.Chat.Migrations.M20230529_indexes -import Simplex.Chat.Migrations.M20230608_deleted_contacts -import Simplex.Chat.Protocol -import Simplex.Chat.Types -import Simplex.Chat.Util (week) -import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..), UserId) -import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, MigrationError, SQLiteStore (..), createSQLiteStore, firstRow, firstRow', maybeFirstRow, withTransaction) -import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) -import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) -import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..)) -import Simplex.Messaging.Transport.Client (TransportHost) -import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8) -import UnliftIO.STM - -schemaMigrations :: [(String, Query, Maybe Query)] -schemaMigrations = - [ ("20220101_initial", m20220101_initial, Nothing), - ("20220122_v1_1", m20220122_v1_1, Nothing), - ("20220205_chat_item_status", m20220205_chat_item_status, Nothing), - ("20220210_deduplicate_contact_requests", m20220210_deduplicate_contact_requests, Nothing), - ("20220224_messages_fks", m20220224_messages_fks, Nothing), - ("20220301_smp_servers", m20220301_smp_servers, Nothing), - ("20220302_profile_images", m20220302_profile_images, Nothing), - ("20220304_msg_quotes", m20220304_msg_quotes, Nothing), - ("20220321_chat_item_edited", m20220321_chat_item_edited, Nothing), - ("20220404_files_status_fields", m20220404_files_status_fields, Nothing), - ("20220514_profiles_user_id", m20220514_profiles_user_id, Nothing), - ("20220626_auto_reply", m20220626_auto_reply, Nothing), - ("20220702_calls", m20220702_calls, Nothing), - ("20220715_groups_chat_item_id", m20220715_groups_chat_item_id, Nothing), - ("20220811_chat_items_indices", m20220811_chat_items_indices, Nothing), - ("20220812_incognito_profiles", m20220812_incognito_profiles, Nothing), - ("20220818_chat_notifications", m20220818_chat_notifications, Nothing), - ("20220822_groups_host_conn_custom_user_profile_id", m20220822_groups_host_conn_custom_user_profile_id, Nothing), - ("20220823_delete_broken_group_event_chat_items", m20220823_delete_broken_group_event_chat_items, Nothing), - ("20220824_profiles_local_alias", m20220824_profiles_local_alias, Nothing), - ("20220909_commands", m20220909_commands, Nothing), - ("20220926_connection_alias", m20220926_connection_alias, Nothing), - ("20220928_settings", m20220928_settings, Nothing), - ("20221001_shared_msg_id_indices", m20221001_shared_msg_id_indices, Nothing), - ("20221003_delete_broken_integrity_error_chat_items", m20221003_delete_broken_integrity_error_chat_items, Nothing), - ("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id, Nothing), - ("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id, Nothing), - ("20221012_inline_files", m20221012_inline_files, Nothing), - ("20221019_unread_chat", m20221019_unread_chat, Nothing), - ("20221021_auto_accept__group_links", m20221021_auto_accept__group_links, Nothing), - ("20221024_contact_used", m20221024_contact_used, Nothing), - ("20221025_chat_settings", m20221025_chat_settings, Nothing), - ("20221029_group_link_id", m20221029_group_link_id, Nothing), - ("20221112_server_password", m20221112_server_password, Nothing), - ("20221115_server_cfg", m20221115_server_cfg, Nothing), - ("20221129_delete_group_feature_items", m20221129_delete_group_feature_items, Nothing), - ("20221130_delete_item_deleted", m20221130_delete_item_deleted, Nothing), - ("20221209_verified_connection", m20221209_verified_connection, Nothing), - ("20221210_idxs", m20221210_idxs, Nothing), - ("20221211_group_description", m20221211_group_description, Nothing), - ("20221212_chat_items_timed", m20221212_chat_items_timed, Nothing), - ("20221214_live_message", m20221214_live_message, Nothing), - ("20221222_chat_ts", m20221222_chat_ts, Nothing), - ("20221223_idx_chat_items_item_status", m20221223_idx_chat_items_item_status, Nothing), - ("20221230_idxs", m20221230_idxs, Nothing), - ("20230107_connections_auth_err_counter", m20230107_connections_auth_err_counter, Nothing), - ("20230111_users_agent_user_id", m20230111_users_agent_user_id, Nothing), - ("20230117_fkey_indexes", m20230117_fkey_indexes, Nothing), - ("20230118_recreate_smp_servers", m20230118_recreate_smp_servers, Nothing), - ("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx, Nothing), - ("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id, Nothing), - ("20230303_group_link_role", m20230303_group_link_role, Nothing), - ("20230317_hidden_profiles", m20230317_hidden_profiles, Just down_m20230317_hidden_profiles), - ("20230318_file_description", m20230318_file_description, Just down_m20230318_file_description), - ("20230321_agent_file_deleted", m20230321_agent_file_deleted, Just down_m20230321_agent_file_deleted), - ("20230328_files_protocol", m20230328_files_protocol, Just down_m20230328_files_protocol), - ("20230402_protocol_servers", m20230402_protocol_servers, Just down_m20230402_protocol_servers), - ("20230411_extra_xftp_file_descriptions", m20230411_extra_xftp_file_descriptions, Just down_m20230411_extra_xftp_file_descriptions), - ("20230420_rcv_files_to_receive", m20230420_rcv_files_to_receive, Just down_m20230420_rcv_files_to_receive), - ("20230422_profile_contact_links", m20230422_profile_contact_links, Just down_m20230422_profile_contact_links), - ("20230504_recreate_msg_delivery_events_cleanup_messages", m20230504_recreate_msg_delivery_events_cleanup_messages, Just down_m20230504_recreate_msg_delivery_events_cleanup_messages), - ("20230505_chat_item_versions", m20230505_chat_item_versions, Just down_m20230505_chat_item_versions), - ("20230511_reactions", m20230511_reactions, Just down_m20230511_reactions), - ("20230519_item_deleted_ts", m20230519_item_deleted_ts, Just down_m20230519_item_deleted_ts), - ("20230526_indexes", m20230526_indexes, Just down_m20230526_indexes), - ("20230529_indexes", m20230529_indexes, Just down_m20230529_indexes), - ("20230608_deleted_contacts", m20230608_deleted_contacts, Just down_m20230608_deleted_contacts) - ] - --- | The list of migrations in ascending order by date -migrations :: [Migration] -migrations = sortOn name $ map migration schemaMigrations - where - migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down} +import Simplex.Chat.Store.Migrations +import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Shared +import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, MigrationError, SQLiteStore (..), createSQLiteStore, withTransaction) createChatStore :: FilePath -> String -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore) -createChatStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey migrations +createChatStore dbPath dbKey = createSQLiteStore dbPath dbKey migrations chatStoreFile :: FilePath -> FilePath chatStoreFile = (<> "_chat.db") agentStoreFile :: FilePath -> FilePath agentStoreFile = (<> "_agent.db") - -checkConstraint :: StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a -checkConstraint err action = ExceptT $ runExceptT action `E.catch` (pure . Left . handleSQLError err) - -handleSQLError :: StoreError -> SQLError -> StoreError -handleSQLError err e - | DB.sqlError e == DB.ErrorConstraint = err - | otherwise = SEInternalError $ show e - -insertedRowId :: DB.Connection -> IO Int64 -insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()" - -createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User -createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime - -createUserRecordAt :: DB.Connection -> AgentUserId -> Profile -> Bool -> UTCTime -> ExceptT StoreError IO User -createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, image, preferences = userPreferences} activeUser currentTs = - checkConstraint SEDuplicateName . liftIO $ do - when activeUser $ DB.execute_ db "UPDATE users SET active_user = 0" - DB.execute - db - "INSERT INTO users (agent_user_id, local_display_name, active_user, contact_id, show_ntfs, created_at, updated_at) VALUES (?,?,?,0,?,?,?)" - (auId, displayName, activeUser, True, currentTs, currentTs) - userId <- insertedRowId db - DB.execute - db - "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (displayName, displayName, userId, currentTs, currentTs) - DB.execute - db - "INSERT INTO contact_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (displayName, fullName, image, userId, userPreferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO contacts (contact_profile_id, local_display_name, user_id, is_user, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (profileId, displayName, userId, True, currentTs, currentTs) - contactId <- insertedRowId db - DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId) - pure $ toUser $ (userId, auId, contactId, profileId, activeUser, displayName, fullName, image, Nothing, userPreferences, True) :. (Nothing, Nothing) - -getUsersInfo :: DB.Connection -> IO [UserInfo] -getUsersInfo db = getUsers db >>= mapM getUserInfo - where - getUserInfo :: User -> IO UserInfo - getUserInfo user@User {userId} = do - ctCount <- - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT COUNT(1) - FROM chat_items i - JOIN contacts ct USING (contact_id) - WHERE i.user_id = ? AND i.item_status = ? AND (ct.enable_ntfs = 1 OR ct.enable_ntfs IS NULL) AND ct.deleted = 0 - |] - (userId, CISRcvNew) - gCount <- - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT COUNT(1) - FROM chat_items i - JOIN groups g USING (group_id) - WHERE i.user_id = ? AND i.item_status = ? AND (g.enable_ntfs = 1 OR g.enable_ntfs IS NULL) - |] - (userId, CISRcvNew) - pure UserInfo {user, unreadCount = fromMaybe 0 ctCount + fromMaybe 0 gCount} - -getUsers :: DB.Connection -> IO [User] -getUsers db = - map toUser <$> DB.query_ db userQuery - -userQuery :: Query -userQuery = - [sql| - SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.local_display_name, ucp.full_name, ucp.image, ucp.contact_link, ucp.preferences, u.show_ntfs, u.view_pwd_hash, u.view_pwd_salt - FROM users u - JOIN contacts uct ON uct.contact_id = u.contact_id - JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id - |] - -toUser :: (UserId, UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences, Bool) :. (Maybe B64UrlByteString, Maybe B64UrlByteString) -> User -toUser ((userId, auId, userContactId, profileId, activeUser, displayName, fullName, image, contactLink, userPreferences, showNtfs) :. (viewPwdHash_, viewPwdSalt_)) = - User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, fullPreferences, showNtfs, viewPwdHash} - where - profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences = userPreferences, localAlias = ""} - fullPreferences = mergePreferences Nothing userPreferences - viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_ - -setActiveUser :: DB.Connection -> UserId -> IO () -setActiveUser db userId = do - DB.execute_ db "UPDATE users SET active_user = 0" - DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?" (Only userId) - -getSetActiveUser :: DB.Connection -> UserId -> ExceptT StoreError IO User -getSetActiveUser db userId = do - liftIO $ setActiveUser db userId - getUser db userId - -getUser :: DB.Connection -> UserId -> ExceptT StoreError IO User -getUser db userId = - ExceptT . firstRow toUser (SEUserNotFound userId) $ - DB.query db (userQuery <> " WHERE u.user_id = ?") (Only userId) - -getUserIdByName :: DB.Connection -> UserName -> ExceptT StoreError IO Int64 -getUserIdByName db uName = - ExceptT . firstRow fromOnly (SEUserNotFoundByName uName) $ - DB.query db "SELECT user_id FROM users WHERE local_display_name = ?" (Only uName) - -getUserByAConnId :: DB.Connection -> AgentConnId -> IO (Maybe User) -getUserByAConnId db agentConnId = - maybeFirstRow toUser $ - DB.query db (userQuery <> " JOIN connections c ON c.user_id = u.user_id WHERE c.agent_conn_id = ?") (Only agentConnId) - -getUserByASndFileId :: DB.Connection -> AgentSndFileId -> IO (Maybe User) -getUserByASndFileId db aSndFileId = - maybeFirstRow toUser $ - DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.agent_snd_file_id = ?") (Only aSndFileId) - -getUserByARcvFileId :: DB.Connection -> AgentRcvFileId -> IO (Maybe User) -getUserByARcvFileId db aRcvFileId = - maybeFirstRow toUser $ - DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id JOIN rcv_files r ON r.file_id = f.file_id WHERE r.agent_rcv_file_id = ?") (Only aRcvFileId) - -getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User -getUserByContactId db contactId = - ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $ - DB.query db (userQuery <> " JOIN contacts ct ON ct.user_id = u.user_id WHERE ct.contact_id = ? AND ct.deleted = 0") (Only contactId) - -getUserByGroupId :: DB.Connection -> GroupId -> ExceptT StoreError IO User -getUserByGroupId db groupId = - ExceptT . firstRow toUser (SEUserNotFoundByGroupId groupId) $ - DB.query db (userQuery <> " JOIN groups g ON g.user_id = u.user_id WHERE g.group_id = ?") (Only groupId) - -getUserByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO User -getUserByFileId db fileId = - ExceptT . firstRow toUser (SEUserNotFoundByFileId fileId) $ - DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.file_id = ?") (Only fileId) - -getUserByContactRequestId :: DB.Connection -> Int64 -> ExceptT StoreError IO User -getUserByContactRequestId db contactRequestId = - ExceptT . firstRow toUser (SEUserNotFoundByContactRequestId contactRequestId) $ - DB.query db (userQuery <> " JOIN contact_requests cr ON cr.user_id = u.user_id WHERE cr.contact_request_id = ?") (Only contactRequestId) - -getUserFileInfo :: DB.Connection -> User -> IO [CIFileInfo] -getUserFileInfo db User {userId} = - map toFileInfo - <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ?") (Only userId) - -fileInfoQuery :: Query -fileInfoQuery = - [sql| - SELECT f.file_id, f.ci_file_status, f.file_path - FROM chat_items i - JOIN files f ON f.chat_item_id = i.chat_item_id - |] - -toFileInfo :: (Int64, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo -toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath} - -deleteUserRecord :: DB.Connection -> User -> IO () -deleteUserRecord db User {userId} = - DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) - -updateUserPrivacy :: DB.Connection -> User -> IO () -updateUserPrivacy db User {userId, showNtfs, viewPwdHash} = - DB.execute - db - [sql| - UPDATE users - SET view_pwd_hash = ?, view_pwd_salt = ?, show_ntfs = ? - WHERE user_id = ? - |] - (hashSalt viewPwdHash :. (showNtfs, userId)) - where - hashSalt = L.unzip . fmap (\UserPwdHash {hash, salt} -> (hash, salt)) - -createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> IO PendingContactConnection -createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId = do - createdAt <- getCurrentTime - customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile - let pccConnStatus = ConnJoined - DB.execute - db - [sql| - INSERT INTO connections ( - user_id, agent_conn_id, conn_status, conn_type, - via_contact_uri_hash, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at - ) VALUES (?,?,?,?,?,?,?,?,?,?,?) - |] - ((userId, acId, pccConnStatus, ConnContact, cReqHash, xContactId) :. (customUserProfileId, isJust groupLinkId, groupLinkId, createdAt, createdAt)) - pccConnId <- insertedRowId db - pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, groupLinkId, customUserProfileId, connReqInv = Nothing, localAlias = "", createdAt, updatedAt = createdAt} - -getConnReqContactXContactId :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId) -getConnReqContactXContactId db user@User {userId} cReqHash = do - getContact' >>= \case - c@(Just _) -> pure (c, Nothing) - Nothing -> (Nothing,) <$> getXContactId - where - getContact' :: IO (Maybe Contact) - getContact' = - maybeFirstRow (toContact user) $ - DB.query - db - [sql| - SELECT - -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, - c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM contacts ct - JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id - JOIN connections c ON c.contact_id = ct.contact_id - WHERE ct.user_id = ? AND c.via_contact_uri_hash = ? AND ct.deleted = 0 - ORDER BY c.connection_id DESC - LIMIT 1 - |] - (userId, cReqHash) - getXContactId :: IO (Maybe XContactId) - getXContactId = - maybeFirstRow fromOnly $ - DB.query - db - "SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1" - (userId, cReqHash) - -createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> IO PendingContactConnection -createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile = do - createdAt <- getCurrentTime - customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile - DB.execute - db - [sql| - INSERT INTO connections - (user_id, agent_conn_id, conn_req_inv, conn_status, conn_type, custom_user_profile_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?) - |] - (userId, acId, cReq, pccConnStatus, ConnContact, customUserProfileId, createdAt, createdAt) - pccConnId <- insertedRowId db - pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, viaUserContactLink = Nothing, groupLinkId = Nothing, customUserProfileId, connReqInv = Just cReq, localAlias = "", createdAt, updatedAt = createdAt} - -createIncognitoProfile_ :: DB.Connection -> UserId -> UTCTime -> Profile -> IO Int64 -createIncognitoProfile_ db userId createdAt Profile {displayName, fullName, image} = do - DB.execute - db - [sql| - INSERT INTO contact_profiles (display_name, full_name, image, user_id, incognito, created_at, updated_at) - VALUES (?,?,?,?,?,?,?) - |] - (displayName, fullName, image, userId, Just True, createdAt, createdAt) - insertedRowId db - -getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile -getProfileById db userId profileId = - ExceptT . firstRow toProfile (SEProfileNotFound profileId) $ - DB.query - db - [sql| - SELECT cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, cp.preferences -- , ct.user_preferences - FROM contact_profiles cp - WHERE cp.user_id = ? AND cp.contact_profile_id = ? - |] - (userId, profileId) - where - toProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences) -> LocalProfile - toProfile (displayName, fullName, image, contactLink, localAlias, preferences) = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - -createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> IO Connection -createConnection_ db userId connType entityId acId viaContact viaUserContactLink customUserProfileId connLevel currentTs = do - viaLinkGroupId :: Maybe Int64 <- fmap join . forM viaUserContactLink $ \ucLinkId -> - maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? AND group_id IS NOT NULL" (userId, ucLinkId) - let viaGroupLink = isJust viaLinkGroupId - DB.execute - db - [sql| - INSERT INTO connections ( - user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, custom_user_profile_id, conn_status, conn_type, - contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (userId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, customUserProfileId, ConnNew, connType) - :. (ent ConnContact, ent ConnMember, ent ConnSndFile, ent ConnRcvFile, ent ConnUserContact, currentTs, currentTs) - ) - connId <- insertedRowId db - pure Connection {connId, agentConnId = AgentConnId acId, connType, entityId, viaContact, viaUserContactLink, viaGroupLink, groupLinkId = Nothing, customUserProfileId, connLevel, connStatus = ConnNew, localAlias = "", createdAt = currentTs, connectionCode = Nothing, authErrCounter = 0} - where - ent ct = if connType == ct then entityId else Nothing - -createDirectContact :: DB.Connection -> User -> Connection -> Profile -> ExceptT StoreError IO Contact -createDirectContact db user@User {userId} activeConn@Connection {connId, localAlias} p@Profile {preferences} = do - createdAt <- liftIO getCurrentTime - (localDisplayName, contactId, profileId) <- createContact_ db userId connId p localAlias Nothing createdAt (Just createdAt) - let profile = toLocalProfile profileId p localAlias - userPreferences = emptyChatPrefs - mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt, updatedAt = createdAt, chatTs = Just createdAt} - -createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> LocalAlias -> Maybe Int64 -> UTCTime -> Maybe UTCTime -> ExceptT StoreError IO (Text, ContactId, ProfileId) -createContact_ db userId connId Profile {displayName, fullName, image, contactLink, preferences} localAlias viaGroup currentTs chatTs = - ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do - DB.execute - db - "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, local_alias, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" - (displayName, fullName, image, contactLink, userId, localAlias, preferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO contacts (contact_profile_id, local_display_name, user_id, via_group, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?)" - (profileId, ldn, userId, viaGroup, currentTs, currentTs, chatTs) - contactId <- insertedRowId db - DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId) - pure $ Right (ldn, contactId, profileId) - -deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO () -deleteContactConnectionsAndFiles db userId Contact {contactId} = do - DB.execute - db - [sql| - DELETE FROM connections WHERE connection_id IN ( - SELECT connection_id - FROM connections c - JOIN contacts ct ON ct.contact_id = c.contact_id - WHERE ct.user_id = ? AND ct.contact_id = ? - ) - |] - (userId, contactId) - DB.execute db "DELETE FROM files WHERE user_id = ? AND contact_id = ?" (userId, contactId) - -deleteContact :: DB.Connection -> User -> Contact -> IO () -deleteContact db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) - ctMember :: (Maybe ContactId) <- maybeFirstRow fromOnly $ DB.query db "SELECT contact_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId) - if isNothing ctMember - then do - deleteContactProfile_ db userId contactId - DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - else do - currentTs <- getCurrentTime - DB.execute db "UPDATE group_members SET contact_id = NULL, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId) - DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId) - forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId - --- should only be used if contact is not member of any groups -deleteContactWithoutGroups :: DB.Connection -> User -> Contact -> IO () -deleteContactWithoutGroups db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) - deleteContactProfile_ db userId contactId - DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId) - forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId - -setContactDeleted :: DB.Connection -> User -> Contact -> IO () -setContactDeleted db User {userId} Contact {contactId} = do - currentTs <- getCurrentTime - DB.execute db "UPDATE contacts SET deleted = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId) - -getDeletedContacts :: DB.Connection -> User -> IO [Contact] -getDeletedContacts db user@User {userId} = do - contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 1" (Only userId) - rights <$> mapM (runExceptT . getDeletedContact db user) contactIds - -getDeletedContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact -getDeletedContact db user contactId = getContact_ db user contactId True - -deleteUnusedIncognitoProfileById_ :: DB.Connection -> User -> ProfileId -> IO () -deleteUnusedIncognitoProfileById_ db User {userId} profile_id = - DB.executeNamed - db - [sql| - DELETE FROM contact_profiles - WHERE user_id = :user_id AND contact_profile_id = :profile_id AND incognito = 1 - AND 1 NOT IN ( - SELECT 1 FROM connections - WHERE user_id = :user_id AND custom_user_profile_id = :profile_id LIMIT 1 - ) - AND 1 NOT IN ( - SELECT 1 FROM group_members - WHERE user_id = :user_id AND member_profile_id = :profile_id LIMIT 1 - ) - |] - [":user_id" := userId, ":profile_id" := profile_id] - -deleteContactProfile_ :: DB.Connection -> UserId -> ContactId -> IO () -deleteContactProfile_ db userId contactId = - DB.execute - db - [sql| - DELETE FROM contact_profiles - WHERE contact_profile_id in ( - SELECT contact_profile_id - FROM contacts - WHERE user_id = ? AND contact_id = ? - ) - |] - (userId, contactId) - -updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User -updateUserProfile db user p' - | displayName == newName = do - liftIO $ updateContactProfile_ db userId profileId p' - pure user {profile, fullPreferences} - | otherwise = - checkConstraint SEDuplicateName . liftIO $ do - currentTs <- getCurrentTime - DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId) - DB.execute - db - "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (newName, newName, userId, currentTs, currentTs) - updateContactProfile_' db userId profileId p' currentTs - updateContact_ db userId userContactId localDisplayName newName currentTs - pure user {localDisplayName = newName, profile, fullPreferences} - where - User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user - Profile {displayName = newName, preferences} = p' - profile = toLocalProfile profileId p' localAlias - fullPreferences = mergePreferences Nothing preferences - -setUserProfileContactLink :: DB.Connection -> User -> Maybe UserContactLink -> IO User -setUserProfileContactLink db user@User {userId, profile = p@LocalProfile {profileId}} ucl_ = do - ts <- getCurrentTime - DB.execute - db - [sql| - UPDATE contact_profiles - SET contact_link = ?, updated_at = ? - WHERE user_id = ? AND contact_profile_id = ? - |] - (connReqContact_, ts, userId, profileId) - pure (user :: User) {profile = p {contactLink = connReqContact_}} - where - connReqContact_ = case ucl_ of - Just UserContactLink {connReqContact} -> Just connReqContact - _ -> Nothing - -updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact -updateContactProfile db user@User {userId} c p' - | displayName == newName = do - liftIO $ updateContactProfile_ db userId profileId p' - pure c {profile, mergedPreferences} - | otherwise = - ExceptT . withLocalDisplayName db userId newName $ \ldn -> do - currentTs <- getCurrentTime - updateContactProfile_' db userId profileId p' currentTs - updateContact_ db userId contactId localDisplayName ldn currentTs - pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} - where - Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, activeConn, userPreferences} = c - Profile {displayName = newName, preferences} = p' - profile = toLocalProfile profileId p' localAlias - mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - -updateContactUserPreferences :: DB.Connection -> User -> Contact -> Preferences -> IO Contact -updateContactUserPreferences db user@User {userId} c@Contact {contactId, activeConn} userPreferences = do - updatedAt <- getCurrentTime - DB.execute - db - "UPDATE contacts SET user_preferences = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" - (userPreferences, updatedAt, userId, contactId) - let mergedPreferences = contactUserPreferences user userPreferences (preferences' c) $ connIncognito activeConn - pure $ c {mergedPreferences, userPreferences} - -updateContactAlias :: DB.Connection -> UserId -> Contact -> LocalAlias -> IO Contact -updateContactAlias db userId c@Contact {profile = lp@LocalProfile {profileId}} localAlias = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE contact_profiles - SET local_alias = ?, updated_at = ? - WHERE user_id = ? AND contact_profile_id = ? - |] - (localAlias, updatedAt, userId, profileId) - pure $ (c :: Contact) {profile = lp {localAlias}} - -updateContactConnectionAlias :: DB.Connection -> UserId -> PendingContactConnection -> LocalAlias -> IO PendingContactConnection -updateContactConnectionAlias db userId conn localAlias = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE connections - SET local_alias = ?, updated_at = ? - WHERE user_id = ? AND connection_id = ? - |] - (localAlias, updatedAt, userId, pccConnId conn) - pure (conn :: PendingContactConnection) {localAlias} - -updateContactUsed :: DB.Connection -> User -> Contact -> IO () -updateContactUsed db User {userId} Contact {contactId} = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (updatedAt, userId, contactId) - -updateContactUnreadChat :: DB.Connection -> User -> Contact -> Bool -> IO () -updateContactUnreadChat db User {userId} Contact {contactId} unreadChat = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE contacts SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" (unreadChat, updatedAt, userId, contactId) - -updateGroupUnreadChat :: DB.Connection -> User -> GroupInfo -> Bool -> IO () -updateGroupUnreadChat db User {userId} GroupInfo {groupId} unreadChat = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE groups SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (unreadChat, updatedAt, userId, groupId) - -setConnectionVerified :: DB.Connection -> User -> Int64 -> Maybe Text -> IO () -setConnectionVerified db User {userId} connId code = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE connections SET security_code = ?, security_code_verified_at = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (code, code $> updatedAt, updatedAt, userId, connId) - -incConnectionAuthErrCounter :: DB.Connection -> User -> Connection -> IO Int -incConnectionAuthErrCounter db User {userId} Connection {connId, authErrCounter} = do - updatedAt <- getCurrentTime - (counter_ :: Maybe Int) <- maybeFirstRow fromOnly $ DB.query db "SELECT auth_err_counter FROM connections WHERE user_id = ? AND connection_id = ?" (userId, connId) - let counter' = fromMaybe authErrCounter counter_ + 1 - DB.execute db "UPDATE connections SET auth_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter', updatedAt, userId, connId) - pure counter' - -setConnectionAuthErrCounter :: DB.Connection -> User -> Connection -> Int -> IO () -setConnectionAuthErrCounter db User {userId} Connection {connId} counter = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE connections SET auth_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter, updatedAt, userId, connId) - -updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO () -updateContactProfile_ db userId profileId profile = do - currentTs <- getCurrentTime - updateContactProfile_' db userId profileId profile currentTs - -updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO () -updateContactProfile_' db userId profileId Profile {displayName, fullName, image, contactLink, preferences} updatedAt = do - DB.execute - db - [sql| - UPDATE contact_profiles - SET display_name = ?, full_name = ?, image = ?, contact_link = ?, preferences = ?, updated_at = ? - WHERE user_id = ? AND contact_profile_id = ? - |] - (displayName, fullName, image, contactLink, preferences, updatedAt, userId, profileId) - -updateContact_ :: DB.Connection -> UserId -> Int64 -> ContactName -> ContactName -> UTCTime -> IO () -updateContact_ db userId contactId displayName newName updatedAt = do - DB.execute - db - "UPDATE contacts SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" - (newName, updatedAt, userId, contactId) - DB.execute - db - "UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" - (newName, updatedAt, userId, contactId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (displayName, userId) - -type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) - -toContact :: User -> ContactRow :. ConnectionRow -> Contact -toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = - let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - activeConn = toConnection connRow - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} - mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} - -toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact -toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = - let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} - in case toMaybeConnection connRow of - Just activeConn -> - let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} - _ -> Left $ SEContactNotReady localDisplayName - -getContactByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Contact -getContactByName db user localDisplayName = do - cId <- getContactIdByName db user localDisplayName - getContact db user cId - -getUserContacts :: DB.Connection -> User -> IO [Contact] -getUserContacts db user@User {userId} = do - contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId) - rights <$> mapM (runExceptT . getContact db user) contactIds - --- only used in tests -getUserContactProfiles :: DB.Connection -> User -> IO [Profile] -getUserContactProfiles db User {userId} = - map toContactProfile - <$> DB.query - db - [sql| - SELECT display_name, full_name, image, contact_link, preferences - FROM contact_profiles - WHERE user_id = ? - |] - (Only userId) - where - toContactProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) -> (Profile) - toContactProfile (displayName, fullName, image, contactLink, preferences) = Profile {displayName, fullName, image, contactLink, preferences} - -createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> ExceptT StoreError IO () -createUserContactLink db User {userId} agentConnId cReq = - checkConstraint SEDuplicateContactLink . liftIO $ do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?)" - (userId, cReq, currentTs, currentTs) - userContactLinkId <- insertedRowId db - void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs - -getUserAddressConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection] -getUserAddressConnections db User {userId} = do - cs <- liftIO getUserAddressConnections_ - if null cs then throwError SEUserContactLinkNotFound else pure cs - where - getUserAddressConnections_ :: IO [Connection] - getUserAddressConnections_ = - map toConnection - <$> DB.query - db - [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM connections c - JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id - WHERE c.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL - |] - (userId, userId) - -getUserContactLinks :: DB.Connection -> User -> IO [(Connection, UserContact)] -getUserContactLinks db User {userId} = - map toUserContactConnection - <$> DB.query - db - [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, - uc.user_contact_link_id, uc.conn_req_contact, uc.group_id - FROM connections c - JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id - WHERE c.user_id = ? AND uc.user_id = ? - |] - (userId, userId) - where - toUserContactConnection :: (ConnectionRow :. (Int64, ConnReqContact, Maybe GroupId)) -> (Connection, UserContact) - toUserContactConnection (connRow :. (userContactLinkId, connReqContact, groupId)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact, groupId}) - -deleteUserAddress :: DB.Connection -> User -> IO () -deleteUserAddress db user@User {userId} = do - DB.execute - db - [sql| - DELETE FROM connections WHERE connection_id IN ( - SELECT connection_id - FROM connections c - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL - ) - |] - (Only userId) - DB.executeNamed - db - [sql| - DELETE FROM display_names - WHERE user_id = :user_id - AND local_display_name in ( - SELECT cr.local_display_name - FROM contact_requests cr - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL - ) - |] - [":user_id" := userId] - DB.executeNamed - db - [sql| - DELETE FROM contact_profiles - WHERE contact_profile_id in ( - SELECT cr.contact_profile_id - FROM contact_requests cr - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL - ) - |] - [":user_id" := userId] - void $ setUserProfileContactLink db user Nothing - DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL" (Only userId) - -data UserContactLink = UserContactLink - { connReqContact :: ConnReqContact, - autoAccept :: Maybe AutoAccept - } - deriving (Show, Generic) - -instance ToJSON UserContactLink where toEncoding = J.genericToEncoding J.defaultOptions - -data AutoAccept = AutoAccept - { acceptIncognito :: Bool, - autoReply :: Maybe MsgContent - } - deriving (Show, Generic) - -instance ToJSON AutoAccept where toEncoding = J.genericToEncoding J.defaultOptions - -toUserContactLink :: (ConnReqContact, Bool, Bool, Maybe MsgContent) -> UserContactLink -toUserContactLink (connReq, autoAccept, acceptIncognito, autoReply) = - UserContactLink connReq $ - if autoAccept then Just AutoAccept {acceptIncognito, autoReply} else Nothing - -getUserAddress :: DB.Connection -> User -> ExceptT StoreError IO UserContactLink -getUserAddress db User {userId} = - ExceptT . firstRow toUserContactLink SEUserContactLinkNotFound $ - DB.query - db - [sql| - SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content - FROM user_contact_links - WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL - |] - (Only userId) - -getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (UserContactLink, Maybe GroupId, GroupMemberRole)) -getUserContactLinkById db userId userContactLinkId = - maybeFirstRow (\(ucl :. (groupId_, mRole_)) -> (toUserContactLink ucl, groupId_, fromMaybe GRMember mRole_)) $ - DB.query - db - [sql| - SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role - FROM user_contact_links - WHERE user_id = ? - AND user_contact_link_id = ? - |] - (userId, userContactLinkId) - -updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink -updateUserAddressAutoAccept db user@User {userId} autoAccept = do - link <- getUserAddress db user - liftIO updateUserAddressAutoAccept_ $> link {autoAccept} - where - updateUserAddressAutoAccept_ = - DB.execute - db - [sql| - UPDATE user_contact_links - SET auto_accept = ?, auto_accept_incognito = ?, auto_reply_msg_content = ? - WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL - |] - (ucl :. Only userId) - ucl = case autoAccept of - Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply) - _ -> (False, False, Nothing) - -createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> ExceptT StoreError IO () -createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq groupLinkId memberRole = - checkConstraint (SEDuplicateGroupLink groupInfo) . liftIO $ do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, group_link_member_role, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" - (userId, groupId, groupLinkId, "group_link_" <> localDisplayName, cReq, memberRole, True, currentTs, currentTs) - userContactLinkId <- insertedRowId db - void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs - -getGroupLinkConnection :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO Connection -getGroupLinkConnection db User {userId} groupInfo@GroupInfo {groupId} = - ExceptT . firstRow toConnection (SEGroupLinkNotFound groupInfo) $ - DB.query - db - [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM connections c - JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id - WHERE c.user_id = ? AND uc.user_id = ? AND uc.group_id = ? - |] - (userId, userId, groupId) - -deleteGroupLink :: DB.Connection -> User -> GroupInfo -> IO () -deleteGroupLink db User {userId} GroupInfo {groupId} = do - DB.execute - db - [sql| - DELETE FROM connections WHERE connection_id IN ( - SELECT connection_id - FROM connections c - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = ? AND uc.group_id = ? - ) - |] - (userId, groupId) - DB.execute - db - [sql| - DELETE FROM display_names - WHERE user_id = ? - AND local_display_name in ( - SELECT cr.local_display_name - FROM contact_requests cr - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = ? AND uc.group_id = ? - ) - |] - (userId, userId, groupId) - DB.execute - db - [sql| - DELETE FROM contact_profiles - WHERE contact_profile_id in ( - SELECT cr.contact_profile_id - FROM contact_requests cr - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = ? AND uc.group_id = ? - ) - |] - (userId, groupId) - DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId) - -getGroupLink :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO (Int64, ConnReqContact, GroupMemberRole) -getGroupLink db User {userId} gInfo@GroupInfo {groupId} = - ExceptT . firstRow groupLink (SEGroupLinkNotFound gInfo) $ - DB.query db "SELECT user_contact_link_id, conn_req_contact, group_link_member_role FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId) - where - groupLink (linkId, cReq, mRole_) = (linkId, cReq, fromMaybe GRMember mRole_) - -getGroupLinkId :: DB.Connection -> User -> GroupInfo -> IO (Maybe GroupLinkId) -getGroupLinkId db User {userId} GroupInfo {groupId} = - fmap join . maybeFirstRow fromOnly $ - DB.query db "SELECT group_link_id FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId) - -setGroupLinkMemberRole :: DB.Connection -> User -> Int64 -> GroupMemberRole -> IO () -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) - -createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest -createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profile {displayName, fullName, image, contactLink, preferences} xContactId_ = - liftIO (maybeM getContact' xContactId_) >>= \case - Just contact -> pure $ CORContact contact - Nothing -> CORRequest <$> createOrUpdate_ - where - maybeM = maybe (pure Nothing) - createOrUpdate_ :: ExceptT StoreError IO UserContactRequest - createOrUpdate_ = do - cReqId <- - ExceptT $ - maybeM getContactRequestByXContactId xContactId_ >>= \case - Nothing -> createContactRequest - Just cr -> updateContactRequest cr $> Right (contactRequestId (cr :: UserContactRequest)) - getContactRequest db user cReqId - createContactRequest :: IO (Either StoreError Int64) - createContactRequest = do - currentTs <- getCurrentTime - withLocalDisplayName db userId displayName (fmap Right . createContactRequest_ currentTs) - where - createContactRequest_ currentTs ldn = do - DB.execute - db - "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - [sql| - INSERT INTO contact_requests - (user_contact_link_id, agent_invitation_id, contact_profile_id, local_display_name, user_id, created_at, updated_at, xcontact_id) - VALUES (?,?,?,?,?,?,?,?) - |] - (userContactLinkId, invId, profileId, ldn, userId, currentTs, currentTs, xContactId_) - insertedRowId db - getContact' :: XContactId -> IO (Maybe Contact) - getContact' xContactId = - maybeFirstRow (toContact user) $ - DB.query - db - [sql| - SELECT - -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, - c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM contacts ct - JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id - LEFT JOIN connections c ON c.contact_id = ct.contact_id - WHERE ct.user_id = ? AND ct.xcontact_id = ? AND ct.deleted = 0 - ORDER BY c.connection_id DESC - LIMIT 1 - |] - (userId, xContactId) - getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest) - getContactRequestByXContactId xContactId = - maybeFirstRow toContactRequest $ - DB.query - db - [sql| - SELECT - cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id, - c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at - FROM contact_requests cr - JOIN connections c USING (user_contact_link_id) - JOIN contact_profiles p USING (contact_profile_id) - WHERE cr.user_id = ? - AND cr.xcontact_id = ? - LIMIT 1 - |] - (userId, xContactId) - updateContactRequest :: UserContactRequest -> IO (Either StoreError ()) - updateContactRequest UserContactRequest {contactRequestId = cReqId, localDisplayName = oldLdn, profile = Profile {displayName = oldDisplayName}} = do - currentTs <- liftIO getCurrentTime - updateProfile currentTs - if displayName == oldDisplayName - then Right <$> DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, currentTs, userId, cReqId) - else withLocalDisplayName db userId displayName $ \ldn -> - Right <$> do - DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, ldn, currentTs, userId, cReqId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (oldLdn, userId) - where - updateProfile currentTs = - DB.execute - db - [sql| - UPDATE contact_profiles - SET display_name = ?, - full_name = ?, - image = ?, - contact_link = ?, - updated_at = ? - WHERE contact_profile_id IN ( - SELECT contact_profile_id - FROM contact_requests - WHERE user_id = ? - AND contact_request_id = ? - ) - |] - (displayName, fullName, image, contactLink, currentTs, userId, cReqId) - -getContactRequest' :: DB.Connection -> Int64 -> ExceptT StoreError IO (User, UserContactRequest) -getContactRequest' db contactRequestId = do - user <- getUserByContactRequestId db contactRequestId - (user,) <$> getContactRequest db user contactRequestId - -getContactRequest :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO UserContactRequest -getContactRequest db User {userId} contactRequestId = - ExceptT . firstRow toContactRequest (SEContactRequestNotFound contactRequestId) $ - DB.query - db - [sql| - SELECT - cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id, - c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at - FROM contact_requests cr - JOIN connections c USING (user_contact_link_id) - JOIN contact_profiles p USING (contact_profile_id) - WHERE cr.user_id = ? - AND cr.contact_request_id = ? - |] - (userId, contactRequestId) - -type ContactRequestRow = (Int64, ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact) :. (Maybe XContactId, Maybe Preferences, UTCTime, UTCTime) - -toContactRequest :: ContactRequestRow -> UserContactRequest -toContactRequest ((contactRequestId, localDisplayName, agentInvitationId, userContactLinkId, agentContactConnId, profileId, displayName, fullName, image, contactLink) :. (xContactId, preferences, createdAt, updatedAt)) = do - let profile = Profile {displayName, fullName, image, contactLink, preferences} - in UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, localDisplayName, profileId, profile, xContactId, createdAt, updatedAt} - -getContactRequestIdByName :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Int64 -getContactRequestIdByName db userId cName = - ExceptT . firstRow fromOnly (SEContactRequestNotFoundByName cName) $ - DB.query db "SELECT contact_request_id FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, cName) - -deleteContactRequest :: DB.Connection -> User -> Int64 -> IO () -deleteContactRequest db User {userId} contactRequestId = do - DB.execute - db - [sql| - DELETE FROM contact_profiles - WHERE contact_profile_id in ( - SELECT contact_profile_id - FROM contact_requests - WHERE user_id = ? AND contact_request_id = ? - ) - |] - (userId, contactRequestId) - DB.execute - db - [sql| - DELETE FROM display_names - WHERE user_id = ? AND local_display_name = ( - SELECT local_display_name FROM contact_requests - WHERE user_id = ? AND contact_request_id = ? - ) - |] - (userId, userId, contactRequestId) - DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId) - -createAcceptedContact :: DB.Connection -> User -> ConnId -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> IO Contact -createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do - DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - createdAt <- getCurrentTime - customUserProfileId <- forM incognitoProfile $ \case - NewIncognito p -> createIncognitoProfile_ db userId createdAt p - ExistingIncognito LocalProfile {profileId = pId} -> pure pId - let userPreferences = fromMaybe emptyChatPrefs $ incognitoProfile >> preferences - DB.execute - db - "INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, chat_ts, xcontact_id) VALUES (?,?,?,?,?,?,?,?,?)" - (userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, createdAt, xContactId) - contactId <- insertedRowId db - activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing (Just userContactLinkId) customUserProfileId 0 createdAt - let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt, chatTs = Just createdAt} - -getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] -getLiveSndFileTransfers db User {userId} = do - cutoffTs <- addUTCTime (- week) <$> getCurrentTime - fileIds :: [Int64] <- - map fromOnly - <$> DB.query - db - [sql| - SELECT DISTINCT f.file_id - FROM files f - JOIN snd_files s USING (file_id) - WHERE f.user_id = ? - AND s.file_status IN (?, ?, ?) - AND s.file_descr_id IS NULL - AND s.file_inline IS NULL - AND s.created_at > ? - |] - (userId, FSNew, FSAccepted, FSConnected, cutoffTs) - concatMap (filter liveTransfer) . rights <$> mapM (getSndFileTransfers_ db userId) fileIds - where - liveTransfer :: SndFileTransfer -> Bool - liveTransfer SndFileTransfer {fileStatus} = fileStatus `elem` [FSNew, FSAccepted, FSConnected] - -getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer] -getLiveRcvFileTransfers db user@User {userId} = do - cutoffTs <- addUTCTime (- week) <$> getCurrentTime - fileIds :: [Int64] <- - map fromOnly - <$> DB.query - db - [sql| - SELECT f.file_id - FROM files f - JOIN rcv_files r USING (file_id) - WHERE f.user_id = ? AND r.file_status IN (?, ?) - AND r.rcv_file_inline IS NULL - AND r.file_descr_id IS NULL - AND r.created_at > ? - |] - (userId, FSAccepted, FSConnected, cutoffTs) - rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds - -getPendingSndChunks :: DB.Connection -> Int64 -> Int64 -> IO [Integer] -getPendingSndChunks db fileId connId = - map fromOnly - <$> DB.query - db - [sql| - SELECT chunk_number - FROM snd_file_chunks - WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id IS NULL - ORDER BY chunk_number - |] - (fileId, connId) - -getPendingContactConnections :: DB.Connection -> User -> IO [PendingContactConnection] -getPendingContactConnections db User {userId} = do - map toPendingContactConnection - <$> DB.queryNamed - db - [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at - FROM connections - WHERE user_id = :user_id - AND conn_type = :conn_type - AND contact_id IS NULL - |] - [":user_id" := userId, ":conn_type" := ConnContact] - -getContactConnections :: DB.Connection -> UserId -> Contact -> ExceptT StoreError IO [Connection] -getContactConnections db userId Contact {contactId} = - connections =<< liftIO getConnections_ - where - getConnections_ = - DB.query - db - [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM connections c - JOIN contacts ct ON ct.contact_id = c.contact_id - WHERE c.user_id = ? AND ct.user_id = ? AND ct.contact_id = ? - |] - (userId, userId, contactId) - connections [] = throwError $ SEContactNotFound contactId - connections rows = pure $ map toConnection rows - -type EntityIdsRow = (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64) - -type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, Bool, Maybe GroupLinkId, Maybe Int64, ConnStatus, ConnType, LocalAlias) :. EntityIdsRow :. (UTCTime, Maybe Text, Maybe UTCTime, Int) - -type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe Bool, Maybe GroupLinkId, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe Int) - -toConnection :: ConnectionRow -> Connection -toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter)) = - let entityId = entityId_ connType - connectionCode = SecurityCode <$> code_ <*> verifiedAt_ - in Connection {connId, agentConnId = AgentConnId acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias, entityId, connectionCode, authErrCounter, createdAt} - where - entityId_ :: ConnType -> Maybe Int64 - entityId_ ConnContact = contactId - entityId_ ConnMember = groupMemberId - entityId_ ConnRcvFile = rcvFileId - entityId_ ConnSndFile = sndFileId - entityId_ ConnUserContact = userContactLinkId - -toMaybeConnection :: MaybeConnectionRow -> Maybe Connection -toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just authErrCounter)) = - Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter)) -toMaybeConnection _ = Nothing - -getMatchingContacts :: DB.Connection -> User -> Contact -> IO [Contact] -getMatchingContacts db user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, image}} = do - contactIds <- - map fromOnly - <$> DB.query - db - [sql| - SELECT ct.contact_id - FROM contacts ct - JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id - WHERE ct.user_id = ? AND ct.contact_id != ? - AND ct.deleted = 0 - AND p.display_name = ? AND p.full_name = ? - AND ((p.image IS NULL AND ? IS NULL) OR p.image = ?) - |] - (userId, contactId, displayName, fullName, image, image) - rights <$> mapM (runExceptT . getContact db user) contactIds - -createSentProbe :: DB.Connection -> TVar ChaChaDRG -> UserId -> Contact -> ExceptT StoreError IO (Probe, Int64) -createSentProbe db gVar userId _to@Contact {contactId} = - createWithRandomBytes 32 gVar $ \probe -> do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO sent_probes (contact_id, probe, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (contactId, probe, userId, currentTs, currentTs) - (Probe probe,) <$> insertedRowId db - -createSentProbeHash :: DB.Connection -> UserId -> Int64 -> Contact -> IO () -createSentProbeHash db userId probeId _to@Contact {contactId} = do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO sent_probe_hashes (sent_probe_id, contact_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (probeId, contactId, userId, currentTs, currentTs) - -deleteSentProbe :: DB.Connection -> UserId -> Int64 -> IO () -deleteSentProbe db userId probeId = - DB.execute - db - "DELETE FROM sent_probes WHERE user_id = ? AND sent_probe_id = ?" - (userId, probeId) - -matchReceivedProbe :: DB.Connection -> User -> Contact -> Probe -> IO (Maybe Contact) -matchReceivedProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = do - let probeHash = C.sha256Hash probe - contactIds <- - map fromOnly - <$> DB.query - db - [sql| - SELECT c.contact_id - FROM contacts c - JOIN received_probes r ON r.contact_id = c.contact_id - WHERE c.user_id = ? AND c.deleted = 0 AND r.probe_hash = ? AND r.probe IS NULL - |] - (userId, probeHash) - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO received_probes (contact_id, probe, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (contactId, probe, probeHash, userId, currentTs, currentTs) - case contactIds of - [] -> pure Nothing - cId : _ -> eitherToMaybe <$> runExceptT (getContact db user cId) - -matchReceivedProbeHash :: DB.Connection -> User -> Contact -> ProbeHash -> IO (Maybe (Contact, Probe)) -matchReceivedProbeHash db user@User {userId} _from@Contact {contactId} (ProbeHash probeHash) = do - namesAndProbes <- - DB.query - db - [sql| - SELECT c.contact_id, r.probe - FROM contacts c - JOIN received_probes r ON r.contact_id = c.contact_id - WHERE c.user_id = ? AND c.deleted = 0 AND r.probe_hash = ? AND r.probe IS NOT NULL - |] - (userId, probeHash) - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO received_probes (contact_id, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (contactId, probeHash, userId, currentTs, currentTs) - case namesAndProbes of - [] -> pure Nothing - (cId, probe) : _ -> - either (const Nothing) (Just . (,Probe probe)) - <$> runExceptT (getContact db user cId) - -matchSentProbe :: DB.Connection -> User -> Contact -> Probe -> IO (Maybe Contact) -matchSentProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = do - contactIds <- - map fromOnly - <$> DB.query - db - [sql| - SELECT c.contact_id - FROM contacts c - JOIN sent_probes s ON s.contact_id = c.contact_id - JOIN sent_probe_hashes h ON h.sent_probe_id = s.sent_probe_id - WHERE c.user_id = ? AND c.deleted = 0 AND s.probe = ? AND h.contact_id = ? - |] - (userId, probe, contactId) - case contactIds of - [] -> pure Nothing - cId : _ -> eitherToMaybe <$> runExceptT (getContact db user cId) - -mergeContactRecords :: DB.Connection -> UserId -> Contact -> Contact -> IO () -mergeContactRecords db userId ct1 ct2 = do - let (toCt, fromCt) = toFromContacts ct1 ct2 - Contact {contactId = toContactId} = toCt - Contact {contactId = fromContactId, localDisplayName} = fromCt - currentTs <- getCurrentTime - -- TODO next query fixes incorrect unused contacts deletion; consider more thorough fix - when (contactDirect toCt && not (contactUsed toCt)) $ - DB.execute - db - "UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" - (currentTs, userId, toContactId) - DB.execute - db - "UPDATE connections SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?" - (toContactId, currentTs, fromContactId, userId) - DB.execute - db - "UPDATE connections SET via_contact = ?, updated_at = ? WHERE via_contact = ? AND user_id = ?" - (toContactId, currentTs, fromContactId, userId) - DB.execute - db - "UPDATE group_members SET invited_by = ?, updated_at = ? WHERE invited_by = ? AND user_id = ?" - (toContactId, currentTs, fromContactId, userId) - DB.execute - db - "UPDATE chat_items SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?" - (toContactId, currentTs, fromContactId, userId) - DB.executeNamed - db - [sql| - UPDATE group_members - SET contact_id = :to_contact_id, - local_display_name = (SELECT local_display_name FROM contacts WHERE contact_id = :to_contact_id), - contact_profile_id = (SELECT contact_profile_id FROM contacts WHERE contact_id = :to_contact_id), - updated_at = :updated_at - WHERE contact_id = :from_contact_id - AND user_id = :user_id - |] - [ ":to_contact_id" := toContactId, - ":from_contact_id" := fromContactId, - ":user_id" := userId, - ":updated_at" := currentTs - ] - deleteContactProfile_ db userId fromContactId - DB.execute db "DELETE FROM contacts WHERE contact_id = ? AND user_id = ?" (fromContactId, userId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) - where - toFromContacts :: Contact -> Contact -> (Contact, Contact) - toFromContacts c1 c2 - | d1 && not d2 = (c1, c2) - | d2 && not d1 = (c2, c1) - | ctCreatedAt c1 <= ctCreatedAt c2 = (c1, c2) - | otherwise = (c2, c1) - where - d1 = directOrUsed c1 - d2 = directOrUsed c2 - ctCreatedAt Contact {createdAt} = createdAt - -getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity -getConnectionEntity db user@User {userId, userContactId} agentConnId = do - c@Connection {connType, entityId} <- getConnection_ - case entityId of - Nothing -> - if connType == ConnContact - then pure $ RcvDirectMsgConnection c Nothing - else throwError $ SEInternalError $ "connection " <> show connType <> " without entity" - Just entId -> - case connType of - ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ entId c - ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ entId c - ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ entId c - ConnRcvFile -> RcvFileConnection c <$> getRcvFileTransfer db user entId - ConnUserContact -> UserContactConnection c <$> getUserContact_ entId - where - getConnection_ :: ExceptT StoreError IO Connection - getConnection_ = ExceptT $ do - firstRow toConnection (SEConnectionNotFound agentConnId) $ - DB.query - db - [sql| - SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id, - conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter - FROM connections - WHERE user_id = ? AND agent_conn_id = ? - |] - (userId, agentConnId) - getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact - getContactRec_ contactId c = ExceptT $ do - toContact' contactId c - <$> DB.query - db - [sql| - SELECT - c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, c.via_group, c.contact_used, c.enable_ntfs, - p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts - FROM contacts c - JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id - WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0 - |] - (userId, contactId) - toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)] -> Either StoreError Contact - toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)] = - let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} - mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} - toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" - getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) - getGroupAndMember_ groupMemberId c = ExceptT $ do - firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $ - DB.query - db - [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - -- GroupInfo {membership} - mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, - -- GroupInfo {membership = GroupMember {memberProfile}} - pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, - -- from GroupMember - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences - FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - JOIN groups g ON g.group_id = m.group_id - JOIN group_profiles gp USING (group_profile_id) - JOIN group_members mu ON g.group_id = mu.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? - |] - (groupMemberId, userId, userContactId) - toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember) - toGroupAndMember c (groupInfoRow :. memberRow) = - let groupInfo = toGroupInfo userContactId groupInfoRow - member = toGroupMember userContactId memberRow - in (groupInfo, (member :: GroupMember) {activeConn = Just c}) - getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer - getConnSndFileTransfer_ fileId Connection {connId} = - ExceptT $ - firstRow' (sndFileTransfer_ fileId connId) (SESndFileNotFound fileId) $ - DB.query - db - [sql| - SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.group_member_id, cs.local_display_name, m.local_display_name - FROM snd_files s - JOIN files f USING (file_id) - LEFT JOIN contacts cs USING (contact_id) - LEFT JOIN group_members m USING (group_member_id) - WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ? - |] - (userId, fileId, connId) - sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer - sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, contactName_, memberName_) = - case contactName_ <|> memberName_ of - Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId, groupMemberId} - Nothing -> Left $ SESndFileInvalid fileId - getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact - getUserContact_ userContactLinkId = ExceptT $ do - userContact_ - <$> DB.query - db - [sql| - SELECT conn_req_contact, group_id - FROM user_contact_links - WHERE user_id = ? AND user_contact_link_id = ? - |] - (userId, userContactLinkId) - where - userContact_ :: [(ConnReqContact, Maybe GroupId)] -> Either StoreError UserContact - userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId} - userContact_ _ = Left SEUserContactLinkNotFound - -getConnectionById :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Connection -getConnectionById db User {userId} connId = ExceptT $ do - firstRow toConnection (SEConnectionNotFoundById connId) $ - DB.query - db - [sql| - SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id, - conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter - FROM connections - WHERE user_id = ? AND connection_id = ? - |] - (userId, connId) - -getConnectionsContacts :: DB.Connection -> [ConnId] -> IO [ContactRef] -getConnectionsContacts db agentConnIds = do - DB.execute_ db "DROP TABLE IF EXISTS temp.conn_ids" - DB.execute_ db "CREATE TABLE temp.conn_ids (conn_id BLOB)" - DB.executeMany db "INSERT INTO temp.conn_ids (conn_id) VALUES (?)" $ map Only agentConnIds - conns <- - map toContactRef - <$> DB.query - db - [sql| - SELECT ct.contact_id, c.connection_id, c.agent_conn_id, ct.local_display_name - FROM contacts ct - JOIN connections c ON c.contact_id = ct.contact_id - WHERE c.agent_conn_id IN (SELECT conn_id FROM temp.conn_ids) - AND c.conn_type = ? - AND ct.deleted = 0 - |] - (Only ConnContact) - DB.execute_ db "DROP TABLE temp.conn_ids" - pure conns - where - toContactRef :: (ContactId, Int64, ConnId, ContactName) -> ContactRef - toContactRef (contactId, connId, acId, localDisplayName) = ContactRef {contactId, connId, agentConnId = AgentConnId acId, localDisplayName} - -getGroupAndMember :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupMember) -getGroupAndMember db User {userId, userContactId} groupMemberId = - ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $ - DB.query - db - [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - -- GroupInfo {membership} - mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, - -- GroupInfo {membership = GroupMember {memberProfile}} - pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, - -- from GroupMember - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - JOIN groups g ON g.group_id = m.group_id - JOIN group_profiles gp USING (group_profile_id) - JOIN group_members mu ON g.group_id = mu.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - LEFT JOIN connections c ON c.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.group_member_id = m.group_member_id - ) - WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? - |] - (groupMemberId, userId, userContactId) - where - toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) - toGroupAndMember (groupInfoRow :. memberRow :. connRow) = - let groupInfo = toGroupInfo userContactId groupInfoRow - member = toGroupMember userContactId memberRow - in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) - -updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO () -updateConnectionStatus db Connection {connId} connStatus = do - currentTs <- getCurrentTime - DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId) - --- | creates completely new group with a single member - the current user -createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> ExceptT StoreError IO GroupInfo -createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do - let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile - fullGroupPreferences = mergeGroupPreferences groupPreferences - currentTs <- getCurrentTime - withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do - groupId <- liftIO $ do - DB.execute - db - "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO groups (local_display_name, user_id, group_profile_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?)" - (ldn, userId, profileId, True, currentTs, currentTs, currentTs) - insertedRowId db - memberId <- liftIO $ encodedRandomBytes gVar 12 - membership <- createContactMemberInv_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing currentTs - let chatSettings = ChatSettings {enableNtfs = True} - pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs} - --- | creates a new group record for the group the current user was invited to, or returns an existing one -createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId) -createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do - liftIO getInvitationGroupId_ >>= \case - Nothing -> createGroupInvitation_ - Just gId -> do - gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db user gId - hostId <- getHostMemberId_ db user gId - let GroupMember {groupMemberId, memberId, memberRole} = membership - MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember - liftIO . when (memberId /= memberId' || memberRole /= memberRole') $ - DB.execute db "UPDATE group_members SET member_id = ?, member_role = ? WHERE group_member_id = ?" (memberId', memberRole', groupMemberId) - gInfo' <- - if p' == groupProfile - then pure gInfo - else updateGroupProfile db user gInfo groupProfile - pure (gInfo', hostId) - where - getInvitationGroupId_ :: IO (Maybe Int64) - getInvitationGroupId_ = - maybeFirstRow fromOnly $ - DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId) - createGroupInvitation_ :: ExceptT StoreError IO (GroupInfo, GroupMemberId) - createGroupInvitation_ = do - let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile - fullGroupPreferences = mergeGroupPreferences groupPreferences - ExceptT $ - withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do - currentTs <- liftIO getCurrentTime - groupId <- liftIO $ do - DB.execute - db - "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?,?)" - (profileId, localDisplayName, connRequest, customUserProfileId, userId, True, currentTs, currentTs, currentTs) - insertedRowId db - GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs - membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs - let chatSettings = ChatSettings {enableNtfs = True} - pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId) - -getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId -getHostMemberId_ db User {userId} groupId = - ExceptT . firstRow fromOnly (SEHostMemberIdNotFound groupId) $ - DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND member_category = ?" (userId, groupId, GCHostMember) - -createContactMemberInv_ :: IsContact a => DB.Connection -> User -> GroupId -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ProfileId -> UTCTime -> ExceptT StoreError IO GroupMember -createContactMemberInv_ db User {userId, userContactId} groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy incognitoProfileId createdAt = do - incognitoProfile <- forM incognitoProfileId $ \profileId -> getProfileById db userId profileId - (localDisplayName, memberProfile) <- case (incognitoProfile, incognitoProfileId) of - (Just profile@LocalProfile {displayName}, Just profileId) -> - (,profile) <$> insertMemberIncognitoProfile_ displayName profileId - _ -> (,profile' userOrContact) <$> liftIO insertMember_ - groupMemberId <- liftIO $ insertedRowId db - pure - GroupMember - { groupMemberId, - groupId, - memberId, - memberRole, - memberCategory, - memberStatus, - invitedBy, - localDisplayName, - memberProfile, - memberContactId = Just $ contactId' userOrContact, - memberContactProfileId = localProfileId (profile' userOrContact), - activeConn = Nothing - } - where - insertMember_ :: IO ContactName - insertMember_ = do - let localDisplayName = localDisplayName' userOrContact - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, - user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy) - :. (userId, localDisplayName' userOrContact, contactId' userOrContact, localProfileId $ profile' userOrContact, createdAt, createdAt) - ) - pure localDisplayName - insertMemberIncognitoProfile_ :: ContactName -> ProfileId -> ExceptT StoreError IO ContactName - insertMemberIncognitoProfile_ incognitoDisplayName customUserProfileId = ExceptT $ - withLocalDisplayName db userId incognitoDisplayName $ \incognitoLdn -> do - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, - user_id, local_display_name, contact_id, contact_profile_id, member_profile_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy) - :. (userId, incognitoLdn, contactId' userOrContact, localProfileId $ profile' userOrContact, customUserProfileId, createdAt, createdAt) - ) - pure $ Right incognitoLdn - -setGroupInvitationChatItemId :: DB.Connection -> User -> GroupId -> ChatItemId -> IO () -setGroupInvitationChatItemId db User {userId} groupId chatItemId = do - currentTs <- getCurrentTime - DB.execute db "UPDATE groups SET chat_item_id = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (chatItemId, currentTs, userId, groupId) - --- TODO return the last connection that is ready, not any last connection --- requires updating connection status -getGroup :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO Group -getGroup db user groupId = do - gInfo <- getGroupInfo db user groupId - members <- liftIO $ getGroupMembers db user gInfo - pure $ Group gInfo members - -deleteGroupConnectionsAndFiles :: DB.Connection -> User -> GroupInfo -> [GroupMember] -> IO () -deleteGroupConnectionsAndFiles db User {userId} GroupInfo {groupId} members = do - forM_ members $ \m -> DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId' m) - DB.execute db "DELETE FROM files WHERE user_id = ? AND group_id = ?" (userId, groupId) - -deleteGroupItemsAndMembers :: DB.Connection -> User -> GroupInfo -> [GroupMember] -> IO () -deleteGroupItemsAndMembers db user@User {userId} GroupInfo {groupId} members = do - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId) - void $ runExceptT cleanupHostGroupLinkConn_ -- to allow repeat connection via the same group link if one was used - DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_id = ?" (userId, groupId) - forM_ members $ \m@GroupMember {memberProfile = LocalProfile {profileId}} -> do - cleanupMemberProfileAndName_ db user m - when (memberIncognito m) $ deleteUnusedIncognitoProfileById_ db user profileId - where - cleanupHostGroupLinkConn_ = do - hostId <- getHostMemberId_ db user groupId - liftIO $ - DB.execute - db - [sql| - UPDATE connections SET via_contact_uri_hash = NULL, xcontact_id = NULL - WHERE user_id = ? AND via_group_link = 1 AND contact_id IN ( - SELECT contact_id - FROM group_members - WHERE user_id = ? AND group_member_id = ? - ) - |] - (userId, userId, hostId) - -deleteGroup :: DB.Connection -> User -> GroupInfo -> IO () -deleteGroup db user@User {userId} GroupInfo {groupId, localDisplayName, membership = membership@GroupMember {memberProfile = LocalProfile {profileId}}} = do - deleteGroupProfile_ db userId groupId - DB.execute db "DELETE FROM groups WHERE user_id = ? AND group_id = ?" (userId, groupId) - DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - when (memberIncognito membership) $ deleteUnusedIncognitoProfileById_ db user profileId - -deleteGroupProfile_ :: DB.Connection -> UserId -> GroupId -> IO () -deleteGroupProfile_ db userId groupId = - DB.execute - db - [sql| - DELETE FROM group_profiles - WHERE group_profile_id in ( - SELECT group_profile_id - FROM groups - WHERE user_id = ? AND group_id = ? - ) - |] - (userId, groupId) - -getUserGroups :: DB.Connection -> User -> IO [Group] -getUserGroups db user@User {userId} = do - groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId) - rights <$> mapM (runExceptT . getGroup db user) groupIds - -getUserGroupDetails :: DB.Connection -> User -> IO [GroupInfo] -getUserGroupDetails db User {userId, userContactId} = - map (toGroupInfo userContactId) - <$> DB.query - db - [sql| - SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - mu.group_member_id, g.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, - mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences - FROM groups g - JOIN group_profiles gp USING (group_profile_id) - JOIN group_members mu USING (group_id) - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - WHERE g.user_id = ? AND mu.contact_id = ? - |] - (userId, userContactId) - -getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences] -getContactGroupPreferences db User {userId} Contact {contactId} = do - map (mergeGroupPreferences . fromOnly) - <$> DB.query - db - [sql| - SELECT gp.preferences - FROM groups g - JOIN group_profiles gp USING (group_profile_id) - JOIN group_members m USING (group_id) - WHERE g.user_id = ? AND m.contact_id = ? - |] - (userId, contactId) - -checkContactHasGroups :: DB.Connection -> User -> Contact -> IO (Maybe GroupId) -checkContactHasGroups db User {userId} Contact {contactId} = - maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId) - -getGroupInfoByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupInfo -getGroupInfoByName db user gName = do - gId <- getGroupIdByName db user gName - getGroupInfo db user gId - -type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe GroupPreferences, UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow - -toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo -toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, groupPreferences, createdAt, updatedAt, chatTs) :. userMemberRow) = - let membership = toGroupMember userContactId userMemberRow - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} - fullGroupPreferences = mergeGroupPreferences groupPreferences - groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences} - in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs} - -groupMemberQuery :: Query -groupMemberQuery = - [sql| - SELECT - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - LEFT JOIN connections c ON c.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.group_member_id = m.group_member_id - ) - |] - -getGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember -getGroupMember db user@User {userId} groupId groupMemberId = - ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound groupMemberId) $ - DB.query - db - (groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?") - (groupId, groupMemberId, userId) - -getGroupMemberById :: DB.Connection -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember -getGroupMemberById db user@User {userId} groupMemberId = - ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound groupMemberId) $ - DB.query - db - (groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ?") - (groupMemberId, userId) - -getGroupMembers :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] -getGroupMembers db user@User {userId, userContactId} GroupInfo {groupId} = do - map (toContactMember user) - <$> DB.query - db - (groupMemberQuery <> " WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)") - (groupId, userId, userContactId) - -getGroupMembersForExpiration :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] -getGroupMembersForExpiration db user@User {userId, userContactId} GroupInfo {groupId} = do - map (toContactMember user) - <$> DB.query - db - ( groupMemberQuery - <> [sql| - WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) - AND m.member_status IN (?, ?, ?) - AND m.group_member_id NOT IN ( - SELECT DISTINCT group_member_id FROM chat_items - ) - |] - ) - (groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) - -toContactMember :: User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember -toContactMember User {userContactId} (memberRow :. connRow) = - (toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow} - -getGroupInvitation :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation -getGroupInvitation db user groupId = - getConnRec_ user >>= \case - Just connRequest -> do - groupInfo@GroupInfo {membership} <- getGroupInfo db user groupId - when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined - hostId <- getHostMemberId_ db user groupId - fromMember <- getGroupMember db user groupId hostId - pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo} - _ -> throwError SEGroupInvitationNotFound - where - getConnRec_ :: User -> ExceptT StoreError IO (Maybe ConnReqInvitation) - getConnRec_ User {userId} = ExceptT $ do - firstRow fromOnly (SEGroupNotFound groupId) $ - DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId) - -type GroupMemberRow = ((Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus) :. (Maybe Int64, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences)) - -type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus) :. (Maybe Int64, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences)) - -toGroupMember :: Int64 -> GroupMemberRow -> GroupMember -toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) = - let memberProfile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - invitedBy = toInvitedBy userContactId invitedById - activeConn = Nothing - in GroupMember {..} - -toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember -toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus) :. (invitedById, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image, contactLink, Just localAlias, contactPreferences)) = - Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences)) -toMaybeGroupMember _ _ = Nothing - -createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember -createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole agentConnId connRequest = - createWithRandomId gVar $ \memId -> do - createdAt <- liftIO getCurrentTime - member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt - void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt - pure member - where - createMember_ memberId createdAt = do - insertMember_ - groupMemberId <- liftIO $ insertedRowId db - pure - GroupMember - { groupMemberId, - groupId, - memberId, - memberRole, - memberCategory = GCInviteeMember, - memberStatus = GSMemInvited, - invitedBy = IBUser, - localDisplayName, - memberProfile = profile, - memberContactId = Just contactId, - memberContactProfileId = localProfileId profile, - activeConn = Nothing - } - where - insertMember_ = - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, - user_id, local_display_name, contact_id, contact_profile_id, sent_inv_queue_info, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser) - :. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt) - ) - -createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> ExceptT StoreError IO () -createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) = - createWithRandomId gVar $ \memId -> do - createdAt <- liftIO getCurrentTime - insertMember_ (MemberId memId) createdAt - groupMemberId <- liftIO $ insertedRowId db - Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt - setCommandConnId db user cmdId connId - where - insertMember_ memberId createdAt = - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, - user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser) - :. (userId, localDisplayName, contactId, localProfileId profile, createdAt, createdAt) - ) - -getContactViaMember :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact) -getContactViaMember db user@User {userId} GroupMember {groupMemberId} = - maybeFirstRow (toContact user) $ - DB.query - db - [sql| - SELECT - -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, - c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM contacts ct - JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id - JOIN connections c ON c.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.contact_id = ct.contact_id - ) - JOIN group_members m ON m.contact_id = ct.contact_id - WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0 - |] - (userId, groupMemberId) - -setNewContactMemberConnRequest :: DB.Connection -> User -> GroupMember -> ConnReqInvitation -> IO () -setNewContactMemberConnRequest db User {userId} GroupMember {groupMemberId} connRequest = do - currentTs <- getCurrentTime - DB.execute db "UPDATE group_members SET sent_inv_queue_info = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?" (connRequest, currentTs, userId, groupMemberId) - -getMemberInvitation :: DB.Connection -> User -> Int64 -> IO (Maybe ConnReqInvitation) -getMemberInvitation db User {userId} groupMemberId = - fmap join . maybeFirstRow fromOnly $ - DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId) - -createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> IO () -createMemberConnection db userId GroupMember {groupMemberId} agentConnId = do - currentTs <- getCurrentTime - void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs - -createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> IO () -createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) = do - currentTs <- getCurrentTime - Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs - setCommandConnId db user cmdId connId - -updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO () -updateGroupMemberStatus db userId GroupMember {groupMemberId} = updateGroupMemberStatusById db userId groupMemberId - -updateGroupMemberStatusById :: DB.Connection -> UserId -> GroupMemberId -> GroupMemberStatus -> IO () -updateGroupMemberStatusById db userId groupMemberId memStatus = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - UPDATE group_members - SET member_status = ?, updated_at = ? - WHERE user_id = ? AND group_member_id = ? - |] - (memStatus, currentTs, userId, groupMemberId) - --- | add new member with profile -createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember -createNewGroupMember db user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile {displayName, fullName, image, contactLink, preferences}) memCategory memStatus = - ExceptT . withLocalDisplayName db userId displayName $ \localDisplayName -> do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs) - memProfileId <- insertedRowId db - let newMember = - NewGroupMember - { memInfo, - memCategory, - memStatus, - memInvitedBy = IBUnknown, - localDisplayName, - memContactId = Nothing, - memProfileId - } - Right <$> createNewMember_ db user gInfo newMember currentTs - -createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember -createNewMember_ - db - User {userId, userContactId} - GroupInfo {groupId} - NewGroupMember - { memInfo = MemberInfo memberId memberRole memberProfile, - memCategory = memberCategory, - memStatus = memberStatus, - memInvitedBy = invitedBy, - localDisplayName, - memContactId = memberContactId, - memProfileId = memberContactProfileId - } - createdAt = do - let invitedById = fromInvitedBy userContactId invitedBy - activeConn = Nothing - DB.execute - db - [sql| - INSERT INTO group_members - (group_id, member_id, member_role, member_category, member_status, - invited_by, user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?) - |] - (groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt) - groupMemberId <- insertedRowId db - pure GroupMember {groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile = toLocalProfile memberContactProfileId memberProfile "", memberContactId, memberContactProfileId, activeConn} - -checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId) -checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} = - maybeFirstRow fromOnly $ DB.query db "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ? LIMIT 1" (userId, groupId, groupMemberId) - -deleteGroupMember :: DB.Connection -> User -> GroupMember -> IO () -deleteGroupMember db user@User {userId} m@GroupMember {groupMemberId, groupId, memberProfile = LocalProfile {profileId}} = do - deleteGroupMemberConnection db user m - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ?" (userId, groupId, groupMemberId) - DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId) - cleanupMemberProfileAndName_ db user m - when (memberIncognito m) $ deleteUnusedIncognitoProfileById_ db user profileId - -cleanupMemberProfileAndName_ :: DB.Connection -> User -> GroupMember -> IO () -cleanupMemberProfileAndName_ db User {userId} GroupMember {groupMemberId, memberContactId, memberContactProfileId, localDisplayName} = - -- check record has no memberContactId (contact_id) - it means contact has been deleted and doesn't use profile & ldn - when (isNothing memberContactId) $ do - -- check other group member records don't use profile & ldn - sameProfileMember :: (Maybe GroupMemberId) <- maybeFirstRow fromOnly $ DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND contact_profile_id = ? AND group_member_id != ? LIMIT 1" (userId, memberContactProfileId, groupMemberId) - when (isNothing sameProfileMember) $ do - DB.execute db "DELETE FROM contact_profiles WHERE user_id = ? AND contact_profile_id = ?" (userId, memberContactProfileId) - DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - -deleteGroupMemberConnection :: DB.Connection -> User -> GroupMember -> IO () -deleteGroupMemberConnection db User {userId} GroupMember {groupMemberId} = - DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId) - -updateGroupMemberRole :: DB.Connection -> User -> GroupMember -> GroupMemberRole -> IO () -updateGroupMemberRole db User {userId} GroupMember {groupMemberId} memRole = - DB.execute db "UPDATE group_members SET member_role = ? WHERE user_id = ? AND group_member_id = ?" (memRole, userId, groupMemberId) - -createIntroductions :: DB.Connection -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro] -createIntroductions db members toMember = do - let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members - if null reMembers - then pure [] - else do - currentTs <- getCurrentTime - mapM (insertIntro_ currentTs) reMembers - where - insertIntro_ :: UTCTime -> GroupMember -> IO GroupMemberIntro - insertIntro_ ts reMember = do - DB.execute - db - [sql| - INSERT INTO group_member_intros - (re_group_member_id, to_group_member_id, intro_status, created_at, updated_at) - VALUES (?,?,?,?,?) - |] - (groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, ts, ts) - introId <- insertedRowId db - pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing} - -updateIntroStatus :: DB.Connection -> Int64 -> GroupMemberIntroStatus -> IO () -updateIntroStatus db introId introStatus = do - currentTs <- getCurrentTime - DB.executeNamed - db - [sql| - UPDATE group_member_intros - SET intro_status = :intro_status, updated_at = :updated_at - WHERE group_member_intro_id = :intro_id - |] - [":intro_status" := introStatus, ":updated_at" := currentTs, ":intro_id" := introId] - -saveIntroInvitation :: DB.Connection -> GroupMember -> GroupMember -> IntroInvitation -> ExceptT StoreError IO GroupMemberIntro -saveIntroInvitation db reMember toMember introInv = do - intro <- getIntroduction_ db reMember toMember - liftIO $ do - currentTs <- getCurrentTime - DB.executeNamed - db - [sql| - UPDATE group_member_intros - SET intro_status = :intro_status, - group_queue_info = :group_queue_info, - direct_queue_info = :direct_queue_info, - updated_at = :updated_at - WHERE group_member_intro_id = :intro_id - |] - [ ":intro_status" := GMIntroInvReceived, - ":group_queue_info" := groupConnReq (introInv :: IntroInvitation), - ":direct_queue_info" := directConnReq introInv, - ":updated_at" := currentTs, - ":intro_id" := introId intro - ] - pure intro {introInvitation = Just introInv, introStatus = GMIntroInvReceived} - -saveMemberInvitation :: DB.Connection -> GroupMember -> IntroInvitation -> IO () -saveMemberInvitation db GroupMember {groupMemberId} IntroInvitation {groupConnReq, directConnReq} = do - currentTs <- getCurrentTime - DB.executeNamed - db - [sql| - UPDATE group_members - SET member_status = :member_status, - group_queue_info = :group_queue_info, - direct_queue_info = :direct_queue_info, - updated_at = :updated_at - WHERE group_member_id = :group_member_id - |] - [ ":member_status" := GSMemIntroInvited, - ":group_queue_info" := groupConnReq, - ":direct_queue_info" := directConnReq, - ":updated_at" := currentTs, - ":group_member_id" := groupMemberId - ] - -getIntroduction_ :: DB.Connection -> GroupMember -> GroupMember -> ExceptT StoreError IO GroupMemberIntro -getIntroduction_ db reMember toMember = ExceptT $ do - toIntro - <$> DB.query - db - [sql| - SELECT group_member_intro_id, group_queue_info, direct_queue_info, intro_status - FROM group_member_intros - WHERE re_group_member_id = ? AND to_group_member_id = ? - |] - (groupMemberId' reMember, groupMemberId' toMember) - where - toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro - toIntro [(introId, groupConnReq, directConnReq, introStatus)] = - let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq - in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation} - toIntro _ = Left SEIntroNotFound - -createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember -createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do - let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn - currentTs <- liftIO getCurrentTime - Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId memberContactId Nothing customUserProfileId cLevel currentTs - liftIO $ setCommandConnId db user directCmdId directConnId - (localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing - liftIO $ do - let newMember = - NewGroupMember - { memInfo, - memCategory = GCPreMember, - memStatus = GSMemIntroduced, - memInvitedBy = IBUnknown, - localDisplayName, - memContactId = Just contactId, - memProfileId - } - member <- createNewMember_ db user gInfo newMember currentTs - conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId memberContactId cLevel currentTs - liftIO $ setCommandConnId db user groupCmdId groupConnId - pure (member :: GroupMember) {activeConn = Just conn} - -createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> IO () -createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do - let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn - currentTs <- getCurrentTime - Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel currentTs - setCommandConnId db user groupCmdId groupConnId - Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId viaContactId Nothing customUserProfileId cLevel currentTs - setCommandConnId db user directCmdId directConnId - contactId <- createMemberContact_ directConnId currentTs - updateMember_ contactId currentTs - where - createMemberContact_ :: Int64 -> UTCTime -> IO Int64 - createMemberContact_ connId ts = do - DB.execute - db - [sql| - INSERT INTO contacts (contact_profile_id, via_group, local_display_name, user_id, created_at, updated_at) - SELECT contact_profile_id, group_id, ?, ?, ?, ? - FROM group_members - WHERE group_member_id = ? - |] - (localDisplayName, userId, ts, ts, groupMemberId) - contactId <- insertedRowId db - DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, ts, connId) - pure contactId - updateMember_ :: Int64 -> UTCTime -> IO () - updateMember_ contactId ts = - DB.executeNamed - db - [sql| - UPDATE group_members - SET contact_id = :contact_id, updated_at = :updated_at - WHERE group_member_id = :group_member_id - |] - [":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId] - -createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection -createMemberConnection_ db userId groupMemberId agentConnId viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId viaContact Nothing Nothing - -getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember)) -getViaGroupMember db User {userId, userContactId} Contact {contactId} = - maybeFirstRow toGroupAndMember $ - DB.query - db - [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - -- GroupInfo {membership} - mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, - -- GroupInfo {membership = GroupMember {memberProfile}} - pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, - -- via GroupMember - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM group_members m - JOIN contacts ct ON ct.contact_id = m.contact_id - JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group - JOIN group_profiles gp USING (group_profile_id) - JOIN group_members mu ON g.group_id = mu.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - LEFT JOIN connections c ON c.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.group_member_id = m.group_member_id - ) - WHERE ct.user_id = ? AND ct.contact_id = ? AND mu.contact_id = ? AND ct.deleted = 0 - |] - (userId, contactId, userContactId) - where - toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) - toGroupAndMember (groupInfoRow :. memberRow :. connRow) = - let groupInfo = toGroupInfo userContactId groupInfoRow - member = toGroupMember userContactId memberRow - in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) - -getViaGroupContact :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact) -getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = - maybeFirstRow toContact' $ - DB.query - db - [sql| - SELECT - ct.contact_id, ct.contact_profile_id, ct.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, ct.via_group, ct.contact_used, ct.enable_ntfs, - p.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM contacts ct - JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id - JOIN connections c ON c.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.contact_id = ct.contact_id - ) - JOIN groups g ON g.group_id = ct.via_group - JOIN group_members m ON m.group_id = g.group_id AND m.contact_id = ct.contact_id - WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0 - |] - (userId, groupMemberId) - where - toContact' :: ((ContactId, ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)) :. ConnectionRow -> Contact - toContact' (((contactId, profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = - let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} - activeConn = toConnection connRow - mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} - -createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> IO FileTransferMeta -createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize = do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)" - ((userId, contactId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs)) - fileId <- insertedRowId db - forM_ acId_ $ \acId -> do - Connection {connId} <- createSndFileConnection_ db userId fileId acId - let fileStatus = FSNew - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (fileId, fileStatus, fileInline, connId, currentTs, currentTs) - pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} - -createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> IO () -createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do - currentTs <- getCurrentTime - Connection {connId} <- createSndFileConnection_ db userId fileId acId - setCommandConnId db user cmdId connId - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (fileId, FSAccepted, connId, currentTs, currentTs) - -createSndGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO FileTransferMeta -createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize, fileInline} chunkSize = do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)" - ((userId, groupId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs)) - fileId <- insertedRowId db - pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} - -createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> IO () -createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} = do - currentTs <- getCurrentTime - Connection {connId} <- createSndFileConnection_ db userId fileId acId - setCommandConnId db user cmdId connId - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs) - -createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO SndFileTransfer -createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do - currentTs <- getCurrentTime - let fileStatus = FSConnected - fileInline' = Just $ fromMaybe IFMOffer fileInline - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (fileId, fileStatus, fileInline', connId, currentTs, currentTs) - pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Nothing, fileStatus, fileDescrId = Nothing, fileInline = fileInline'} - -createSndGroupInlineFT :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> IO SndFileTransfer -createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Connection {connId, agentConnId} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do - currentTs <- getCurrentTime - let fileStatus = FSConnected - fileInline' = Just $ fromMaybe IFMOffer fileInline - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (fileId, fileStatus, fileInline', connId, groupMemberId, currentTs, currentTs) - pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Just groupMemberId, fileStatus, fileDescrId = Nothing, fileInline = fileInline'} - -updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> IO () -updateSndDirectFTDelivery db Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = - DB.execute - db - "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" - (msgDeliveryId, connId, fileId) - -updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO () -updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId = - DB.execute - db - "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE group_member_id = ? AND connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" - (msgDeliveryId, groupMemberId, connId, fileId) - -getSndFTViaMsgDelivery :: DB.Connection -> User -> Connection -> AgentMsgId -> IO (Maybe SndFileTransfer) -getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMsgId = do - (sndFileTransfer_ <=< listToMaybe) - <$> DB.query - db - [sql| - SELECT s.file_id, s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.group_member_id, c.local_display_name, m.local_display_name - FROM msg_deliveries d - JOIN snd_files s ON s.connection_id = d.connection_id AND s.last_inline_msg_delivery_id = d.msg_delivery_id - JOIN files f ON f.file_id = s.file_id - LEFT JOIN contacts c USING (contact_id) - LEFT JOIN group_members m USING (group_member_id) - WHERE d.connection_id = ? AND d.agent_msg_id = ? AND f.user_id = ? - AND (s.file_descr_id IS NOT NULL OR s.file_inline IS NOT NULL) - |] - (connId, agentMsgId, userId) - where - sndFileTransfer_ :: (Int64, FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Maybe SndFileTransfer - sndFileTransfer_ (fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, contactName_, memberName_) = - (\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId}) - <$> (contactName_ <|> memberName_) - -createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta -createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do - currentTs <- getCurrentTime - let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False} - DB.execute - db - "INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)" - (contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs)) - fileId <- insertedRowId db - pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False} - -createSndFTDescrXFTP :: DB.Connection -> User -> Maybe GroupMember -> Connection -> FileTransferMeta -> FileDescr -> IO () -createSndFTDescrXFTP db User {userId} m Connection {connId} FileTransferMeta {fileId} FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do - currentTs <- getCurrentTime - let fileStatus = FSNew - DB.execute - db - "INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs) - fileDescrId <- insertedRowId db - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, file_descr_id, group_member_id, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (fileId, fileStatus, fileDescrId, groupMemberId' <$> m, connId, currentTs, currentTs) - -setSndFTPrivateSndDescr :: DB.Connection -> User -> FileTransferId -> Text -> IO () -setSndFTPrivateSndDescr db User {userId} fileId sfdText = do - currentTs <- getCurrentTime - DB.execute - db - "UPDATE files SET private_snd_file_descr = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" - (sfdText, currentTs, userId, fileId) - -updateSndFTDescrXFTP :: DB.Connection -> User -> SndFileTransfer -> Text -> IO () -updateSndFTDescrXFTP db user@User {userId} sft@SndFileTransfer {fileId, fileDescrId} rfdText = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - UPDATE xftp_file_descriptions - SET file_descr_text = ?, file_descr_part_no = ?, file_descr_complete = ?, updated_at = ? - WHERE user_id = ? AND file_descr_id = ? - |] - (rfdText, 1 :: Int, True, currentTs, userId, fileDescrId) - updateCIFileStatus db user fileId $ CIFSSndTransfer 1 1 - updateSndFileStatus db sft FSConnected - -createExtraSndFTDescrs :: DB.Connection -> User -> FileTransferId -> [Text] -> IO () -createExtraSndFTDescrs db User {userId} fileId rfdTexts = do - currentTs <- getCurrentTime - forM_ rfdTexts $ \rfdText -> - DB.execute - db - "INSERT INTO extra_xftp_file_descriptions (file_id, user_id, file_descr_text, created_at, updated_at) VALUES (?,?,?,?,?)" - (fileId, userId, rfdText, currentTs, currentTs) - -updateSndFTDeliveryXFTP :: DB.Connection -> SndFileTransfer -> Int64 -> IO () -updateSndFTDeliveryXFTP db SndFileTransfer {connId, fileId, fileDescrId} msgDeliveryId = - DB.execute - db - "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_descr_id = ?" - (msgDeliveryId, connId, fileId, fileDescrId) - -setSndFTAgentDeleted :: DB.Connection -> User -> FileTransferId -> IO () -setSndFTAgentDeleted db User {userId} fileId = do - currentTs <- getCurrentTime - DB.execute - db - "UPDATE files SET agent_snd_file_deleted = 1, updated_at = ? WHERE user_id = ? AND file_id = ?" - (currentTs, userId, fileId) - -getXFTPSndFileDBId :: DB.Connection -> User -> AgentSndFileId -> ExceptT StoreError IO FileTransferId -getXFTPSndFileDBId db User {userId} aSndFileId = - ExceptT . firstRow fromOnly (SESndFileNotFoundXFTP aSndFileId) $ - DB.query db "SELECT file_id FROM files WHERE user_id = ? AND agent_snd_file_id = ?" (userId, aSndFileId) - -getXFTPRcvFileDBId :: DB.Connection -> AgentRcvFileId -> ExceptT StoreError IO FileTransferId -getXFTPRcvFileDBId db aRcvFileId = - ExceptT . firstRow fromOnly (SERcvFileNotFoundXFTP aRcvFileId) $ - DB.query db "SELECT file_id FROM rcv_files WHERE agent_rcv_file_id = ?" (Only aRcvFileId) - -updateFileCancelled :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () -updateFileCancelled db User {userId} fileId ciFileStatus = do - currentTs <- getCurrentTime - DB.execute db "UPDATE files SET cancelled = 1, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) - -updateCIFileStatus :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () -updateCIFileStatus db User {userId} fileId ciFileStatus = do - currentTs <- getCurrentTime - DB.execute db "UPDATE files SET ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) - -getSharedMsgIdByFileId :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO SharedMsgId -getSharedMsgIdByFileId db userId fileId = - ExceptT . firstRow fromOnly (SESharedMsgIdNotFoundByFileId fileId) $ - DB.query - db - [sql| - SELECT i.shared_msg_id - FROM chat_items i - JOIN files f ON f.chat_item_id = i.chat_item_id - WHERE f.user_id = ? AND f.file_id = ? - |] - (userId, fileId) - -getFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 -getFileIdBySharedMsgId db userId contactId sharedMsgId = - ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ - DB.query - db - [sql| - SELECT f.file_id - FROM files f - JOIN chat_items i ON i.chat_item_id = f.chat_item_id - WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ? - |] - (userId, contactId, sharedMsgId) - -getGroupFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 -getGroupFileIdBySharedMsgId db userId groupId sharedMsgId = - ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ - DB.query - db - [sql| - SELECT f.file_id - FROM files f - JOIN chat_items i ON i.chat_item_id = f.chat_item_id - WHERE i.user_id = ? AND i.group_id = ? AND i.shared_msg_id = ? - |] - (userId, groupId, sharedMsgId) - -getDirectFileIdBySharedMsgId :: DB.Connection -> User -> Contact -> SharedMsgId -> ExceptT StoreError IO Int64 -getDirectFileIdBySharedMsgId db User {userId} Contact {contactId} sharedMsgId = - ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ - DB.query - db - [sql| - SELECT f.file_id - FROM files f - JOIN chat_items i ON i.chat_item_id = f.chat_item_id - WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ? - |] - (userId, contactId, sharedMsgId) - -getChatRefByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO ChatRef -getChatRefByFileId db User {userId} fileId = - liftIO getChatRef >>= \case - [(Just contactId, Nothing)] -> pure $ ChatRef CTDirect contactId - [(Nothing, Just groupId)] -> pure $ ChatRef CTGroup groupId - _ -> throwError $ SEInternalError "could not retrieve chat ref by file id" - where - getChatRef = - DB.query - db - [sql| - SELECT contact_id, group_id - FROM files - WHERE user_id = ? AND file_id = ? - LIMIT 1 - |] - (userId, fileId) - -createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection -createSndFileConnection_ db userId fileId agentConnId = do - currentTs <- getCurrentTime - createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing Nothing Nothing 0 currentTs - -updateSndFileStatus :: DB.Connection -> SndFileTransfer -> FileStatus -> IO () -updateSndFileStatus db SndFileTransfer {fileId, connId} status = do - currentTs <- getCurrentTime - DB.execute db "UPDATE snd_files SET file_status = ?, updated_at = ? WHERE file_id = ? AND connection_id = ?" (status, currentTs, fileId, connId) - -createSndFileChunk :: DB.Connection -> SndFileTransfer -> IO (Maybe Integer) -createSndFileChunk db SndFileTransfer {fileId, connId, fileSize, chunkSize} = do - chunkNo <- getLastChunkNo - insertChunk chunkNo - pure chunkNo - where - getLastChunkNo = do - ns <- DB.query db "SELECT chunk_number FROM snd_file_chunks WHERE file_id = ? AND connection_id = ? AND chunk_sent = 1 ORDER BY chunk_number DESC LIMIT 1" (fileId, connId) - pure $ case map fromOnly ns of - [] -> Just 1 - n : _ -> if n * chunkSize >= fileSize then Nothing else Just (n + 1) - insertChunk chunkNo_ = forM_ chunkNo_ $ \chunkNo -> do - currentTs <- getCurrentTime - DB.execute - db - "INSERT OR REPLACE INTO snd_file_chunks (file_id, connection_id, chunk_number, created_at, updated_at) VALUES (?,?,?,?,?)" - (fileId, connId, chunkNo, currentTs, currentTs) - -updateSndFileChunkMsg :: DB.Connection -> SndFileTransfer -> Integer -> AgentMsgId -> IO () -updateSndFileChunkMsg db SndFileTransfer {fileId, connId} chunkNo msgId = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - UPDATE snd_file_chunks - SET chunk_agent_msg_id = ?, updated_at = ? - WHERE file_id = ? AND connection_id = ? AND chunk_number = ? - |] - (msgId, currentTs, fileId, connId, chunkNo) - -updateSndFileChunkSent :: DB.Connection -> SndFileTransfer -> AgentMsgId -> IO () -updateSndFileChunkSent db SndFileTransfer {fileId, connId} msgId = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - UPDATE snd_file_chunks - SET chunk_sent = 1, updated_at = ? - WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id = ? - |] - (currentTs, fileId, connId, msgId) - -deleteSndFileChunks :: DB.Connection -> SndFileTransfer -> IO () -deleteSndFileChunks db SndFileTransfer {fileId, connId} = - DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId) - -createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer -createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do - currentTs <- liftIO getCurrentTime - rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr - let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_ - xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ - fileProtocol = if isJust rfd_ then FPXFTP else FPSMP - fileId <- liftIO $ do - DB.execute - db - "INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)" - (userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs) - insertedRowId db - liftIO $ - DB.execute - db - "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs) - pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing} - -createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer -createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do - currentTs <- liftIO getCurrentTime - rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr - let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_ - xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ - fileProtocol = if isJust rfd_ then FPXFTP else FPSMP - fileId <- liftIO $ do - DB.execute - db - "INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)" - (userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs) - insertedRowId db - liftIO $ - DB.execute - db - "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" - (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs) - pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId} - -createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr -createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do - when (fileDescrPartNo /= 0) $ throwError SERcvFileInvalidDescrPart - fileDescrId <- liftIO $ do - DB.execute - db - "INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs) - insertedRowId db - pure RcvFileDescr {fileDescrId, fileDescrPartNo, fileDescrText, fileDescrComplete} - -appendRcvFD :: DB.Connection -> UserId -> FileTransferId -> FileDescr -> ExceptT StoreError IO RcvFileDescr -appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do - currentTs <- liftIO getCurrentTime - liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case - Nothing -> do - rfd@RcvFileDescr {fileDescrId} <- createRcvFD_ db userId currentTs fd - liftIO $ - DB.execute - db - "UPDATE rcv_files SET file_descr_id = ?, updated_at = ? WHERE file_id = ?" - (fileDescrId, currentTs, fileId) - pure rfd - Just - RcvFileDescr - { fileDescrId, - fileDescrText = rfdText, - fileDescrPartNo = rfdPNo, - fileDescrComplete = rfdComplete - } -> do - when (fileDescrPartNo /= rfdPNo + 1 || rfdComplete) $ throwError SERcvFileInvalidDescrPart - let fileDescrText' = rfdText <> fileDescrText - liftIO $ - DB.execute - db - [sql| - UPDATE xftp_file_descriptions - SET file_descr_text = ?, file_descr_part_no = ?, file_descr_complete = ? - WHERE file_descr_id = ? - |] - (fileDescrText', fileDescrPartNo, fileDescrComplete, fileDescrId) - pure RcvFileDescr {fileDescrId, fileDescrText = fileDescrText', fileDescrPartNo, fileDescrComplete} - -getRcvFileDescrByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr -getRcvFileDescrByFileId db fileId = do - liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case - Nothing -> throwError $ SERcvFileDescrNotFound fileId - Just rfd -> pure rfd - -getRcvFileDescrByFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr) -getRcvFileDescrByFileId_ db fileId = - maybeFirstRow toRcvFileDescr $ - DB.query - db - [sql| - SELECT d.file_descr_id, d.file_descr_text, d.file_descr_part_no, d.file_descr_complete - FROM xftp_file_descriptions d - JOIN rcv_files f ON f.file_descr_id = d.file_descr_id - WHERE f.file_id = ? - LIMIT 1 - |] - (Only fileId) - where - toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr - toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) = - RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete} - -updateRcvFileAgentId :: DB.Connection -> FileTransferId -> Maybe AgentRcvFileId -> IO () -updateRcvFileAgentId db fileId aFileId = do - currentTs <- getCurrentTime - DB.execute db "UPDATE rcv_files SET agent_rcv_file_id = ?, updated_at = ? WHERE file_id = ?" (aFileId, currentTs, fileId) - -getRcvFileTransferById :: DB.Connection -> FileTransferId -> ExceptT StoreError IO (User, RcvFileTransfer) -getRcvFileTransferById db fileId = do - user <- getUserByFileId db fileId - (user,) <$> getRcvFileTransfer db user fileId - -getRcvFileTransfer :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO RcvFileTransfer -getRcvFileTransfer db User {userId} fileId = do - rftRow <- - ExceptT . firstRow id (SERcvFileNotFound fileId) $ - DB.query - db - [sql| - SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name, - f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name, - f.file_path, r.file_inline, r.rcv_file_inline, r.agent_rcv_file_id, r.agent_rcv_file_deleted, c.connection_id, c.agent_conn_id - FROM rcv_files r - JOIN files f USING (file_id) - LEFT JOIN connections c ON r.file_id = c.rcv_file_id - LEFT JOIN contacts cs USING (contact_id) - LEFT JOIN group_members m USING (group_member_id) - WHERE f.user_id = ? AND f.file_id = ? - |] - (userId, fileId) - rfd_ <- liftIO $ getRcvFileDescrByFileId_ db fileId - rcvFileTransfer rfd_ rftRow - where - rcvFileTransfer :: - Maybe RcvFileDescr -> - (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, Bool) :. (Maybe Int64, Maybe AgentConnId) -> - ExceptT StoreError IO RcvFileTransfer - rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileInline, rcvFileInline, agentRcvFileId, agentRcvFileDeleted) :. (connId_, agentConnId_)) = - case contactName_ <|> memberName_ of - Nothing -> throwError $ SERcvFileInvalid fileId - Just name -> do - case fileStatus' of - FSNew -> pure $ ft name RFSNew - FSAccepted -> ft name . RFSAccepted <$> rfi - FSConnected -> ft name . RFSConnected <$> rfi - FSComplete -> ft name . RFSComplete <$> rfi - FSCancelled -> ft name . RFSCancelled <$> rfi_ - where - ft senderDisplayName fileStatus = - let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing} - xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted}) <$> rfd_ - in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId} - rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_ - rfi_ = case (filePath_, connId_, agentConnId_) of - (Just filePath, connId, agentConnId) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId} - _ -> pure Nothing - cancelled = fromMaybe False cancelled_ - -acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem -acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath = ExceptT $ do - currentTs <- getCurrentTime - acceptRcvFT_ db user fileId filePath Nothing currentTs - DB.execute - db - "INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs) - connId <- insertedRowId db - setCommandConnId db user cmdId connId - runExceptT $ getChatItemByFileId db user fileId - -getContactByFileId :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact -getContactByFileId db user@User {userId} fileId = do - cId <- getContactIdByFileId - getContact db user cId - where - getContactIdByFileId = - ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $ - DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, fileId) - -acceptRcvInlineFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem -acceptRcvInlineFT db user fileId filePath = do - liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime - getChatItemByFileId db user fileId - -startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO () -startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline = - acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime - -xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem -xftpAcceptRcvFT db user fileId filePath = do - liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime - getChatItemByFileId db user fileId - -acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO () -acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do - DB.execute - db - "UPDATE files SET file_path = ?, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" - (filePath, CIFSRcvAccepted, currentTs, userId, fileId) - DB.execute - db - "UPDATE rcv_files SET rcv_file_inline = ?, file_status = ?, updated_at = ? WHERE file_id = ?" - (rcvFileInline, FSAccepted, currentTs, fileId) - -setRcvFileToReceive :: DB.Connection -> FileTransferId -> IO () -setRcvFileToReceive db fileId = do - currentTs <- getCurrentTime - DB.execute - db - "UPDATE rcv_files SET to_receive = 1, updated_at = ? WHERE file_id = ?" - (currentTs, fileId) - -getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer] -getRcvFilesToReceive db user@User {userId} = do - cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime - fileIds :: [Int64] <- - map fromOnly - <$> DB.query - db - [sql| - SELECT r.file_id - FROM rcv_files r - JOIN files f ON f.file_id = r.file_id - WHERE f.user_id = ? AND r.file_status = ? - AND r.to_receive = 1 AND r.created_at > ? - |] - (userId, FSNew, cutoffTs) - rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds - -setRcvFTAgentDeleted :: DB.Connection -> FileTransferId -> IO () -setRcvFTAgentDeleted db fileId = do - currentTs <- getCurrentTime - DB.execute - db - "UPDATE rcv_files SET agent_rcv_file_deleted = 1, updated_at = ? WHERE file_id = ?" - (currentTs, fileId) - -updateRcvFileStatus :: DB.Connection -> FileTransferId -> FileStatus -> IO () -updateRcvFileStatus db fileId status = do - currentTs <- getCurrentTime - DB.execute db "UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?" (status, currentTs, fileId) - -createRcvFileChunk :: DB.Connection -> RcvFileTransfer -> Integer -> AgentMsgId -> IO RcvChunkStatus -createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, chunkSize} chunkNo msgId = do - status <- getLastChunkNo - unless (status == RcvChunkError) $ do - currentTs <- getCurrentTime - DB.execute - db - "INSERT OR REPLACE INTO rcv_file_chunks (file_id, chunk_number, chunk_agent_msg_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (fileId, chunkNo, msgId, currentTs, currentTs) - pure status - where - getLastChunkNo = do - ns <- DB.query db "SELECT chunk_number FROM rcv_file_chunks WHERE file_id = ? ORDER BY chunk_number DESC LIMIT 1" (Only fileId) - pure $ case map fromOnly ns of - [] - | chunkNo == 1 -> - if chunkSize >= fileSize - then RcvChunkFinal - else RcvChunkOk - | otherwise -> RcvChunkError - n : _ - | chunkNo == n -> RcvChunkDuplicate - | chunkNo == n + 1 -> - let prevSize = n * chunkSize - in if prevSize >= fileSize - then RcvChunkError - else - if prevSize + chunkSize >= fileSize - then RcvChunkFinal - else RcvChunkOk - | otherwise -> RcvChunkError - -updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO () -updatedRcvFileChunkStored db RcvFileTransfer {fileId} chunkNo = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - UPDATE rcv_file_chunks - SET chunk_stored = 1, updated_at = ? - WHERE file_id = ? AND chunk_number = ? - |] - (currentTs, fileId, chunkNo) - -deleteRcvFileChunks :: DB.Connection -> RcvFileTransfer -> IO () -deleteRcvFileChunks db RcvFileTransfer {fileId} = - DB.execute db "DELETE FROM rcv_file_chunks WHERE file_id = ?" (Only fileId) - -updateFileTransferChatItemId :: DB.Connection -> FileTransferId -> ChatItemId -> UTCTime -> IO () -updateFileTransferChatItemId db fileId ciId currentTs = - DB.execute db "UPDATE files SET chat_item_id = ?, updated_at = ? WHERE file_id = ?" (ciId, currentTs, fileId) - -getFileTransferProgress :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransfer, [Integer]) -getFileTransferProgress db user fileId = do - ft <- getFileTransfer db user fileId - liftIO $ - (ft,) . map fromOnly <$> case ft of - FTSnd _ [] -> pure [Only 0] - FTSnd _ _ -> DB.query db "SELECT COUNT(*) FROM snd_file_chunks WHERE file_id = ? and chunk_sent = 1 GROUP BY connection_id" (Only fileId) - FTRcv _ -> DB.query db "SELECT COUNT(*) FROM rcv_file_chunks WHERE file_id = ? AND chunk_stored = 1" (Only fileId) - -getFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransfer -getFileTransfer db user@User {userId} fileId = - fileTransfer =<< liftIO getFileTransferRow - where - fileTransfer :: [(Maybe Int64, Maybe Int64)] -> ExceptT StoreError IO FileTransfer - fileTransfer [(Nothing, Just _)] = FTRcv <$> getRcvFileTransfer db user fileId - fileTransfer _ = do - (ftm, fts) <- getSndFileTransfer db user fileId - pure $ FTSnd {fileTransferMeta = ftm, sndFileTransfers = fts} - getFileTransferRow :: IO [(Maybe Int64, Maybe Int64)] - getFileTransferRow = - DB.query - db - [sql| - SELECT s.file_id, r.file_id - FROM files f - LEFT JOIN snd_files s ON s.file_id = f.file_id - LEFT JOIN rcv_files r ON r.file_id = f.file_id - WHERE user_id = ? AND f.file_id = ? - |] - (userId, fileId) - -getSndFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer]) -getSndFileTransfer db user fileId = do - fileTransferMeta <- getFileTransferMeta db user fileId - sndFileTransfers <- getSndFileTransfers db user fileId - pure (fileTransferMeta, sndFileTransfers) - -getSndFileTransfers :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO [SndFileTransfer] -getSndFileTransfers db User {userId} fileId = ExceptT $ getSndFileTransfers_ db userId fileId - -getSndFileTransfers_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError [SndFileTransfer]) -getSndFileTransfers_ db userId fileId = - mapM sndFileTransfer - <$> DB.query - db - [sql| - SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.connection_id, c.agent_conn_id, s.group_member_id, - cs.local_display_name, m.local_display_name - FROM snd_files s - JOIN files f USING (file_id) - JOIN connections c USING (connection_id) - LEFT JOIN contacts cs USING (contact_id) - LEFT JOIN group_members m USING (group_member_id) - WHERE f.user_id = ? AND f.file_id = ? - |] - (userId, fileId) - where - sndFileTransfer :: (FileStatus, String, Integer, Integer, FilePath) :. (Maybe Int64, Maybe InlineFileMode, Int64, AgentConnId, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer - sndFileTransfer ((fileStatus, fileName, fileSize, chunkSize, filePath) :. (fileDescrId, fileInline, connId, agentConnId, groupMemberId, contactName_, memberName_)) = - case contactName_ <|> memberName_ of - Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId, groupMemberId} - Nothing -> Left $ SESndFileInvalid fileId - -getFileTransferMeta :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta -getFileTransferMeta db User {userId} fileId = - ExceptT . firstRow fileTransferMeta (SEFileNotFound fileId) $ - DB.query - db - [sql| - SELECT file_name, file_size, chunk_size, file_path, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled - FROM files - WHERE user_id = ? AND file_id = ? - |] - (userId, fileId) - where - fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta - fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) = - let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted}) <$> aSndFileId_ - in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_} - -getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo] -getContactFileInfo db User {userId} Contact {contactId} = - map toFileInfo - <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ?") (userId, contactId) - -deleteContactCIs :: DB.Connection -> User -> Contact -> IO () -deleteContactCIs db user@User {userId} ct@Contact {contactId} = do - connIds <- getContactConnIds_ db user ct - forM_ connIds $ \connId -> - DB.execute db "DELETE FROM messages WHERE connection_id = ?" (Only connId) - DB.execute db "DELETE FROM chat_item_reactions WHERE contact_id = ?" (Only contactId) - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) - -getContactConnIds_ :: DB.Connection -> User -> Contact -> IO [Int64] -getContactConnIds_ db User {userId} Contact {contactId} = - map fromOnly - <$> DB.query db "SELECT connection_id FROM connections WHERE user_id = ? AND contact_id = ?" (userId, contactId) - -getGroupFileInfo :: DB.Connection -> User -> GroupInfo -> IO [CIFileInfo] -getGroupFileInfo db User {userId} GroupInfo {groupId} = - map toFileInfo - <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ?") (userId, groupId) - -deleteGroupCIs :: DB.Connection -> User -> GroupInfo -> IO () -deleteGroupCIs db User {userId} GroupInfo {groupId} = do - DB.execute db "DELETE FROM messages WHERE group_id = ?" (Only groupId) - DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ?" (Only groupId) - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId) - -createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage e) -> ExceptT StoreError IO SndMessage -createNewSndMessage db gVar connOrGroupId mkMessage = - createWithRandomId gVar $ \sharedMsgId -> do - let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId - createdAt <- getCurrentTime - DB.execute - db - [sql| - INSERT INTO messages ( - msg_sent, chat_msg_event, msg_body, connection_id, group_id, - shared_msg_id, shared_msg_id_user, created_at, updated_at - ) VALUES (?,?,?,?,?,?,?,?,?) - |] - (MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt) - msgId <- insertedRowId db - pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody} - where - (connId_, groupId_) = case connOrGroupId of - ConnectionId connId -> (Just connId, Nothing) - GroupId groupId -> (Nothing, Just groupId) - -createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64 -createSndMsgDelivery db sndMsgDelivery messageId = do - currentTs <- getCurrentTime - msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs - createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs - pure msgDeliveryId - -createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage -createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} = do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO messages (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id) VALUES (?,?,?,?,?,?,?,?)" - (MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_) - msgId <- insertedRowId db - DB.execute - db - "INSERT INTO msg_deliveries (message_id, connection_id, agent_msg_id, agent_msg_meta, agent_ack_cmd_id, chat_ts, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs) - msgDeliveryId <- insertedRowId db - createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs - pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody} - where - (connId_, groupId_) = case connOrGroupId of - ConnectionId connId' -> (Just connId', Nothing) - GroupId groupId -> (Nothing, Just groupId) - -createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO () -createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do - msgDeliveryId <- getMsgDeliveryId_ db connId agentMsgId - liftIO $ do - currentTs <- getCurrentTime - createMsgDeliveryEvent_ db msgDeliveryId sndMsgDeliveryStatus currentTs - -createRcvMsgDeliveryEvent :: DB.Connection -> Int64 -> CommandId -> MsgDeliveryStatus 'MDRcv -> IO () -createRcvMsgDeliveryEvent db connId cmdId rcvMsgDeliveryStatus = do - msgDeliveryId <- getMsgDeliveryIdByCmdId_ db connId cmdId - forM_ msgDeliveryId $ \mdId -> do - currentTs <- getCurrentTime - createMsgDeliveryEvent_ db mdId rcvMsgDeliveryStatus currentTs - -createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> UTCTime -> IO Int64 -createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId createdAt = do - DB.execute - db - [sql| - INSERT INTO msg_deliveries - (message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts, created_at, updated_at) - VALUES (?,?,?,NULL,?,?,?) - |] - (messageId, connId, agentMsgId, createdAt, createdAt, createdAt) - insertedRowId db - -createMsgDeliveryEvent_ :: DB.Connection -> Int64 -> MsgDeliveryStatus d -> UTCTime -> IO () -createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do - DB.execute - db - [sql| - INSERT INTO msg_delivery_events - (msg_delivery_id, delivery_status, created_at, updated_at) - VALUES (?,?,?,?) - |] - (msgDeliveryId, msgDeliveryStatus, createdAt, createdAt) - -getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> ExceptT StoreError IO Int64 -getMsgDeliveryId_ db connId agentMsgId = - ExceptT . firstRow fromOnly (SENoMsgDelivery connId agentMsgId) $ - DB.query - db - [sql| - SELECT msg_delivery_id - FROM msg_deliveries m - WHERE m.connection_id = ? AND m.agent_msg_id = ? - LIMIT 1 - |] - (connId, agentMsgId) - -getMsgDeliveryIdByCmdId_ :: DB.Connection -> Int64 -> CommandId -> IO (Maybe AgentMsgId) -getMsgDeliveryIdByCmdId_ db connId cmdId = - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT msg_delivery_id - FROM msg_deliveries - WHERE connection_id = ? AND agent_ack_cmd_id = ? - LIMIT 1 - |] - (connId, cmdId) - -createPendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> Maybe Int64 -> IO () -createPendingGroupMessage db groupMemberId messageId introId_ = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - INSERT INTO pending_group_messages - (group_member_id, message_id, group_member_intro_id, created_at, updated_at) VALUES (?,?,?,?,?) - |] - (groupMemberId, messageId, introId_, currentTs, currentTs) - -getPendingGroupMessages :: DB.Connection -> Int64 -> IO [PendingGroupMessage] -getPendingGroupMessages db groupMemberId = - map pendingGroupMessage - <$> DB.query - db - [sql| - SELECT pgm.message_id, m.chat_msg_event, m.msg_body, pgm.group_member_intro_id - FROM pending_group_messages pgm - JOIN messages m USING (message_id) - WHERE pgm.group_member_id = ? - ORDER BY pgm.message_id ASC - |] - (Only groupMemberId) - where - pendingGroupMessage (msgId, cmEventTag, msgBody, introId_) = - PendingGroupMessage {msgId, cmEventTag, msgBody, introId_} - -deletePendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> IO () -deletePendingGroupMessage db groupMemberId messageId = - DB.execute db "DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ?" (groupMemberId, messageId) - -deleteOldMessages :: DB.Connection -> UTCTime -> IO () -deleteOldMessages db createdAtCutoff = do - DB.execute db "DELETE FROM messages WHERE created_at <= ?" (Only createdAtCutoff) - -type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId) - -updateChatTs :: DB.Connection -> User -> ChatDirection c d -> UTCTime -> IO () -updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirection of - DirectChat Contact {contactId} -> - DB.execute - db - "UPDATE contacts SET chat_ts = ? WHERE user_id = ? AND contact_id = ?" - (chatTs, userId, contactId) - GroupChat GroupInfo {groupId} -> - DB.execute - db - "UPDATE groups SET chat_ts = ? WHERE user_id = ? AND group_id = ?" - (chatTs, userId, groupId) - _ -> pure () - -createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId -createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem timed live createdAt = - createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow timed live createdAt createdAt - where - createdByMsgId = if msgId == 0 then Nothing else Just msgId - quoteRow :: NewQuoteRow - quoteRow = case quotedItem of - Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) - Just CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content} -> - uncurry (quotedSharedMsgId,Just sentAt,Just content,,) $ case chatDir of - CIQDirectSnd -> (Just True, Nothing) - CIQDirectRcv -> (Just False, Nothing) - CIQGroupSnd -> (Just True, Nothing) - CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) - CIQGroupRcv Nothing -> (Just False, Nothing) - -createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c)) -createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent timed live itemTs createdAt = do - ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs createdAt - quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg - pure (ciId, quotedItem) - where - quotedMsg = cmToQuotedMsg chatMsgEvent - quoteRow :: NewQuoteRow - quoteRow = case quotedMsg of - Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) - Just QuotedMsg {msgRef = MsgRef {msgId = sharedMsgId, sentAt, sent, memberId}, content} -> - uncurry (sharedMsgId,Just sentAt,Just content,,) $ case chatDirection of - CDDirectRcv _ -> (Just $ not sent, Nothing) - CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ -> - (Just $ Just userMemberId == memberId, memberId) - -createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId -createNewChatItemNoMsg db user chatDirection ciContent = - createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing False - where - quoteRow :: NewQuoteRow - quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing) - -createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO ChatItemId -createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow timed live itemTs createdAt = do - DB.execute - db - [sql| - INSERT INTO chat_items ( - -- user and IDs - user_id, created_by_msg_id, contact_id, group_id, group_member_id, - -- meta - item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at, - -- quote - quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - ((userId, msgId_) :. idsRow :. itemRow :. quoteRow) - ciId <- insertedRowId db - forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt - pure ciId - where - itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime) - itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed - idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64) - idsRow = case chatDirection of - CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing) - CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing) - CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId) - CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing) - -ciTimedRow :: Maybe CITimed -> (Maybe Int, Maybe UTCTime) -ciTimedRow (Just CITimed {ttl, deleteAt}) = (Just ttl, deleteAt) -ciTimedRow _ = (Nothing, Nothing) - -insertChatItemMessage_ :: DB.Connection -> ChatItemId -> MessageId -> UTCTime -> IO () -insertChatItemMessage_ db ciId msgId ts = DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, ts, ts) - -getChatItemQuote_ :: DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c) -getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} = - case chatDirection of - CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent) - CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} -> - case memberId of - Just mId - | mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId - | mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId mId - | otherwise -> getGroupChatItemQuote_ groupId mId - _ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing - where - ciQuote :: Maybe ChatItemId -> CIQDirection c -> CIQuote c - ciQuote itemId dir = CIQuote dir itemId msgId sentAt content . parseMaybeMarkdownList $ msgContentText content - getDirectChatItemQuote_ :: Int64 -> Bool -> IO (CIQuote 'CTDirect) - getDirectChatItemQuote_ contactId userSent = do - fmap ciQuoteDirect . maybeFirstRow fromOnly $ - DB.query - db - "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ? AND item_sent = ?" - (userId, contactId, msgId, userSent) - where - ciQuoteDirect :: Maybe ChatItemId -> CIQuote 'CTDirect - ciQuoteDirect = (`ciQuote` if userSent then CIQDirectSnd else CIQDirectRcv) - getUserGroupChatItemId_ :: Int64 -> IO (Maybe ChatItemId) - getUserGroupChatItemId_ groupId = - maybeFirstRow fromOnly $ - DB.query - db - "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? AND item_sent = ? AND group_member_id IS NULL" - (userId, groupId, msgId, MDSnd) - getGroupChatItemId_ :: Int64 -> MemberId -> IO (Maybe ChatItemId) - getGroupChatItemId_ groupId mId = - maybeFirstRow fromOnly $ - DB.query - db - "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? AND item_sent = ? AND group_member_id = ?" - (userId, groupId, msgId, MDRcv, mId) - getGroupChatItemQuote_ :: Int64 -> MemberId -> IO (CIQuote 'CTGroup) - getGroupChatItemQuote_ groupId mId = do - ciQuoteGroup - <$> DB.queryNamed - db - [sql| - SELECT i.chat_item_id, - -- GroupMember - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, - m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, - p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences - FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - LEFT JOIN contacts c ON m.contact_id = c.contact_id - LEFT JOIN chat_items i ON i.group_id = m.group_id - AND m.group_member_id = i.group_member_id - AND i.shared_msg_id = :msg_id - WHERE m.user_id = :user_id AND m.group_id = :group_id AND m.member_id = :member_id - |] - [":user_id" := userId, ":group_id" := groupId, ":member_id" := mId, ":msg_id" := msgId] - where - ciQuoteGroup :: [Only (Maybe ChatItemId) :. GroupMemberRow] -> CIQuote 'CTGroup - ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing - ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow - -getChatPreviews :: DB.Connection -> User -> Bool -> IO [AChat] -getChatPreviews db user withPCC = do - directChats <- getDirectChatPreviews_ db user - groupChats <- getGroupChatPreviews_ db user - cReqChats <- getContactRequestChatPreviews_ db user - connChats <- getContactConnectionChatPreviews_ db user withPCC - pure $ sortOn (Down . ts) (directChats <> groupChats <> cReqChats <> connChats) - where - ts :: AChat -> UTCTime - ts (AChat _ Chat {chatInfo, chatItems}) = case chatInfoChatTs chatInfo of - Just chatTs -> chatTs - Nothing -> case chatItems of - ci : _ -> max (chatItemTs ci) (chatInfoUpdatedAt chatInfo) - _ -> chatInfoUpdatedAt chatInfo - -getDirectChatPreviews_ :: DB.Connection -> User -> IO [AChat] -getDirectChatPreviews_ db user@User {userId} = do - currentTs <- getCurrentTime - map (toDirectChatPreview currentTs) - <$> DB.query - db - [sql| - SELECT - -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, - c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, - -- ChatStats - COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), ct.unread_chat, - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- DirectQuote - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent - FROM contacts ct - JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id - JOIN connections c ON c.contact_id = ct.contact_id - LEFT JOIN ( - SELECT contact_id, MAX(chat_item_id) AS MaxId - FROM chat_items - GROUP BY contact_id - ) MaxIds ON MaxIds.contact_id = ct.contact_id - LEFT JOIN chat_items i ON i.contact_id = MaxIds.contact_id - AND i.chat_item_id = MaxIds.MaxId - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - LEFT JOIN ( - SELECT contact_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread - FROM chat_items - WHERE item_status = ? - GROUP BY contact_id - ) ChatStats ON ChatStats.contact_id = ct.contact_id - LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id - WHERE ct.user_id = ? - AND ((c.conn_level = 0 AND c.via_group_link = 0) OR ct.contact_used = 1) - AND ct.deleted = 0 - AND c.connection_id = ( - SELECT cc_connection_id FROM ( - SELECT - cc.connection_id AS cc_connection_id, - (CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord - FROM connections cc - WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id - ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC - LIMIT 1 - ) - ) - ORDER BY i.item_ts DESC - |] - (CISRcvNew, userId, ConnReady, ConnSndReady) - where - toDirectChatPreview :: UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat - toDirectChatPreview currentTs (contactRow :. connRow :. statsRow :. ciRow_) = - let contact = toContact user $ contactRow :. connRow - ci_ = toDirectChatItemList currentTs ciRow_ - stats = toChatStats statsRow - in AChat SCTDirect $ Chat (DirectChat contact) ci_ stats - -getGroupChatPreviews_ :: DB.Connection -> User -> IO [AChat] -getGroupChatPreviews_ db User {userId, userContactId} = do - currentTs <- getCurrentTime - map (toGroupChatPreview currentTs) - <$> DB.query - db - [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - -- GroupMember - membership - mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, - pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, - -- ChatStats - COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), g.unread_chat, - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- Maybe GroupMember - sender - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, - m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, - p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, - -- quoted ChatItem - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, - -- quoted GroupMember - rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, - rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, - rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, - -- deleted by GroupMember - dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, - dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, - dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences - FROM groups g - JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id - JOIN group_members mu ON mu.group_id = g.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - LEFT JOIN ( - SELECT group_id, MAX(chat_item_id) AS MaxId - FROM chat_items - GROUP BY group_id - ) MaxIds ON MaxIds.group_id = g.group_id - LEFT JOIN chat_items i ON i.group_id = MaxIds.group_id - AND i.chat_item_id = MaxIds.MaxId - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - LEFT JOIN ( - SELECT group_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread - FROM chat_items - WHERE item_status = ? - GROUP BY group_id - ) ChatStats ON ChatStats.group_id = g.group_id - LEFT JOIN group_members m ON m.group_member_id = i.group_member_id - LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.group_id = i.group_id - LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id - LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id) - LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id - LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id) - WHERE g.user_id = ? AND mu.contact_id = ? - ORDER BY i.item_ts DESC - |] - (CISRcvNew, userId, userContactId) - where - toGroupChatPreview :: UTCTime -> GroupInfoRow :. ChatStatsRow :. MaybeGroupChatItemRow -> AChat - toGroupChatPreview currentTs (groupInfoRow :. statsRow :. ciRow_) = - let groupInfo = toGroupInfo userContactId groupInfoRow - ci_ = toGroupChatItemList currentTs userContactId ciRow_ - stats = toChatStats statsRow - in AChat SCTGroup $ Chat (GroupChat groupInfo) ci_ stats - -getContactRequestChatPreviews_ :: DB.Connection -> User -> IO [AChat] -getContactRequestChatPreviews_ db User {userId} = - map toContactRequestChatPreview - <$> DB.query - db - [sql| - SELECT - cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id, - c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at - FROM contact_requests cr - JOIN connections c ON c.user_contact_link_id = cr.user_contact_link_id - JOIN contact_profiles p ON p.contact_profile_id = cr.contact_profile_id - JOIN user_contact_links uc ON uc.user_contact_link_id = cr.user_contact_link_id - WHERE cr.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL - |] - (userId, userId) - where - toContactRequestChatPreview :: ContactRequestRow -> AChat - toContactRequestChatPreview cReqRow = - let cReq = toContactRequest cReqRow - stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - in AChat SCTContactRequest $ Chat (ContactRequest cReq) [] stats - -getContactConnectionChatPreviews_ :: DB.Connection -> User -> Bool -> IO [AChat] -getContactConnectionChatPreviews_ _ _ False = pure [] -getContactConnectionChatPreviews_ db User {userId} _ = - map toContactConnectionChatPreview - <$> DB.query - db - [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at - FROM connections - WHERE user_id = ? AND conn_type = ? AND contact_id IS NULL AND conn_level = 0 AND via_contact IS NULL AND (via_group_link = 0 || (via_group_link = 1 AND group_link_id IS NOT NULL)) - |] - (userId, ConnContact) - where - toContactConnectionChatPreview :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, LocalAlias, UTCTime, UTCTime) -> AChat - toContactConnectionChatPreview connRow = - let conn = toPendingContactConnection connRow - stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - in AChat SCTContactConnection $ Chat (ContactConnection conn) [] stats - -getPendingContactConnection :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO PendingContactConnection -getPendingContactConnection db userId connId = do - ExceptT . firstRow toPendingContactConnection (SEPendingConnectionNotFound connId) $ - DB.query - db - [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at - FROM connections - WHERE user_id = ? - AND connection_id = ? - AND conn_type = ? - AND contact_id IS NULL - AND conn_level = 0 - AND via_contact IS NULL - |] - (userId, connId, ConnContact) - -deletePendingContactConnection :: DB.Connection -> UserId -> Int64 -> IO () -deletePendingContactConnection db userId connId = - DB.execute - db - [sql| - DELETE FROM connections - WHERE user_id = ? - AND connection_id = ? - AND conn_type = ? - AND contact_id IS NULL - AND conn_level = 0 - AND via_contact IS NULL - |] - (userId, connId, ConnContact) - -updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () -updateContactSettings db User {userId} contactId ChatSettings {enableNtfs} = - DB.execute db "UPDATE contacts SET enable_ntfs = ? WHERE user_id = ? AND contact_id = ?" (enableNtfs, userId, contactId) - -updateGroupSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () -updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs} = - DB.execute db "UPDATE groups SET enable_ntfs = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, userId, groupId) - -toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, LocalAlias, UTCTime, UTCTime) -> PendingContactConnection -toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt) = - PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt} - -getDirectChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect) -getDirectChat db user contactId pagination search_ = do - let search = fromMaybe "" search_ - ct <- getContact db user contactId - liftIO . getDirectChatReactions_ db ct =<< case pagination of - CPLast count -> getDirectChatLast_ db user ct count search - CPAfter afterId count -> getDirectChatAfter_ db user ct afterId count search - CPBefore beforeId count -> getDirectChatBefore_ db user ct beforeId count search - -getDirectChatLast_ :: DB.Connection -> User -> Contact -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) -getDirectChatLast_ db user ct@Contact {contactId} count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - chatItems <- getDirectChatItemsLast db user contactId count search - pure $ Chat (DirectChat ct) (reverse chatItems) stats - --- the last items in reverse order (the last item in the conversation is the first in the returned list) -getDirectChatItemsLast :: DB.Connection -> User -> ContactId -> Int -> String -> ExceptT StoreError IO [CChatItem 'CTDirect] -getDirectChatItemsLast db User {userId} contactId count search = ExceptT $ do - currentTs <- getCurrentTime - mapM (toDirectChatItem currentTs) - <$> DB.query - db - [sql| - SELECT - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- DirectQuote - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent - FROM chat_items i - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id - WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%' - ORDER BY i.chat_item_id DESC - LIMIT ? - |] - (userId, contactId, search, count) - -getDirectChatAfter_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) -getDirectChatAfter_ db User {userId} ct@Contact {contactId} afterChatItemId count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - chatItems <- ExceptT getDirectChatItemsAfter_ - pure $ Chat (DirectChat ct) chatItems stats - where - getDirectChatItemsAfter_ :: IO (Either StoreError [CChatItem 'CTDirect]) - getDirectChatItemsAfter_ = do - currentTs <- getCurrentTime - mapM (toDirectChatItem currentTs) - <$> DB.query - db - [sql| - SELECT - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- DirectQuote - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent - FROM chat_items i - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id - WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%' - AND i.chat_item_id > ? - ORDER BY i.chat_item_id ASC - LIMIT ? - |] - (userId, contactId, search, afterChatItemId, count) - -getDirectChatBefore_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) -getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - chatItems <- ExceptT getDirectChatItemsBefore_ - pure $ Chat (DirectChat ct) (reverse chatItems) stats - where - getDirectChatItemsBefore_ :: IO (Either StoreError [CChatItem 'CTDirect]) - getDirectChatItemsBefore_ = do - currentTs <- getCurrentTime - mapM (toDirectChatItem currentTs) - <$> DB.query - db - [sql| - SELECT - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- DirectQuote - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent - FROM chat_items i - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id - WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%' - AND i.chat_item_id < ? - ORDER BY i.chat_item_id DESC - LIMIT ? - |] - (userId, contactId, search, beforeChatItemId, count) - -getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64 -getContactIdByName db User {userId} cName = - ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $ - DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ? AND deleted = 0" (userId, cName) - -getContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact -getContact db user contactId = getContact_ db user contactId False - -getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact -getContact_ db user@User {userId} contactId deleted = - ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $ - DB.query - db - [sql| - SELECT - -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, - c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM contacts ct - JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id - LEFT JOIN connections c ON c.contact_id = ct.contact_id - WHERE ct.user_id = ? AND ct.contact_id = ? - AND ct.deleted = ? - AND c.connection_id = ( - SELECT cc_connection_id FROM ( - SELECT - cc.connection_id AS cc_connection_id, - (CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord - FROM connections cc - WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id - ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC - LIMIT 1 - ) - ) - |] - (userId, contactId, deleted, ConnReady, ConnSndReady) - -getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChat db user groupId pagination search_ = do - let search = fromMaybe "" search_ - g <- getGroupInfo db user groupId - liftIO . getGroupChatReactions_ db g =<< case pagination of - CPLast count -> getGroupChatLast_ db user g count search - CPAfter afterId count -> getGroupChatAfter_ db user g afterId count search - CPBefore beforeId count -> getGroupChatBefore_ db user g beforeId count search - -getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChatLast_ db user@User {userId} g@GroupInfo {groupId} count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - chatItemIds <- liftIO getGroupChatItemIdsLast_ - chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds - pure $ Chat (GroupChat g) (reverse chatItems) stats - where - getGroupChatItemIdsLast_ :: IO [ChatItemId] - getGroupChatItemIdsLast_ = - map fromOnly - <$> DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' - ORDER BY item_ts DESC, chat_item_id DESC - LIMIT ? - |] - (userId, groupId, search, count) - -getGroupMemberChatItemLast :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO (CChatItem 'CTGroup) -getGroupMemberChatItemLast db user@User {userId} groupId groupMemberId = do - chatItemId <- - ExceptT . firstRow fromOnly (SEChatItemNotFoundByGroupId groupId) $ - DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND group_member_id = ? - ORDER BY item_ts DESC, chat_item_id DESC - LIMIT 1 - |] - (userId, groupId, groupMemberId) - getGroupChatItem db user groupId chatItemId - -getGroupChatAfter_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChatAfter_ db user@User {userId} g@GroupInfo {groupId} afterChatItemId count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - afterChatItem <- getGroupChatItem db user groupId afterChatItemId - chatItemIds <- liftIO $ getGroupChatItemIdsAfter_ (chatItemTs afterChatItem) - chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds - pure $ Chat (GroupChat g) chatItems stats - where - getGroupChatItemIdsAfter_ :: UTCTime -> IO [ChatItemId] - getGroupChatItemIdsAfter_ afterChatItemTs = - map fromOnly - <$> DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' - AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?)) - ORDER BY item_ts ASC, chat_item_id ASC - LIMIT ? - |] - (userId, groupId, search, afterChatItemTs, afterChatItemTs, afterChatItemId, count) - -getGroupChatBefore_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChatBefore_ db user@User {userId} g@GroupInfo {groupId} beforeChatItemId count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - beforeChatItem <- getGroupChatItem db user groupId beforeChatItemId - chatItemIds <- liftIO $ getGroupChatItemIdsBefore_ (chatItemTs beforeChatItem) - chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds - pure $ Chat (GroupChat g) (reverse chatItems) stats - where - getGroupChatItemIdsBefore_ :: UTCTime -> IO [ChatItemId] - getGroupChatItemIdsBefore_ beforeChatItemTs = - map fromOnly - <$> DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' - AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?)) - ORDER BY item_ts DESC, chat_item_id DESC - LIMIT ? - |] - (userId, groupId, search, beforeChatItemTs, beforeChatItemTs, beforeChatItemId, count) - -getGroupInfo :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO GroupInfo -getGroupInfo db User {userId, userContactId} groupId = - ExceptT . firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $ - DB.query - db - [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - -- GroupMember - membership - mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, - pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences - FROM groups g - JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id - JOIN group_members mu ON mu.group_id = g.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ? - |] - (groupId, userId, userContactId) - -updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo -updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences} - | displayName == newName = liftIO $ do - currentTs <- getCurrentTime - updateGroupProfile_ currentTs - pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences} - | otherwise = - ExceptT . withLocalDisplayName db userId newName $ \ldn -> do - currentTs <- getCurrentTime - updateGroupProfile_ currentTs - updateGroup_ ldn currentTs - pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences} - where - fullGroupPreferences = mergeGroupPreferences groupPreferences - updateGroupProfile_ currentTs = - DB.execute - db - [sql| - UPDATE group_profiles - SET display_name = ?, full_name = ?, description = ?, image = ?, preferences = ?, updated_at = ? - WHERE group_profile_id IN ( - SELECT group_profile_id - FROM groups - WHERE user_id = ? AND group_id = ? - ) - |] - (newName, fullName, description, image, groupPreferences, currentTs, userId, groupId) - updateGroup_ ldn currentTs = do - DB.execute - db - "UPDATE groups SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" - (ldn, currentTs, userId, groupId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) - -getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem] -getAllChatItems db user@User {userId} pagination search_ = do - itemRefs <- - rights . map toChatItemRef <$> case pagination of - CPLast count -> liftIO $ getAllChatItemsLast_ count - CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId - CPBefore beforeId count -> liftIO . getAllChatItemsBefore_ beforeId count . aChatItemTs =<< getAChatItem_ beforeId - mapM (uncurry (getAChatItem db user) >=> liftIO . getACIReactions db) itemRefs - where - search = fromMaybe "" search_ - getAChatItem_ itemId = do - chatRef <- getChatRefViaItemId db user itemId - getAChatItem db user chatRef itemId - getAllChatItemsLast_ count = - reverse - <$> DB.query - db - [sql| - SELECT chat_item_id, contact_id, group_id - FROM chat_items - WHERE user_id = ? AND item_text LIKE '%' || ? || '%' - ORDER BY item_ts DESC, chat_item_id DESC - LIMIT ? - |] - (userId, search, count) - getAllChatItemsAfter_ afterId count afterTs = - DB.query - db - [sql| - SELECT chat_item_id, contact_id, group_id - FROM chat_items - WHERE user_id = ? AND item_text LIKE '%' || ? || '%' - AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?)) - ORDER BY item_ts ASC, chat_item_id ASC - LIMIT ? - |] - (userId, search, afterTs, afterTs, afterId, count) - getAllChatItemsBefore_ beforeId count beforeTs = - reverse - <$> DB.query - db - [sql| - SELECT chat_item_id, contact_id, group_id - FROM chat_items - WHERE user_id = ? AND item_text LIKE '%' || ? || '%' - AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?)) - ORDER BY item_ts DESC, chat_item_id DESC - LIMIT ? - |] - (userId, search, beforeTs, beforeTs, beforeId, count) - -getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId -getGroupIdByName db User {userId} gName = - ExceptT . firstRow fromOnly (SEGroupNotFoundByName gName) $ - DB.query db "SELECT group_id FROM groups WHERE user_id = ? AND local_display_name = ?" (userId, gName) - -getGroupMemberIdByName :: DB.Connection -> User -> GroupId -> ContactName -> ExceptT StoreError IO GroupMemberId -getGroupMemberIdByName db User {userId} groupId groupMemberName = - ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound groupId groupMemberName) $ - DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName) - -getChatItemIdByAgentMsgId :: DB.Connection -> Int64 -> AgentMsgId -> IO (Maybe ChatItemId) -getChatItemIdByAgentMsgId db connId msgId = - fmap join . maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT chat_item_id - FROM chat_item_messages - WHERE message_id = ( - SELECT message_id - FROM msg_deliveries - WHERE connection_id = ? AND agent_msg_id = ? - LIMIT 1 - ) - |] - (connId, msgId) - -updateDirectChatItemStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIStatus d -> ExceptT StoreError IO (ChatItem 'CTDirect d) -updateDirectChatItemStatus db user@User {userId} contactId itemId itemStatus = do - ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId - currentTs <- liftIO getCurrentTime - liftIO $ DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" (itemStatus, currentTs, userId, contactId, itemId) - pure ci {meta = (meta ci) {itemStatus}} - where - correctDir :: CChatItem c -> Either StoreError (ChatItem c d) - correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci - -updateDirectChatItem :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d) -updateDirectChatItem db user contactId itemId newContent live msgId_ = do - ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId - liftIO $ updateDirectChatItem' db user contactId ci newContent live msgId_ - where - correctDir :: CChatItem c -> Either StoreError (ChatItem c d) - correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci - -updateDirectChatItem' :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItem 'CTDirect d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTDirect d) -updateDirectChatItem' db User {userId} contactId ci newContent live msgId_ = do - currentTs <- liftIO getCurrentTime - let ci' = updatedChatItem ci newContent live currentTs - liftIO $ updateDirectChatItem_ db userId contactId ci' msgId_ - pure ci' - -updatedChatItem :: ChatItem c d -> CIContent d -> Bool -> UTCTime -> ChatItem c d -updatedChatItem ci@ChatItem {meta = meta@CIMeta {itemStatus, itemEdited, itemTimed, itemLive}} newContent live currentTs = - let newText = ciContentToText newContent - edited' = itemEdited || (itemLive /= Just True) - live' = (live &&) <$> itemLive - timed' = case (itemStatus, itemTimed, itemLive, live) of - (CISRcvNew, _, _, _) -> itemTimed - (_, Just CITimed {ttl, deleteAt = Nothing}, Just True, False) -> - -- timed item, sent or read, not set for deletion, was live, now not live - let deleteAt' = addUTCTime (realToFrac ttl) currentTs - in Just CITimed {ttl, deleteAt = Just deleteAt'} - _ -> itemTimed - in ci {content = newContent, meta = meta {itemText = newText, itemEdited = edited', itemTimed = timed', itemLive = live'}, formattedText = parseMaybeMarkdownList newText} - --- this function assumes that direct item with correct chat direction already exists, --- it should be checked before calling it -updateDirectChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> UserId -> Int64 -> ChatItem 'CTDirect d -> Maybe MessageId -> IO () -updateDirectChatItem_ db userId contactId ChatItem {meta, content} msgId_ = do - let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta - itemDeleted' = isJust itemDeleted - itemDeletedTs' = itemDeletedTs =<< itemDeleted - DB.execute - db - [sql| - UPDATE chat_items - SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_deleted_ts = ?, item_edited = ?, item_live = ?, updated_at = ?, timed_ttl = ?, timed_delete_at = ? - WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? - |] - ((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, contactId, itemId)) - forM_ msgId_ $ \msgId -> liftIO $ insertChatItemMessage_ db itemId msgId updatedAt - -addInitialAndNewCIVersions :: DB.Connection -> ChatItemId -> (UTCTime, MsgContent) -> (UTCTime, MsgContent) -> IO () -addInitialAndNewCIVersions db itemId (initialTs, initialMC) (newTs, newMC) = do - versionsCount <- getChatItemVersionsCount db itemId - when (versionsCount == 0) $ - createChatItemVersion db itemId initialTs initialMC - createChatItemVersion db itemId newTs newMC - -getChatItemVersionsCount :: DB.Connection -> ChatItemId -> IO Int -getChatItemVersionsCount db itemId = do - count <- - maybeFirstRow fromOnly $ - DB.query db "SELECT COUNT(1) FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId) - pure $ fromMaybe 0 count - -createChatItemVersion :: DB.Connection -> ChatItemId -> UTCTime -> MsgContent -> IO () -createChatItemVersion db itemId itemVersionTs msgContent = - DB.execute - db - [sql| - INSERT INTO chat_item_versions (chat_item_id, msg_content, item_version_ts) - VALUES (?,?,?) - |] - (itemId, toMCText msgContent, itemVersionTs) - -deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO () -deleteDirectChatItem db User {userId} Contact {contactId} (CChatItem _ ci) = do - let itemId = chatItemId' ci - deleteChatItemMessages_ db itemId - deleteChatItemVersions_ db itemId - deleteDirectCIReactions_ db contactId ci - DB.execute - db - [sql| - DELETE FROM chat_items - WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? - |] - (userId, contactId, itemId) - -deleteChatItemMessages_ :: DB.Connection -> ChatItemId -> IO () -deleteChatItemMessages_ db itemId = - DB.execute - db - [sql| - DELETE FROM messages - WHERE message_id IN ( - SELECT message_id - FROM chat_item_messages - WHERE chat_item_id = ? - ) - |] - (Only itemId) - -deleteChatItemVersions_ :: DB.Connection -> ChatItemId -> IO () -deleteChatItemVersions_ db itemId = - DB.execute db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId) - -markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> MessageId -> UTCTime -> IO () -markDirectChatItemDeleted db User {userId} Contact {contactId} (CChatItem _ ci) msgId deletedTs = do - currentTs <- liftIO getCurrentTime - let itemId = chatItemId' ci - insertChatItemMessage_ db itemId msgId currentTs - DB.execute - db - [sql| - UPDATE chat_items - SET item_deleted = 1, item_deleted_ts = ?, updated_at = ? - WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? - |] - (deletedTs, currentTs, userId, contactId, itemId) - -getDirectChatItemBySharedMsgId :: DB.Connection -> User -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect) -getDirectChatItemBySharedMsgId db user@User {userId} contactId sharedMsgId = do - itemId <- getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId - getDirectChatItem db user contactId itemId - -getDirectChatItemByAgentMsgId :: DB.Connection -> User -> ContactId -> Int64 -> AgentMsgId -> IO (Maybe (CChatItem 'CTDirect)) -getDirectChatItemByAgentMsgId db user contactId connId msgId = do - itemId_ <- getChatItemIdByAgentMsgId db connId msgId - maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getDirectChatItem db user contactId) itemId_ - -getDirectChatItemIdBySharedMsgId_ :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 -getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId = - ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ - DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ? - ORDER BY chat_item_id DESC - LIMIT 1 - |] - (userId, contactId, sharedMsgId) - -getDirectChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTDirect) -getDirectChatItem db User {userId} contactId itemId = ExceptT $ do - currentTs <- getCurrentTime - join <$> firstRow (toDirectChatItem currentTs) (SEChatItemNotFound itemId) getItem - where - getItem = - DB.query - db - [sql| - SELECT - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- DirectQuote - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent - FROM chat_items i - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id - WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id = ? - |] - (userId, contactId, itemId) - -getDirectChatItemIdByText :: DB.Connection -> UserId -> Int64 -> SMsgDirection d -> Text -> ExceptT StoreError IO ChatItemId -getDirectChatItemIdByText db userId contactId msgDir quotedMsg = - ExceptT . firstRow fromOnly (SEChatItemNotFoundByText quotedMsg) $ - DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND contact_id = ? AND item_sent = ? AND item_text LIKE ? - ORDER BY chat_item_id DESC - LIMIT 1 - |] - (userId, contactId, msgDir, quotedMsg <> "%") - -getDirectChatItemIdByText' :: DB.Connection -> User -> ContactId -> Text -> ExceptT StoreError IO ChatItemId -getDirectChatItemIdByText' db User {userId} contactId msg = - ExceptT . firstRow fromOnly (SEChatItemNotFoundByText msg) $ - DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND contact_id = ? AND item_text LIKE ? - ORDER BY chat_item_id DESC - LIMIT 1 - |] - (userId, contactId, msg <> "%") - -updateGroupChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTGroup d) -updateGroupChatItem db user groupId ci newContent live msgId_ = do - currentTs <- liftIO getCurrentTime - let ci' = updatedChatItem ci newContent live currentTs - liftIO $ updateGroupChatItem_ db user groupId ci' msgId_ - pure ci' - --- this function assumes that the group item with correct chat direction already exists, --- it should be checked before calling it -updateGroupChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> Maybe MessageId -> IO () -updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ = do - let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta - itemDeleted' = isJust itemDeleted - itemDeletedTs' = itemDeletedTs =<< itemDeleted - DB.execute - db - [sql| - UPDATE chat_items - SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_deleted_ts = ?, item_edited = ?, item_live = ?, updated_at = ?, timed_ttl = ?, timed_delete_at = ? - WHERE user_id = ? AND group_id = ? AND chat_item_id = ? - |] - ((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId)) - forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt - -deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO () -deleteGroupChatItem db User {userId} g@GroupInfo {groupId} (CChatItem _ ci) = do - let itemId = chatItemId' ci - deleteChatItemMessages_ db itemId - deleteChatItemVersions_ db itemId - deleteGroupCIReactions_ db g ci - DB.execute - db - [sql| - DELETE FROM chat_items - WHERE user_id = ? AND group_id = ? AND chat_item_id = ? - |] - (userId, groupId, itemId) - -updateGroupChatItemModerated :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> GroupMember -> UTCTime -> IO AChatItem -updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) m@GroupMember {groupMemberId} deletedTs = do - currentTs <- getCurrentTime - let toContent = msgDirToModeratedContent_ msgDir - toText = ciModeratedText - itemId = chatItemId' ci - deleteChatItemMessages_ db itemId - deleteChatItemVersions_ db itemId - liftIO $ - DB.execute - db - [sql| - UPDATE chat_items - SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, item_content = ?, item_text = ?, updated_at = ? - WHERE user_id = ? AND group_id = ? AND chat_item_id = ? - |] - (deletedTs, groupMemberId, toContent, toText, currentTs, userId, groupId, itemId) - pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just currentTs) m)}, formattedText = Nothing}) - -markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> UTCTime -> IO () -markGroupChatItemDeleted db User {userId} GroupInfo {groupId} (CChatItem _ ci) msgId byGroupMember_ deletedTs = do - currentTs <- liftIO getCurrentTime - let itemId = chatItemId' ci - deletedByGroupMemberId = case byGroupMember_ of - Just GroupMember {groupMemberId} -> Just groupMemberId - _ -> Nothing - insertChatItemMessage_ db itemId msgId currentTs - DB.execute - db - [sql| - UPDATE chat_items - SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, updated_at = ? - WHERE user_id = ? AND group_id = ? AND chat_item_id = ? - |] - (deletedTs, deletedByGroupMemberId, currentTs, userId, groupId, itemId) - -getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) -getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do - itemId <- - ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ - DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ? - ORDER BY chat_item_id DESC - LIMIT 1 - |] - (userId, groupId, groupMemberId, sharedMsgId) - getGroupChatItem db user groupId itemId - -getGroupMemberCIBySharedMsgId :: DB.Connection -> User -> GroupId -> MemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) -getGroupMemberCIBySharedMsgId db user@User {userId} groupId memberId sharedMsgId = do - itemId <- - ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ - DB.query - db - [sql| - SELECT i.chat_item_id - FROM chat_items i - JOIN group_members m ON m.group_id = i.group_id - AND ((i.group_member_id IS NULL AND m.member_category = ?) - OR i.group_member_id = m.group_member_id) - WHERE i.user_id = ? AND i.group_id = ? AND m.member_id = ? AND i.shared_msg_id = ? - ORDER BY i.chat_item_id DESC - LIMIT 1 - |] - (GCUserMember, userId, groupId, memberId, sharedMsgId) - getGroupChatItem db user groupId itemId - -getGroupChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTGroup) -getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do - currentTs <- getCurrentTime - join <$> firstRow (toGroupChatItem currentTs userContactId) (SEChatItemNotFound itemId) getItem - where - getItem = - DB.query - db - [sql| - SELECT - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- GroupMember - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, - m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, - p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, - -- quoted ChatItem - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, - -- quoted GroupMember - rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, - rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, - rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, - -- deleted by GroupMember - dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, - dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, - dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences - FROM chat_items i - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - LEFT JOIN group_members m ON m.group_member_id = i.group_member_id - LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.group_id = i.group_id - LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id - LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id) - LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id - LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id) - WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ? - |] - (userId, groupId, itemId) - -getGroupChatItemIdByText :: DB.Connection -> User -> GroupId -> Maybe ContactName -> Text -> ExceptT StoreError IO ChatItemId -getGroupChatItemIdByText db User {userId, localDisplayName = userName} groupId contactName_ quotedMsg = - ExceptT . firstRow fromOnly (SEChatItemNotFoundByText quotedMsg) $ case contactName_ of - Nothing -> anyMemberChatItem_ - Just cName - | userName == cName -> userChatItem_ - | otherwise -> memberChatItem_ cName - where - anyMemberChatItem_ = - DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_text like ? - ORDER BY chat_item_id DESC - LIMIT 1 - |] - (userId, groupId, quotedMsg <> "%") - userChatItem_ = - DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND group_member_id IS NULL AND item_text like ? - ORDER BY chat_item_id DESC - LIMIT 1 - |] - (userId, groupId, quotedMsg <> "%") - memberChatItem_ cName = - DB.query - db - [sql| - SELECT i.chat_item_id - FROM chat_items i - JOIN group_members m ON m.group_member_id = i.group_member_id - JOIN contacts c ON c.contact_id = m.contact_id - WHERE i.user_id = ? AND i.group_id = ? AND c.local_display_name = ? AND i.item_text like ? - ORDER BY i.chat_item_id DESC - LIMIT 1 - |] - (userId, groupId, cName, quotedMsg <> "%") - -getGroupChatItemIdByText' :: DB.Connection -> User -> GroupId -> Text -> ExceptT StoreError IO ChatItemId -getGroupChatItemIdByText' db User {userId} groupId msg = - ExceptT . firstRow fromOnly (SEChatItemNotFoundByText msg) $ - DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_text like ? - ORDER BY chat_item_id DESC - LIMIT 1 - |] - (userId, groupId, msg <> "%") - -getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem -getChatItemByFileId db user@User {userId} fileId = do - (chatRef, itemId) <- - ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $ - DB.query - db - [sql| - SELECT i.chat_item_id, i.contact_id, i.group_id - FROM chat_items i - JOIN files f ON f.chat_item_id = i.chat_item_id - WHERE f.user_id = ? AND f.file_id = ? - LIMIT 1 - |] - (userId, fileId) - getAChatItem db user chatRef itemId - -getChatItemByGroupId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem -getChatItemByGroupId db user@User {userId} groupId = do - (chatRef, itemId) <- - ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $ - DB.query - db - [sql| - SELECT i.chat_item_id, i.contact_id, i.group_id - FROM chat_items i - JOIN groups g ON g.chat_item_id = i.chat_item_id - WHERE g.user_id = ? AND g.group_id = ? - LIMIT 1 - |] - (userId, groupId) - getAChatItem db user chatRef itemId - -getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef -getChatRefViaItemId db User {userId} itemId = do - ExceptT . firstRow' toChatRef (SEChatItemNotFound itemId) $ - DB.query db "SELECT contact_id, group_id FROM chat_items WHERE user_id = ? AND chat_item_id = ?" (userId, itemId) - where - toChatRef = \case - (Just contactId, Nothing) -> Right $ ChatRef CTDirect contactId - (Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId - (_, _) -> Left $ SEBadChatItem itemId - -getAChatItem :: DB.Connection -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem -getAChatItem db user chatRef itemId = case chatRef of - ChatRef CTDirect contactId -> do - ct <- getContact db user contactId - (CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId - pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci - ChatRef CTGroup groupId -> do - gInfo <- getGroupInfo db user groupId - (CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId - pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci - _ -> throwError $ SEChatItemNotFound itemId - -getChatItemVersions :: DB.Connection -> ChatItemId -> IO [ChatItemVersion] -getChatItemVersions db itemId = do - map toChatItemVersion - <$> DB.query - db - [sql| - SELECT chat_item_version_id, msg_content, item_version_ts, created_at - FROM chat_item_versions - WHERE chat_item_id = ? - ORDER BY chat_item_version_id DESC - |] - (Only itemId) - where - toChatItemVersion :: (Int64, MsgContent, UTCTime, UTCTime) -> ChatItemVersion - toChatItemVersion (chatItemVersionId, msgContent, itemVersionTs, createdAt) = - let formattedText = parseMaybeMarkdownList $ msgContentText msgContent - in ChatItemVersion {chatItemVersionId, msgContent, formattedText, itemVersionTs, createdAt} - -getDirectChatReactions_ :: DB.Connection -> Contact -> Chat 'CTDirect -> IO (Chat 'CTDirect) -getDirectChatReactions_ db ct c@Chat {chatItems} = do - chatItems' <- forM chatItems $ \(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) -> do - reactions <- maybe (pure []) (getDirectCIReactions db ct) itemSharedMsgId - pure $ CChatItem md ci {reactions} - pure c {chatItems = chatItems'} - -getGroupChatReactions_ :: DB.Connection -> GroupInfo -> Chat 'CTGroup -> IO (Chat 'CTGroup) -getGroupChatReactions_ db g c@Chat {chatItems} = do - chatItems' <- forM chatItems $ \(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) -> do - let GroupMember {memberId} = chatItemMember g ci - reactions <- maybe (pure []) (getGroupCIReactions db g memberId) itemSharedMsgId - pure $ CChatItem md ci {reactions} - pure c {chatItems = chatItems'} - -getDirectCIReactions :: DB.Connection -> Contact -> SharedMsgId -> IO [CIReactionCount] -getDirectCIReactions db Contact {contactId} itemSharedMsgId = - map toCIReaction - <$> DB.query - db - [sql| - SELECT reaction, MAX(reaction_sent), COUNT(chat_item_reaction_id) - FROM chat_item_reactions - WHERE contact_id = ? AND shared_msg_id = ? - GROUP BY reaction - |] - (contactId, itemSharedMsgId) - -getGroupCIReactions :: DB.Connection -> GroupInfo -> MemberId -> SharedMsgId -> IO [CIReactionCount] -getGroupCIReactions db GroupInfo {groupId} itemMemberId itemSharedMsgId = - map toCIReaction - <$> DB.query - db - [sql| - SELECT reaction, MAX(reaction_sent), COUNT(chat_item_reaction_id) - FROM chat_item_reactions - WHERE group_id = ? AND item_member_id = ? AND shared_msg_id = ? - GROUP BY reaction - |] - (groupId, itemMemberId, itemSharedMsgId) - -getACIReactions :: DB.Connection -> AChatItem -> IO AChatItem -getACIReactions db aci@(AChatItem _ md chat ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) = case itemSharedMsgId of - Just itemSharedMId -> case chat of - DirectChat ct -> do - reactions <- getDirectCIReactions db ct itemSharedMId - pure $ AChatItem SCTDirect md chat ci {reactions} - GroupChat g -> do - let GroupMember {memberId} = chatItemMember g ci - reactions <- getGroupCIReactions db g memberId itemSharedMId - pure $ AChatItem SCTGroup md chat ci {reactions} - _ -> pure aci - _ -> pure aci - -deleteDirectCIReactions_ :: DB.Connection -> ContactId -> ChatItem 'CTDirect d -> IO () -deleteDirectCIReactions_ db contactId ChatItem {meta = CIMeta {itemSharedMsgId}} = - forM_ itemSharedMsgId $ \itemSharedMId -> - DB.execute db "DELETE FROM chat_item_reactions WHERE contact_id = ? AND shared_msg_id = ?" (contactId, itemSharedMId) - -deleteGroupCIReactions_ :: DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> IO () -deleteGroupCIReactions_ db g@GroupInfo {groupId} ci@ChatItem {meta = CIMeta {itemSharedMsgId}} = - forM_ itemSharedMsgId $ \itemSharedMId -> do - let GroupMember {memberId} = chatItemMember g ci - DB.execute - db - "DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id = ?" - (groupId, itemSharedMId, memberId) - -toCIReaction :: (MsgReaction, Bool, Int) -> CIReactionCount -toCIReaction (reaction, userReacted, totalReacted) = CIReactionCount {reaction, userReacted, totalReacted} - -getDirectReactions :: DB.Connection -> Contact -> SharedMsgId -> Bool -> IO [MsgReaction] -getDirectReactions db ct itemSharedMId sent = - map fromOnly - <$> DB.query - db - [sql| - SELECT reaction - FROM chat_item_reactions - WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? - |] - (contactId' ct, itemSharedMId, sent) - -setDirectReaction :: DB.Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () -setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs - | add = - DB.execute - db - [sql| - INSERT INTO chat_item_reactions - (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) - VALUES (?,?,?,?,?,?) - |] - (contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs) - | otherwise = - DB.execute - db - [sql| - DELETE FROM chat_item_reactions - WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ? - |] - (contactId' ct, itemSharedMId, sent, reaction) - -getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction] -getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent = - map fromOnly - <$> DB.query - db - [sql| - SELECT reaction - FROM chat_item_reactions - WHERE group_id = ? AND group_member_id = ? AND item_member_id = ? AND shared_msg_id = ? AND reaction_sent = ? - |] - (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent) - -setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () -setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reaction add msgId reactionTs - | add = - DB.execute - db - [sql| - INSERT INTO chat_item_reactions - (group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) - VALUES (?,?,?,?,?,?,?,?) - |] - (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs) - | otherwise = - DB.execute - db - [sql| - DELETE FROM chat_item_reactions - WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ? - |] - (groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction) - -updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem -updateDirectCIFileStatus db user fileId fileStatus = do - aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId - case (cType, testEquality d $ msgDirection @d) of - (SCTDirect, Just Refl) -> do - liftIO $ updateCIFileStatus db user fileId fileStatus - pure $ AChatItem SCTDirect d cInfo $ updateFileStatus ci fileStatus - _ -> pure aci - -toChatItemRef :: (ChatItemId, Maybe Int64, Maybe Int64) -> Either StoreError (ChatRef, ChatItemId) -toChatItemRef = \case - (itemId, Just contactId, Nothing) -> Right (ChatRef CTDirect contactId, itemId) - (itemId, Nothing, Just groupId) -> Right (ChatRef CTGroup groupId, itemId) - (itemId, _, _) -> Left $ SEBadChatItem itemId - -updateDirectChatItemsRead :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO () -updateDirectChatItemsRead db User {userId} contactId itemsRange_ = do - currentTs <- getCurrentTime - case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND contact_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, contactId, fromItemId, toItemId, CISRcvNew) - _ -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND contact_id = ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, contactId, CISRcvNew) - -getDirectUnreadTimedItems :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)] -getDirectUnreadTimedItems db User {userId} contactId itemsRange_ = case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.query - db - [sql| - SELECT chat_item_id, timed_ttl - FROM chat_items - WHERE user_id = ? AND contact_id = ? - AND chat_item_id >= ? AND chat_item_id <= ? - AND item_status = ? - AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL - AND (item_live IS NULL OR item_live = ?) - |] - (userId, contactId, fromItemId, toItemId, CISRcvNew, False) - _ -> - DB.query - db - [sql| - SELECT chat_item_id, timed_ttl - FROM chat_items - WHERE user_id = ? AND contact_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL - |] - (userId, contactId, CISRcvNew) - -setDirectChatItemDeleteAt :: DB.Connection -> User -> ContactId -> ChatItemId -> UTCTime -> IO () -setDirectChatItemDeleteAt db User {userId} contactId chatItemId deleteAt = - DB.execute - db - "UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" - (deleteAt, userId, contactId, chatItemId) - -updateGroupChatItemsRead :: DB.Connection -> UserId -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO () -updateGroupChatItemsRead db userId groupId itemsRange_ = do - currentTs <- getCurrentTime - case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND group_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, groupId, fromItemId, toItemId, CISRcvNew) - _ -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND group_id = ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, groupId, CISRcvNew) - -getGroupUnreadTimedItems :: DB.Connection -> User -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)] -getGroupUnreadTimedItems db User {userId} groupId itemsRange_ = case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.query - db - [sql| - SELECT chat_item_id, timed_ttl - FROM chat_items - WHERE user_id = ? AND group_id = ? - AND chat_item_id >= ? AND chat_item_id <= ? - AND item_status = ? - AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL - AND (item_live IS NULL OR item_live = ?) - |] - (userId, groupId, fromItemId, toItemId, CISRcvNew, False) - _ -> - DB.query - db - [sql| - SELECT chat_item_id, timed_ttl - FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL - |] - (userId, groupId, CISRcvNew) - -setGroupChatItemDeleteAt :: DB.Connection -> User -> GroupId -> ChatItemId -> UTCTime -> IO () -setGroupChatItemDeleteAt db User {userId} groupId chatItemId deleteAt = - DB.execute - db - "UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?" - (deleteAt, userId, groupId, chatItemId) - -type ChatStatsRow = (Int, ChatItemId, Bool) - -toChatStats :: ChatStatsRow -> ChatStats -toChatStats (unreadCount, minUnreadItemId, unreadChat) = ChatStats {unreadCount, minUnreadItemId, unreadChat} - -type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe ACIFileStatus, Maybe FileProtocol) - -type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool) - -type ChatItemRow = (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId) :. (Bool, Maybe UTCTime, Maybe Bool, UTCTime, UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow - -type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe AMsgDirection, Maybe Text, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId) :. (Maybe Bool, Maybe UTCTime, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow - -type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool) - -toDirectQuote :: QuoteRow -> Maybe (CIQuote 'CTDirect) -toDirectQuote qr@(_, _, _, _, quotedSent) = toQuote qr $ direction <$> quotedSent - where - direction sent = if sent then CIQDirectSnd else CIQDirectRcv - -toQuote :: QuoteRow -> Maybe (CIQDirection c) -> Maybe (CIQuote c) -toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir = - CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent) - --- this function can be changed so it never fails, not only avoid failure on invalid json -toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) -toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. quoteRow) = - chatItem $ fromRight invalid $ dbParseACIContent itemContentText - where - invalid = ACIContent msgDir $ CIInvalidJSON itemContentText - chatItem itemContent = case (itemContent, itemStatus, fileStatus_) of - (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Just (AFS SMDSnd fileStatus)) -> - Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent (maybeCIFile fileStatus) - (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Nothing) -> - Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent Nothing - (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just (AFS SMDRcv fileStatus)) -> - Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent (maybeCIFile fileStatus) - (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Nothing) -> - Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent Nothing - _ -> badItem - maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) - maybeCIFile fileStatus = - case (fileId_, fileName_, fileSize_, fileProtocol_) of - (Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol} - _ -> Nothing - cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect - cItem d chatDir ciStatus content file = - CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, reactions = [], file} - badItem = Left $ SEBadChatItem itemId - ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d - ciMeta content status = - let itemDeleted' = if itemDeleted then Just (CIDeleted @'CTDirect deletedTs) else Nothing - itemEdited' = fromMaybe False itemEdited - in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt - ciTimed :: Maybe CITimed - ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} - -toDirectChatItemList :: UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect] -toDirectChatItemList currentTs (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) = - either (const []) (: []) $ toDirectChatItem currentTs (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) -toDirectChatItemList _ _ = [] - -type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow - -type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow - -toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) -toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_ - where - direction (Just True) _ = Just CIQGroupSnd - direction (Just False) (Just member) = Just . CIQGroupRcv $ Just member - direction (Just False) Nothing = Just $ CIQGroupRcv Nothing - direction _ _ = Nothing - --- this function can be changed so it never fails, not only avoid failure on invalid json -toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) -toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do - chatItem $ fromRight invalid $ dbParseACIContent itemContentText - where - member_ = toMaybeGroupMember userContactId memberRow_ - quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_ - deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_ - invalid = ACIContent msgDir $ CIInvalidJSON itemContentText - chatItem itemContent = case (itemContent, itemStatus, member_, fileStatus_) of - (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) -> - Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent (maybeCIFile fileStatus) - (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) -> - Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent Nothing - (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) -> - Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent (maybeCIFile fileStatus) - (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) -> - Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent Nothing - _ -> badItem - maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) - maybeCIFile fileStatus = - case (fileId_, fileName_, fileSize_, fileProtocol_) of - (Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol} - _ -> Nothing - cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup - cItem d chatDir ciStatus content file = - CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, reactions = [], file} - badItem = Left $ SEBadChatItem itemId - ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d - ciMeta content status = - let itemDeleted' = - if itemDeleted - then Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) - else Nothing - itemEdited' = fromMaybe False itemEdited - in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt - ciTimed :: Maybe CITimed - ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} - -toGroupChatItemList :: UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] -toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = - either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) -toGroupChatItemList _ _ _ = [] - -getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p] -getProtocolServers db User {userId} = - map toServerCfg - <$> DB.query - db - [sql| - SELECT host, port, key_hash, basic_auth, preset, tested, enabled - FROM protocol_servers - WHERE user_id = ? AND protocol = ?; - |] - (userId, decodeLatin1 $ strEncode protocol) - where - protocol = protocolTypeI @p - toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg p - toServerCfg (host, port, keyHash, auth_, preset, tested, enabled) = - let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_) - in ServerCfg {server, preset, tested, enabled} - -overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO () -overwriteProtocolServers db User {userId} servers = - checkConstraint SEUniqueID . ExceptT $ do - currentTs <- getCurrentTime - DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, protocol) - forM_ servers $ \ServerCfg {server, preset, tested, enabled} -> do - let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server - DB.execute - db - [sql| - INSERT INTO protocol_servers - (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?) - |] - ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs)) - pure $ Right () - where - protocol = decodeLatin1 $ strEncode $ protocolTypeI @p - -createCall :: DB.Connection -> User -> Call -> UTCTime -> IO () -createCall db user@User {userId} Call {contactId, callId, chatItemId, callState} callTs = do - currentTs <- getCurrentTime - deleteCalls db user contactId - DB.execute - db - [sql| - INSERT INTO calls - (contact_id, shared_call_id, chat_item_id, call_state, call_ts, user_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?) - |] - (contactId, callId, chatItemId, callState, callTs, userId, currentTs, currentTs) - -deleteCalls :: DB.Connection -> User -> ContactId -> IO () -deleteCalls db User {userId} contactId = do - DB.execute db "DELETE FROM calls WHERE user_id = ? AND contact_id = ?" (userId, contactId) - -getCalls :: DB.Connection -> IO [Call] -getCalls db = - map toCall - <$> DB.query_ - db - [sql| - SELECT - contact_id, shared_call_id, chat_item_id, call_state, call_ts - FROM calls - ORDER BY call_ts ASC - |] - where - toCall :: (ContactId, CallId, ChatItemId, CallState, UTCTime) -> Call - toCall (contactId, callId, chatItemId, callState, callTs) = Call {contactId, callId, chatItemId, callState, callTs} - -createCommand :: DB.Connection -> User -> Maybe Int64 -> CommandFunction -> IO CommandId -createCommand db User {userId} connId commandFunction = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - INSERT INTO commands (connection_id, command_function, command_status, user_id, created_at, updated_at) - VALUES (?,?,?,?,?,?) - |] - (connId, commandFunction, CSCreated, userId, currentTs, currentTs) - insertedRowId db - -setCommandConnId :: DB.Connection -> User -> CommandId -> Int64 -> IO () -setCommandConnId db User {userId} cmdId connId = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE commands - SET connection_id = ?, updated_at = ? - WHERE user_id = ? AND command_id = ? - |] - (connId, updatedAt, userId, cmdId) - -deleteCommand :: DB.Connection -> User -> CommandId -> IO () -deleteCommand db User {userId} cmdId = - DB.execute db "DELETE FROM commands WHERE user_id = ? AND command_id = ?" (userId, cmdId) - -updateCommandStatus :: DB.Connection -> User -> CommandId -> CommandStatus -> IO () -updateCommandStatus db User {userId} cmdId status = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE commands - SET command_status = ?, updated_at = ? - WHERE user_id = ? AND command_id = ? - |] - (status, updatedAt, userId, cmdId) - -getCommandDataByCorrId :: DB.Connection -> User -> ACorrId -> IO (Maybe CommandData) -getCommandDataByCorrId db User {userId} corrId = - maybeFirstRow toCommandData $ - DB.query - db - [sql| - SELECT command_id, connection_id, command_function, command_status - FROM commands - WHERE user_id = ? AND command_id = ? - |] - (userId, commandId corrId) - where - toCommandData :: (CommandId, Maybe Int64, CommandFunction, CommandStatus) -> CommandData - toCommandData (cmdId, cmdConnId, cmdFunction, cmdStatus) = CommandData {cmdId, cmdConnId, cmdFunction, cmdStatus} - -setConnConnReqInv :: DB.Connection -> User -> Int64 -> ConnReqInvitation -> IO () -setConnConnReqInv db User {userId} connId connReq = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE connections - SET conn_req_inv = ?, updated_at = ? - WHERE user_id = ? AND connection_id = ? - |] - (connReq, updatedAt, userId, connId) - -getXGrpMemIntroContDirect :: DB.Connection -> User -> Contact -> IO (Maybe (Int64, XGrpMemIntroCont)) -getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do - fmap join . maybeFirstRow toCont $ - DB.query - db - [sql| - SELECT ch.connection_id, g.group_id, m.group_member_id, m.member_id, c.conn_req_inv - FROM contacts ct - JOIN group_members m ON m.contact_id = ct.contact_id - LEFT JOIN connections c ON c.connection_id = ( - SELECT MAX(cc.connection_id) - FROM connections cc - WHERE cc.group_member_id = m.group_member_id - ) - JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group - JOIN group_members mh ON mh.group_id = g.group_id - LEFT JOIN connections ch ON ch.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.group_member_id = mh.group_member_id - ) - WHERE ct.user_id = ? AND ct.contact_id = ? AND ct.deleted = 0 AND mh.member_category = ? - |] - (userId, contactId, GCHostMember) - where - toCont :: (Int64, GroupId, GroupMemberId, MemberId, Maybe ConnReqInvitation) -> Maybe (Int64, XGrpMemIntroCont) - toCont (hostConnId, groupId, groupMemberId, memberId, connReq_) = case connReq_ of - Just groupConnReq -> Just (hostConnId, XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}) - _ -> Nothing - -getXGrpMemIntroContGroup :: DB.Connection -> User -> GroupMember -> IO (Maybe (Int64, ConnReqInvitation)) -getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do - fmap join . maybeFirstRow toCont $ - DB.query - db - [sql| - SELECT ch.connection_id, c.conn_req_inv - FROM group_members m - JOIN contacts ct ON ct.contact_id = m.contact_id - LEFT JOIN connections c ON c.connection_id = ( - SELECT MAX(cc.connection_id) - FROM connections cc - WHERE cc.contact_id = ct.contact_id - ) - JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group - JOIN group_members mh ON mh.group_id = g.group_id - LEFT JOIN connections ch ON ch.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.group_member_id = mh.group_member_id - ) - WHERE m.user_id = ? AND m.group_member_id = ? AND mh.member_category = ? AND ct.deleted = 0 - |] - (userId, groupMemberId, GCHostMember) - where - toCont :: (Int64, Maybe ConnReqInvitation) -> Maybe (Int64, ConnReqInvitation) - toCont (hostConnId, connReq_) = case connReq_ of - Just connReq -> Just (hostConnId, connReq) - _ -> Nothing - -getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)] -getTimedItems db User {userId} startTimedThreadCutoff = - mapMaybe toCIRefDeleteAt - <$> DB.query - db - [sql| - SELECT chat_item_id, contact_id, group_id, timed_delete_at - FROM chat_items - WHERE user_id = ? AND timed_delete_at IS NOT NULL AND timed_delete_at <= ? - |] - (userId, startTimedThreadCutoff) - where - toCIRefDeleteAt :: (ChatItemId, Maybe ContactId, Maybe GroupId, UTCTime) -> Maybe ((ChatRef, ChatItemId), UTCTime) - toCIRefDeleteAt = \case - (itemId, Just contactId, Nothing, deleteAt) -> Just ((ChatRef CTDirect contactId, itemId), deleteAt) - (itemId, Nothing, Just groupId, deleteAt) -> Just ((ChatRef CTGroup groupId, itemId), deleteAt) - _ -> Nothing - -getChatItemTTL :: DB.Connection -> User -> IO (Maybe Int64) -getChatItemTTL db User {userId} = - fmap join . maybeFirstRow fromOnly $ DB.query db "SELECT chat_item_ttl FROM settings WHERE user_id = ? LIMIT 1" (Only userId) - -setChatItemTTL :: DB.Connection -> User -> Maybe Int64 -> IO () -setChatItemTTL db User {userId} chatItemTTL = do - currentTs <- getCurrentTime - r :: (Maybe Int64) <- maybeFirstRow fromOnly $ DB.query db "SELECT 1 FROM settings WHERE user_id = ? LIMIT 1" (Only userId) - case r of - Just _ -> do - DB.execute - db - "UPDATE settings SET chat_item_ttl = ?, updated_at = ? WHERE user_id = ?" - (chatItemTTL, currentTs, userId) - Nothing -> do - DB.execute - db - "INSERT INTO settings (user_id, chat_item_ttl, created_at, updated_at) VALUES (?,?,?,?)" - (userId, chatItemTTL, currentTs, currentTs) - -getContactExpiredFileInfo :: DB.Connection -> User -> Contact -> UTCTime -> IO [CIFileInfo] -getContactExpiredFileInfo db User {userId} Contact {contactId} expirationDate = - map toFileInfo - <$> DB.query - db - (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ? AND i.created_at <= ?") - (userId, contactId, expirationDate) - -deleteContactExpiredCIs :: DB.Connection -> User -> Contact -> UTCTime -> IO () -deleteContactExpiredCIs db user@User {userId} ct@Contact {contactId} expirationDate = do - connIds <- getContactConnIds_ db user ct - forM_ connIds $ \connId -> - DB.execute db "DELETE FROM messages WHERE connection_id = ? AND created_at <= ?" (connId, expirationDate) - DB.execute db "DELETE FROM chat_item_reactions WHERE contact_id = ? AND created_at <= ?" (contactId, expirationDate) - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ? AND created_at <= ?" (userId, contactId, expirationDate) - -getGroupExpiredFileInfo :: DB.Connection -> User -> GroupInfo -> UTCTime -> UTCTime -> IO [CIFileInfo] -getGroupExpiredFileInfo db User {userId} GroupInfo {groupId} expirationDate createdAtCutoff = - map toFileInfo - <$> DB.query - db - (fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ? AND i.item_ts <= ? AND i.created_at <= ?") - (userId, groupId, expirationDate, createdAtCutoff) - -deleteGroupExpiredCIs :: DB.Connection -> User -> GroupInfo -> UTCTime -> UTCTime -> IO () -deleteGroupExpiredCIs db User {userId} GroupInfo {groupId} expirationDate createdAtCutoff = do - DB.execute db "DELETE FROM messages WHERE group_id = ? AND created_at <= ?" (groupId, min expirationDate createdAtCutoff) - DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ? AND reaction_ts <= ? AND created_at <= ?" (groupId, expirationDate, createdAtCutoff) - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND item_ts <= ? AND created_at <= ?" (userId, groupId, expirationDate, createdAtCutoff) - --- | Saves unique local display name based on passed displayName, suffixed with _N if required. --- This function should be called inside transaction. -withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO (Either StoreError a)) -> IO (Either StoreError a) -withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreateName` 20) - where - getLdnSuffix :: IO Int - getLdnSuffix = - maybe 0 ((+ 1) . fromOnly) . listToMaybe - <$> DB.queryNamed - db - [sql| - SELECT ldn_suffix FROM display_names - WHERE user_id = :user_id AND ldn_base = :display_name - ORDER BY ldn_suffix DESC - LIMIT 1 - |] - [":user_id" := userId, ":display_name" := displayName] - tryCreateName :: Int -> Int -> IO (Either StoreError a) - tryCreateName _ 0 = pure $ Left SEDuplicateName - tryCreateName ldnSuffix attempts = do - currentTs <- getCurrentTime - let ldn = displayName <> (if ldnSuffix == 0 then "" else T.pack $ '_' : show ldnSuffix) - E.try (insertName ldn currentTs) >>= \case - Right () -> action ldn - Left e - | DB.sqlError e == DB.ErrorConstraint -> tryCreateName (ldnSuffix + 1) (attempts - 1) - | otherwise -> E.throwIO e - where - insertName ldn ts = - DB.execute - db - [sql| - INSERT INTO display_names - (local_display_name, ldn_base, ldn_suffix, user_id, created_at, updated_at) - VALUES (?,?,?,?,?,?) - |] - (ldn, displayName, ldnSuffix, userId, ts, ts) - -createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a -createWithRandomId = createWithRandomBytes 12 - -createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a -createWithRandomBytes size gVar create = tryCreate 3 - where - tryCreate :: Int -> ExceptT StoreError IO a - tryCreate 0 = throwError SEUniqueID - tryCreate n = do - id' <- liftIO $ encodedRandomBytes gVar size - liftIO (E.try $ create id') >>= \case - Right x -> pure x - Left e - | DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1) - | otherwise -> throwError . SEInternalError $ show e - -encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString -encodedRandomBytes gVar = fmap B64.encode . randomBytes gVar - -randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString -randomBytes gVar = atomically . stateTVar gVar . randomBytesGenerate - --- These error type constructors must be added to mobile apps -data StoreError - = SEDuplicateName - | SEUserNotFound {userId :: UserId} - | SEUserNotFoundByName {contactName :: ContactName} - | SEUserNotFoundByContactId {contactId :: ContactId} - | SEUserNotFoundByGroupId {groupId :: GroupId} - | SEUserNotFoundByFileId {fileId :: FileTransferId} - | SEUserNotFoundByContactRequestId {contactRequestId :: Int64} - | SEContactNotFound {contactId :: ContactId} - | SEContactNotFoundByName {contactName :: ContactName} - | SEContactNotReady {contactName :: ContactName} - | SEDuplicateContactLink - | SEUserContactLinkNotFound - | SEContactRequestNotFound {contactRequestId :: Int64} - | SEContactRequestNotFoundByName {contactName :: ContactName} - | SEGroupNotFound {groupId :: GroupId} - | SEGroupNotFoundByName {groupName :: GroupName} - | SEGroupMemberNameNotFound {groupId :: GroupId, groupMemberName :: ContactName} - | SEGroupMemberNotFound {groupMemberId :: GroupMemberId} - | SEGroupWithoutUser - | SEDuplicateGroupMember - | SEGroupAlreadyJoined - | SEGroupInvitationNotFound - | SESndFileNotFound {fileId :: FileTransferId} - | SESndFileInvalid {fileId :: FileTransferId} - | SERcvFileNotFound {fileId :: FileTransferId} - | SERcvFileDescrNotFound {fileId :: FileTransferId} - | SEFileNotFound {fileId :: FileTransferId} - | SERcvFileInvalid {fileId :: FileTransferId} - | SERcvFileInvalidDescrPart - | SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId} - | SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId} - | SESndFileNotFoundXFTP {agentSndFileId :: AgentSndFileId} - | SERcvFileNotFoundXFTP {agentRcvFileId :: AgentRcvFileId} - | SEConnectionNotFound {agentConnId :: AgentConnId} - | SEConnectionNotFoundById {connId :: Int64} - | SEPendingConnectionNotFound {connId :: Int64} - | SEIntroNotFound - | SEUniqueID - | SEInternalError {message :: String} - | SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId} - | SEBadChatItem {itemId :: ChatItemId} - | SEChatItemNotFound {itemId :: ChatItemId} - | SEChatItemNotFoundByText {text :: Text} - | SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId} - | SEChatItemNotFoundByFileId {fileId :: FileTransferId} - | SEChatItemNotFoundByGroupId {groupId :: GroupId} - | SEProfileNotFound {profileId :: Int64} - | SEDuplicateGroupLink {groupInfo :: GroupInfo} - | SEGroupLinkNotFound {groupInfo :: GroupInfo} - | SEHostMemberIdNotFound {groupId :: Int64} - | SEContactNotFoundByFileId {fileId :: FileTransferId} - deriving (Show, Exception, Generic) - -instance ToJSON StoreError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SE" diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs new file mode 100644 index 0000000000..da685f4d75 --- /dev/null +++ b/src/Simplex/Chat/Store/Connections.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Connections + ( getConnectionEntity, + ) +where + +import Control.Applicative ((<|>)) +import Control.Monad.Except +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Time.Clock (UTCTime (..)) +import Database.SQLite.Simple ((:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import Simplex.Chat.Store.Files +import Simplex.Chat.Store.Groups +import Simplex.Chat.Store.Shared +import Simplex.Chat.Protocol +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow') + +getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity +getConnectionEntity db user@User {userId, userContactId} agentConnId = do + c@Connection {connType, entityId} <- getConnection_ + case entityId of + Nothing -> + if connType == ConnContact + then pure $ RcvDirectMsgConnection c Nothing + else throwError $ SEInternalError $ "connection " <> show connType <> " without entity" + Just entId -> + case connType of + ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ entId c + ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ entId c + ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ entId c + ConnRcvFile -> RcvFileConnection c <$> getRcvFileTransfer db user entId + ConnUserContact -> UserContactConnection c <$> getUserContact_ entId + where + getConnection_ :: ExceptT StoreError IO Connection + getConnection_ = ExceptT $ do + firstRow toConnection (SEConnectionNotFound agentConnId) $ + DB.query + db + [sql| + SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id, + conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter + FROM connections + WHERE user_id = ? AND agent_conn_id = ? + |] + (userId, agentConnId) + getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact + getContactRec_ contactId c = ExceptT $ do + toContact' contactId c + <$> DB.query + db + [sql| + SELECT + c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, c.via_group, c.contact_used, c.enable_ntfs, + p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts + FROM contacts c + JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id + WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0 + |] + (userId, contactId) + toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)] -> Either StoreError Contact + toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)] = + let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} + toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" + getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) + getGroupAndMember_ groupMemberId c = ExceptT $ do + firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $ + DB.query + db + [sql| + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + -- GroupInfo {membership} + mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + -- GroupInfo {membership = GroupMember {memberProfile}} + pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, + -- from GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences + FROM group_members m + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + JOIN groups g ON g.group_id = m.group_id + JOIN group_profiles gp USING (group_profile_id) + JOIN group_members mu ON g.group_id = mu.group_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? + |] + (groupMemberId, userId, userContactId) + toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember) + toGroupAndMember c (groupInfoRow :. memberRow) = + let groupInfo = toGroupInfo userContactId groupInfoRow + member = toGroupMember userContactId memberRow + in (groupInfo, (member :: GroupMember) {activeConn = Just c}) + getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer + getConnSndFileTransfer_ fileId Connection {connId} = + ExceptT $ + firstRow' (sndFileTransfer_ fileId connId) (SESndFileNotFound fileId) $ + DB.query + db + [sql| + SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.group_member_id, cs.local_display_name, m.local_display_name + FROM snd_files s + JOIN files f USING (file_id) + LEFT JOIN contacts cs USING (contact_id) + LEFT JOIN group_members m USING (group_member_id) + WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ? + |] + (userId, fileId, connId) + sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer + sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, contactName_, memberName_) = + case contactName_ <|> memberName_ of + Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId, groupMemberId} + Nothing -> Left $ SESndFileInvalid fileId + getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact + getUserContact_ userContactLinkId = ExceptT $ do + userContact_ + <$> DB.query + db + [sql| + SELECT conn_req_contact, group_id + FROM user_contact_links + WHERE user_id = ? AND user_contact_link_id = ? + |] + (userId, userContactLinkId) + where + userContact_ :: [(ConnReqContact, Maybe GroupId)] -> Either StoreError UserContact + userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId} + userContact_ _ = Left SEUserContactLinkNotFound diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs new file mode 100644 index 0000000000..27aeab7cf5 --- /dev/null +++ b/src/Simplex/Chat/Store/Direct.hs @@ -0,0 +1,689 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Simplex.Chat.Store.Direct + ( updateContact_, + updateContactProfile_, + updateContactProfile_', + deleteContactProfile_, + -- * Contacts and connections functions + getPendingContactConnection, + deletePendingContactConnection, + createDirectConnection, + createConnReqConnection, + getProfileById, + getConnReqContactXContactId, + createDirectContact, + deleteContactConnectionsAndFiles, + deleteContact, + deleteContactWithoutGroups, + setContactDeleted, + getDeletedContacts, + getContactByName, + getContact, + getContactIdByName, + updateContactProfile, + updateContactUserPreferences, + updateContactAlias, + updateContactConnectionAlias, + updateContactUsed, + updateContactUnreadChat, + updateGroupUnreadChat, + setConnectionVerified, + incConnectionAuthErrCounter, + setConnectionAuthErrCounter, + getUserContacts, + createOrUpdateContactRequest, + getContactRequest', + getContactRequest, + getContactRequestIdByName, + deleteContactRequest, + createAcceptedContact, + getUserByContactRequestId, + getPendingContactConnections, + getContactConnections, + getConnectionById, + getConnectionsContacts, + updateConnectionStatus, + updateContactSettings, + setConnConnReqInv, + ) +where + +import Control.Monad.Except +import Data.Either (rights) +import Data.Functor (($>)) +import Data.Int (Int64) +import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Text (Text) +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (ConnId, InvitationId, UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) + +getPendingContactConnection :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO PendingContactConnection +getPendingContactConnection db userId connId = do + ExceptT . firstRow toPendingContactConnection (SEPendingConnectionNotFound connId) $ + DB.query + db + [sql| + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at + FROM connections + WHERE user_id = ? + AND connection_id = ? + AND conn_type = ? + AND contact_id IS NULL + AND conn_level = 0 + AND via_contact IS NULL + |] + (userId, connId, ConnContact) + +deletePendingContactConnection :: DB.Connection -> UserId -> Int64 -> IO () +deletePendingContactConnection db userId connId = + DB.execute + db + [sql| + DELETE FROM connections + WHERE user_id = ? + AND connection_id = ? + AND conn_type = ? + AND contact_id IS NULL + AND conn_level = 0 + AND via_contact IS NULL + |] + (userId, connId, ConnContact) + +createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> IO PendingContactConnection +createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId = do + createdAt <- getCurrentTime + customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile + let pccConnStatus = ConnJoined + DB.execute + db + [sql| + INSERT INTO connections ( + user_id, agent_conn_id, conn_status, conn_type, + via_contact_uri_hash, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at + ) VALUES (?,?,?,?,?,?,?,?,?,?,?) + |] + ((userId, acId, pccConnStatus, ConnContact, cReqHash, xContactId) :. (customUserProfileId, isJust groupLinkId, groupLinkId, createdAt, createdAt)) + pccConnId <- insertedRowId db + pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, groupLinkId, customUserProfileId, connReqInv = Nothing, localAlias = "", createdAt, updatedAt = createdAt} + +getConnReqContactXContactId :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId) +getConnReqContactXContactId db user@User {userId} cReqHash = do + getContact' >>= \case + c@(Just _) -> pure (c, Nothing) + Nothing -> (Nothing,) <$> getXContactId + where + getContact' :: IO (Maybe Contact) + getContact' = + maybeFirstRow (toContact user) $ + DB.query + db + [sql| + SELECT + -- Contact + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + -- Connection + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, + c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM contacts ct + JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id + JOIN connections c ON c.contact_id = ct.contact_id + WHERE ct.user_id = ? AND c.via_contact_uri_hash = ? AND ct.deleted = 0 + ORDER BY c.connection_id DESC + LIMIT 1 + |] + (userId, cReqHash) + getXContactId :: IO (Maybe XContactId) + getXContactId = + maybeFirstRow fromOnly $ + DB.query + db + "SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1" + (userId, cReqHash) + +createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> IO PendingContactConnection +createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile = do + createdAt <- getCurrentTime + customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile + DB.execute + db + [sql| + INSERT INTO connections + (user_id, agent_conn_id, conn_req_inv, conn_status, conn_type, custom_user_profile_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?) + |] + (userId, acId, cReq, pccConnStatus, ConnContact, customUserProfileId, createdAt, createdAt) + pccConnId <- insertedRowId db + pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, viaUserContactLink = Nothing, groupLinkId = Nothing, customUserProfileId, connReqInv = Just cReq, localAlias = "", createdAt, updatedAt = createdAt} + +createIncognitoProfile_ :: DB.Connection -> UserId -> UTCTime -> Profile -> IO Int64 +createIncognitoProfile_ db userId createdAt Profile {displayName, fullName, image} = do + DB.execute + db + [sql| + INSERT INTO contact_profiles (display_name, full_name, image, user_id, incognito, created_at, updated_at) + VALUES (?,?,?,?,?,?,?) + |] + (displayName, fullName, image, userId, Just True, createdAt, createdAt) + insertedRowId db + +createDirectContact :: DB.Connection -> User -> Connection -> Profile -> ExceptT StoreError IO Contact +createDirectContact db user@User {userId} activeConn@Connection {connId, localAlias} p@Profile {preferences} = do + createdAt <- liftIO getCurrentTime + (localDisplayName, contactId, profileId) <- createContact_ db userId connId p localAlias Nothing createdAt (Just createdAt) + let profile = toLocalProfile profileId p localAlias + userPreferences = emptyChatPrefs + mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt, updatedAt = createdAt, chatTs = Just createdAt} + +deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO () +deleteContactConnectionsAndFiles db userId Contact {contactId} = do + DB.execute + db + [sql| + DELETE FROM connections WHERE connection_id IN ( + SELECT connection_id + FROM connections c + JOIN contacts ct ON ct.contact_id = c.contact_id + WHERE ct.user_id = ? AND ct.contact_id = ? + ) + |] + (userId, contactId) + DB.execute db "DELETE FROM files WHERE user_id = ? AND contact_id = ?" (userId, contactId) + +deleteContact :: DB.Connection -> User -> Contact -> IO () +deleteContact db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) + ctMember :: (Maybe ContactId) <- maybeFirstRow fromOnly $ DB.query db "SELECT contact_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId) + if isNothing ctMember + then do + deleteContactProfile_ db userId contactId + DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + else do + currentTs <- getCurrentTime + DB.execute db "UPDATE group_members SET contact_id = NULL, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId) + DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId) + forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId + +-- should only be used if contact is not member of any groups +deleteContactWithoutGroups :: DB.Connection -> User -> Contact -> IO () +deleteContactWithoutGroups db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) + deleteContactProfile_ db userId contactId + DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId) + forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId + +setContactDeleted :: DB.Connection -> User -> Contact -> IO () +setContactDeleted db User {userId} Contact {contactId} = do + currentTs <- getCurrentTime + DB.execute db "UPDATE contacts SET deleted = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId) + +getDeletedContacts :: DB.Connection -> User -> IO [Contact] +getDeletedContacts db user@User {userId} = do + contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 1" (Only userId) + rights <$> mapM (runExceptT . getDeletedContact db user) contactIds + +getDeletedContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact +getDeletedContact db user contactId = getContact_ db user contactId True + +deleteContactProfile_ :: DB.Connection -> UserId -> ContactId -> IO () +deleteContactProfile_ db userId contactId = + DB.execute + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT contact_profile_id + FROM contacts + WHERE user_id = ? AND contact_id = ? + ) + |] + (userId, contactId) + +updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact +updateContactProfile db user@User {userId} c p' + | displayName == newName = do + liftIO $ updateContactProfile_ db userId profileId p' + pure c {profile, mergedPreferences} + | otherwise = + ExceptT . withLocalDisplayName db userId newName $ \ldn -> do + currentTs <- getCurrentTime + updateContactProfile_' db userId profileId p' currentTs + updateContact_ db userId contactId localDisplayName ldn currentTs + pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} + where + Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, activeConn, userPreferences} = c + Profile {displayName = newName, preferences} = p' + profile = toLocalProfile profileId p' localAlias + mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + +updateContactUserPreferences :: DB.Connection -> User -> Contact -> Preferences -> IO Contact +updateContactUserPreferences db user@User {userId} c@Contact {contactId, activeConn} userPreferences = do + updatedAt <- getCurrentTime + DB.execute + db + "UPDATE contacts SET user_preferences = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" + (userPreferences, updatedAt, userId, contactId) + let mergedPreferences = contactUserPreferences user userPreferences (preferences' c) $ connIncognito activeConn + pure $ c {mergedPreferences, userPreferences} + +updateContactAlias :: DB.Connection -> UserId -> Contact -> LocalAlias -> IO Contact +updateContactAlias db userId c@Contact {profile = lp@LocalProfile {profileId}} localAlias = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE contact_profiles + SET local_alias = ?, updated_at = ? + WHERE user_id = ? AND contact_profile_id = ? + |] + (localAlias, updatedAt, userId, profileId) + pure $ (c :: Contact) {profile = lp {localAlias}} + +updateContactConnectionAlias :: DB.Connection -> UserId -> PendingContactConnection -> LocalAlias -> IO PendingContactConnection +updateContactConnectionAlias db userId conn localAlias = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE connections + SET local_alias = ?, updated_at = ? + WHERE user_id = ? AND connection_id = ? + |] + (localAlias, updatedAt, userId, pccConnId conn) + pure (conn :: PendingContactConnection) {localAlias} + +updateContactUsed :: DB.Connection -> User -> Contact -> IO () +updateContactUsed db User {userId} Contact {contactId} = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (updatedAt, userId, contactId) + +updateContactUnreadChat :: DB.Connection -> User -> Contact -> Bool -> IO () +updateContactUnreadChat db User {userId} Contact {contactId} unreadChat = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE contacts SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" (unreadChat, updatedAt, userId, contactId) + +updateGroupUnreadChat :: DB.Connection -> User -> GroupInfo -> Bool -> IO () +updateGroupUnreadChat db User {userId} GroupInfo {groupId} unreadChat = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE groups SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (unreadChat, updatedAt, userId, groupId) + +setConnectionVerified :: DB.Connection -> User -> Int64 -> Maybe Text -> IO () +setConnectionVerified db User {userId} connId code = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE connections SET security_code = ?, security_code_verified_at = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (code, code $> updatedAt, updatedAt, userId, connId) + +incConnectionAuthErrCounter :: DB.Connection -> User -> Connection -> IO Int +incConnectionAuthErrCounter db User {userId} Connection {connId, authErrCounter} = do + updatedAt <- getCurrentTime + (counter_ :: Maybe Int) <- maybeFirstRow fromOnly $ DB.query db "SELECT auth_err_counter FROM connections WHERE user_id = ? AND connection_id = ?" (userId, connId) + let counter' = fromMaybe authErrCounter counter_ + 1 + DB.execute db "UPDATE connections SET auth_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter', updatedAt, userId, connId) + pure counter' + +setConnectionAuthErrCounter :: DB.Connection -> User -> Connection -> Int -> IO () +setConnectionAuthErrCounter db User {userId} Connection {connId} counter = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE connections SET auth_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter, updatedAt, userId, connId) + +updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO () +updateContactProfile_ db userId profileId profile = do + currentTs <- getCurrentTime + updateContactProfile_' db userId profileId profile currentTs + +updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO () +updateContactProfile_' db userId profileId Profile {displayName, fullName, image, contactLink, preferences} updatedAt = do + DB.execute + db + [sql| + UPDATE contact_profiles + SET display_name = ?, full_name = ?, image = ?, contact_link = ?, preferences = ?, updated_at = ? + WHERE user_id = ? AND contact_profile_id = ? + |] + (displayName, fullName, image, contactLink, preferences, updatedAt, userId, profileId) + +updateContact_ :: DB.Connection -> UserId -> Int64 -> ContactName -> ContactName -> UTCTime -> IO () +updateContact_ db userId contactId displayName newName updatedAt = do + DB.execute + db + "UPDATE contacts SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" + (newName, updatedAt, userId, contactId) + DB.execute + db + "UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" + (newName, updatedAt, userId, contactId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (displayName, userId) + +getContactByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Contact +getContactByName db user localDisplayName = do + cId <- getContactIdByName db user localDisplayName + getContact db user cId + +getUserContacts :: DB.Connection -> User -> IO [Contact] +getUserContacts db user@User {userId} = do + contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId) + rights <$> mapM (runExceptT . getContact db user) contactIds + +createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest +createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profile {displayName, fullName, image, contactLink, preferences} xContactId_ = + liftIO (maybeM getContact' xContactId_) >>= \case + Just contact -> pure $ CORContact contact + Nothing -> CORRequest <$> createOrUpdate_ + where + maybeM = maybe (pure Nothing) + createOrUpdate_ :: ExceptT StoreError IO UserContactRequest + createOrUpdate_ = do + cReqId <- + ExceptT $ + maybeM getContactRequestByXContactId xContactId_ >>= \case + Nothing -> createContactRequest + Just cr -> updateContactRequest cr $> Right (contactRequestId (cr :: UserContactRequest)) + getContactRequest db user cReqId + createContactRequest :: IO (Either StoreError Int64) + createContactRequest = do + currentTs <- getCurrentTime + withLocalDisplayName db userId displayName (fmap Right . createContactRequest_ currentTs) + where + createContactRequest_ currentTs ldn = do + DB.execute + db + "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + [sql| + INSERT INTO contact_requests + (user_contact_link_id, agent_invitation_id, contact_profile_id, local_display_name, user_id, created_at, updated_at, xcontact_id) + VALUES (?,?,?,?,?,?,?,?) + |] + (userContactLinkId, invId, profileId, ldn, userId, currentTs, currentTs, xContactId_) + insertedRowId db + getContact' :: XContactId -> IO (Maybe Contact) + getContact' xContactId = + maybeFirstRow (toContact user) $ + DB.query + db + [sql| + SELECT + -- Contact + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + -- Connection + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, + c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM contacts ct + JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id + LEFT JOIN connections c ON c.contact_id = ct.contact_id + WHERE ct.user_id = ? AND ct.xcontact_id = ? AND ct.deleted = 0 + ORDER BY c.connection_id DESC + LIMIT 1 + |] + (userId, xContactId) + getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest) + getContactRequestByXContactId xContactId = + maybeFirstRow toContactRequest $ + DB.query + db + [sql| + SELECT + cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id, + c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at + FROM contact_requests cr + JOIN connections c USING (user_contact_link_id) + JOIN contact_profiles p USING (contact_profile_id) + WHERE cr.user_id = ? + AND cr.xcontact_id = ? + LIMIT 1 + |] + (userId, xContactId) + updateContactRequest :: UserContactRequest -> IO (Either StoreError ()) + updateContactRequest UserContactRequest {contactRequestId = cReqId, localDisplayName = oldLdn, profile = Profile {displayName = oldDisplayName}} = do + currentTs <- liftIO getCurrentTime + updateProfile currentTs + if displayName == oldDisplayName + then Right <$> DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, currentTs, userId, cReqId) + else withLocalDisplayName db userId displayName $ \ldn -> + Right <$> do + DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, ldn, currentTs, userId, cReqId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (oldLdn, userId) + where + updateProfile currentTs = + DB.execute + db + [sql| + UPDATE contact_profiles + SET display_name = ?, + full_name = ?, + image = ?, + contact_link = ?, + updated_at = ? + WHERE contact_profile_id IN ( + SELECT contact_profile_id + FROM contact_requests + WHERE user_id = ? + AND contact_request_id = ? + ) + |] + (displayName, fullName, image, contactLink, currentTs, userId, cReqId) + +getContactRequest' :: DB.Connection -> Int64 -> ExceptT StoreError IO (User, UserContactRequest) +getContactRequest' db contactRequestId = do + user <- getUserByContactRequestId db contactRequestId + (user,) <$> getContactRequest db user contactRequestId + +getContactRequest :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO UserContactRequest +getContactRequest db User {userId} contactRequestId = + ExceptT . firstRow toContactRequest (SEContactRequestNotFound contactRequestId) $ + DB.query + db + [sql| + SELECT + cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id, + c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at + FROM contact_requests cr + JOIN connections c USING (user_contact_link_id) + JOIN contact_profiles p USING (contact_profile_id) + WHERE cr.user_id = ? + AND cr.contact_request_id = ? + |] + (userId, contactRequestId) + +getContactRequestIdByName :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Int64 +getContactRequestIdByName db userId cName = + ExceptT . firstRow fromOnly (SEContactRequestNotFoundByName cName) $ + DB.query db "SELECT contact_request_id FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, cName) + +deleteContactRequest :: DB.Connection -> User -> Int64 -> IO () +deleteContactRequest db User {userId} contactRequestId = do + DB.execute + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT contact_profile_id + FROM contact_requests + WHERE user_id = ? AND contact_request_id = ? + ) + |] + (userId, contactRequestId) + DB.execute + db + [sql| + DELETE FROM display_names + WHERE user_id = ? AND local_display_name = ( + SELECT local_display_name FROM contact_requests + WHERE user_id = ? AND contact_request_id = ? + ) + |] + (userId, userId, contactRequestId) + DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId) + +createAcceptedContact :: DB.Connection -> User -> ConnId -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> IO Contact +createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do + DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + createdAt <- getCurrentTime + customUserProfileId <- forM incognitoProfile $ \case + NewIncognito p -> createIncognitoProfile_ db userId createdAt p + ExistingIncognito LocalProfile {profileId = pId} -> pure pId + let userPreferences = fromMaybe emptyChatPrefs $ incognitoProfile >> preferences + DB.execute + db + "INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, chat_ts, xcontact_id) VALUES (?,?,?,?,?,?,?,?,?)" + (userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, createdAt, xContactId) + contactId <- insertedRowId db + activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing (Just userContactLinkId) customUserProfileId 0 createdAt + let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt, chatTs = Just createdAt} + +getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64 +getContactIdByName db User {userId} cName = + ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $ + DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ? AND deleted = 0" (userId, cName) + +getContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact +getContact db user contactId = getContact_ db user contactId False + +getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact +getContact_ db user@User {userId} contactId deleted = + ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $ + DB.query + db + [sql| + SELECT + -- Contact + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + -- Connection + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, + c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM contacts ct + JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id + LEFT JOIN connections c ON c.contact_id = ct.contact_id + WHERE ct.user_id = ? AND ct.contact_id = ? + AND ct.deleted = ? + AND c.connection_id = ( + SELECT cc_connection_id FROM ( + SELECT + cc.connection_id AS cc_connection_id, + (CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord + FROM connections cc + WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id + ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC + LIMIT 1 + ) + ) + |] + (userId, contactId, deleted, ConnReady, ConnSndReady) + +getUserByContactRequestId :: DB.Connection -> Int64 -> ExceptT StoreError IO User +getUserByContactRequestId db contactRequestId = + ExceptT . firstRow toUser (SEUserNotFoundByContactRequestId contactRequestId) $ + DB.query db (userQuery <> " JOIN contact_requests cr ON cr.user_id = u.user_id WHERE cr.contact_request_id = ?") (Only contactRequestId) + +getPendingContactConnections :: DB.Connection -> User -> IO [PendingContactConnection] +getPendingContactConnections db User {userId} = do + map toPendingContactConnection + <$> DB.queryNamed + db + [sql| + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at + FROM connections + WHERE user_id = :user_id + AND conn_type = :conn_type + AND contact_id IS NULL + |] + [":user_id" := userId, ":conn_type" := ConnContact] + +getContactConnections :: DB.Connection -> UserId -> Contact -> ExceptT StoreError IO [Connection] +getContactConnections db userId Contact {contactId} = + connections =<< liftIO getConnections_ + where + getConnections_ = + DB.query + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM connections c + JOIN contacts ct ON ct.contact_id = c.contact_id + WHERE c.user_id = ? AND ct.user_id = ? AND ct.contact_id = ? + |] + (userId, userId, contactId) + connections [] = throwError $ SEContactNotFound contactId + connections rows = pure $ map toConnection rows + + + + +getConnectionById :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Connection +getConnectionById db User {userId} connId = ExceptT $ do + firstRow toConnection (SEConnectionNotFoundById connId) $ + DB.query + db + [sql| + SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id, + conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter + FROM connections + WHERE user_id = ? AND connection_id = ? + |] + (userId, connId) + +getConnectionsContacts :: DB.Connection -> [ConnId] -> IO [ContactRef] +getConnectionsContacts db agentConnIds = do + DB.execute_ db "DROP TABLE IF EXISTS temp.conn_ids" + DB.execute_ db "CREATE TABLE temp.conn_ids (conn_id BLOB)" + DB.executeMany db "INSERT INTO temp.conn_ids (conn_id) VALUES (?)" $ map Only agentConnIds + conns <- + map toContactRef + <$> DB.query + db + [sql| + SELECT ct.contact_id, c.connection_id, c.agent_conn_id, ct.local_display_name + FROM contacts ct + JOIN connections c ON c.contact_id = ct.contact_id + WHERE c.agent_conn_id IN (SELECT conn_id FROM temp.conn_ids) + AND c.conn_type = ? + AND ct.deleted = 0 + |] + (Only ConnContact) + DB.execute_ db "DROP TABLE temp.conn_ids" + pure conns + where + toContactRef :: (ContactId, Int64, ConnId, ContactName) -> ContactRef + toContactRef (contactId, connId, acId, localDisplayName) = ContactRef {contactId, connId, agentConnId = AgentConnId acId, localDisplayName} + +updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO () +updateConnectionStatus db Connection {connId} connStatus = do + currentTs <- getCurrentTime + DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId) + +updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () +updateContactSettings db User {userId} contactId ChatSettings {enableNtfs} = + DB.execute db "UPDATE contacts SET enable_ntfs = ? WHERE user_id = ? AND contact_id = ?" (enableNtfs, userId, contactId) + +setConnConnReqInv :: DB.Connection -> User -> Int64 -> ConnReqInvitation -> IO () +setConnConnReqInv db User {userId} connId connReq = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE connections + SET conn_req_inv = ?, updated_at = ? + WHERE user_id = ? AND connection_id = ? + |] + (connReq, updatedAt, userId, connId) diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs new file mode 100644 index 0000000000..49e149c7f0 --- /dev/null +++ b/src/Simplex/Chat/Store/Files.hs @@ -0,0 +1,868 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Files + ( getLiveSndFileTransfers, + getLiveRcvFileTransfers, + getPendingSndChunks, + createSndDirectFileTransfer, + createSndDirectFTConnection, + createSndGroupFileTransfer, + createSndGroupFileTransferConnection, + createSndDirectInlineFT, + createSndGroupInlineFT, + updateSndDirectFTDelivery, + updateSndGroupFTDelivery, + getSndFTViaMsgDelivery, + createSndFileTransferXFTP, + createSndFTDescrXFTP, + setSndFTPrivateSndDescr, + updateSndFTDescrXFTP, + createExtraSndFTDescrs, + updateSndFTDeliveryXFTP, + setSndFTAgentDeleted, + getXFTPSndFileDBId, + getXFTPRcvFileDBId, + updateFileCancelled, + updateCIFileStatus, + getSharedMsgIdByFileId, + getFileIdBySharedMsgId, + getGroupFileIdBySharedMsgId, + getDirectFileIdBySharedMsgId, + getChatRefByFileId, + updateSndFileStatus, + createSndFileChunk, + updateSndFileChunkMsg, + updateSndFileChunkSent, + deleteSndFileChunks, + createRcvFileTransfer, + createRcvGroupFileTransfer, + appendRcvFD, + getRcvFileDescrByFileId, + updateRcvFileAgentId, + getRcvFileTransferById, + getRcvFileTransfer, + acceptRcvFileTransfer, + getContactByFileId, + acceptRcvInlineFT, + startRcvInlineFT, + xftpAcceptRcvFT, + setRcvFileToReceive, + getRcvFilesToReceive, + setRcvFTAgentDeleted, + updateRcvFileStatus, + createRcvFileChunk, + updatedRcvFileChunkStored, + deleteRcvFileChunks, + updateFileTransferChatItemId, + getFileTransfer, + getFileTransferProgress, + getFileTransferMeta, + getSndFileTransfer, + getSndFileTransfers, + getContactFileInfo, + updateDirectCIFileStatus, + ) +where + +import Control.Applicative ((<|>)) +import Control.Monad.Except +import Data.Either (rights) +import Data.Int (Int64) +import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.Text (Text) +import Data.Time (addUTCTime) +import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay) +import Data.Type.Equality +import Database.SQLite.Simple (Only (..), (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Messages +import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Shared +import Simplex.Chat.Messages +import Simplex.Chat.Messages.CIContent +import Simplex.Chat.Protocol +import Simplex.Chat.Types +import Simplex.Chat.Util (week) +import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) + +getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] +getLiveSndFileTransfers db User {userId} = do + cutoffTs <- addUTCTime (- week) <$> getCurrentTime + fileIds :: [Int64] <- + map fromOnly + <$> DB.query + db + [sql| + SELECT DISTINCT f.file_id + FROM files f + JOIN snd_files s USING (file_id) + WHERE f.user_id = ? + AND s.file_status IN (?, ?, ?) + AND s.file_descr_id IS NULL + AND s.file_inline IS NULL + AND s.created_at > ? + |] + (userId, FSNew, FSAccepted, FSConnected, cutoffTs) + concatMap (filter liveTransfer) . rights <$> mapM (getSndFileTransfers_ db userId) fileIds + where + liveTransfer :: SndFileTransfer -> Bool + liveTransfer SndFileTransfer {fileStatus} = fileStatus `elem` [FSNew, FSAccepted, FSConnected] + +getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer] +getLiveRcvFileTransfers db user@User {userId} = do + cutoffTs <- addUTCTime (- week) <$> getCurrentTime + fileIds :: [Int64] <- + map fromOnly + <$> DB.query + db + [sql| + SELECT f.file_id + FROM files f + JOIN rcv_files r USING (file_id) + WHERE f.user_id = ? AND r.file_status IN (?, ?) + AND r.rcv_file_inline IS NULL + AND r.file_descr_id IS NULL + AND r.created_at > ? + |] + (userId, FSAccepted, FSConnected, cutoffTs) + rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds + +getPendingSndChunks :: DB.Connection -> Int64 -> Int64 -> IO [Integer] +getPendingSndChunks db fileId connId = + map fromOnly + <$> DB.query + db + [sql| + SELECT chunk_number + FROM snd_file_chunks + WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id IS NULL + ORDER BY chunk_number + |] + (fileId, connId) + +createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> IO FileTransferMeta +createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize = do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)" + ((userId, contactId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs)) + fileId <- insertedRowId db + forM_ acId_ $ \acId -> do + Connection {connId} <- createSndFileConnection_ db userId fileId acId + let fileStatus = FSNew + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (fileId, fileStatus, fileInline, connId, currentTs, currentTs) + pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} + +createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> IO () +createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do + currentTs <- getCurrentTime + Connection {connId} <- createSndFileConnection_ db userId fileId acId + setCommandConnId db user cmdId connId + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (fileId, FSAccepted, connId, currentTs, currentTs) + +createSndGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO FileTransferMeta +createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize, fileInline} chunkSize = do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)" + ((userId, groupId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs)) + fileId <- insertedRowId db + pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} + +createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> IO () +createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} = do + currentTs <- getCurrentTime + Connection {connId} <- createSndFileConnection_ db userId fileId acId + setCommandConnId db user cmdId connId + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs) + +createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO SndFileTransfer +createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do + currentTs <- getCurrentTime + let fileStatus = FSConnected + fileInline' = Just $ fromMaybe IFMOffer fileInline + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (fileId, fileStatus, fileInline', connId, currentTs, currentTs) + pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Nothing, fileStatus, fileDescrId = Nothing, fileInline = fileInline'} + +createSndGroupInlineFT :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> IO SndFileTransfer +createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Connection {connId, agentConnId} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do + currentTs <- getCurrentTime + let fileStatus = FSConnected + fileInline' = Just $ fromMaybe IFMOffer fileInline + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (fileId, fileStatus, fileInline', connId, groupMemberId, currentTs, currentTs) + pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Just groupMemberId, fileStatus, fileDescrId = Nothing, fileInline = fileInline'} + +updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> IO () +updateSndDirectFTDelivery db Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = + DB.execute + db + "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" + (msgDeliveryId, connId, fileId) + +updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO () +updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId = + DB.execute + db + "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE group_member_id = ? AND connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" + (msgDeliveryId, groupMemberId, connId, fileId) + +getSndFTViaMsgDelivery :: DB.Connection -> User -> Connection -> AgentMsgId -> IO (Maybe SndFileTransfer) +getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMsgId = do + (sndFileTransfer_ <=< listToMaybe) + <$> DB.query + db + [sql| + SELECT s.file_id, s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.group_member_id, c.local_display_name, m.local_display_name + FROM msg_deliveries d + JOIN snd_files s ON s.connection_id = d.connection_id AND s.last_inline_msg_delivery_id = d.msg_delivery_id + JOIN files f ON f.file_id = s.file_id + LEFT JOIN contacts c USING (contact_id) + LEFT JOIN group_members m USING (group_member_id) + WHERE d.connection_id = ? AND d.agent_msg_id = ? AND f.user_id = ? + AND (s.file_descr_id IS NOT NULL OR s.file_inline IS NOT NULL) + |] + (connId, agentMsgId, userId) + where + sndFileTransfer_ :: (Int64, FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Maybe SndFileTransfer + sndFileTransfer_ (fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, contactName_, memberName_) = + (\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId}) + <$> (contactName_ <|> memberName_) + +createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta +createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do + currentTs <- getCurrentTime + let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False} + DB.execute + db + "INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)" + (contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs)) + fileId <- insertedRowId db + pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False} + +createSndFTDescrXFTP :: DB.Connection -> User -> Maybe GroupMember -> Connection -> FileTransferMeta -> FileDescr -> IO () +createSndFTDescrXFTP db User {userId} m Connection {connId} FileTransferMeta {fileId} FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do + currentTs <- getCurrentTime + let fileStatus = FSNew + DB.execute + db + "INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs) + fileDescrId <- insertedRowId db + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, file_descr_id, group_member_id, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (fileId, fileStatus, fileDescrId, groupMemberId' <$> m, connId, currentTs, currentTs) + +setSndFTPrivateSndDescr :: DB.Connection -> User -> FileTransferId -> Text -> IO () +setSndFTPrivateSndDescr db User {userId} fileId sfdText = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE files SET private_snd_file_descr = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" + (sfdText, currentTs, userId, fileId) + +updateSndFTDescrXFTP :: DB.Connection -> User -> SndFileTransfer -> Text -> IO () +updateSndFTDescrXFTP db user@User {userId} sft@SndFileTransfer {fileId, fileDescrId} rfdText = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE xftp_file_descriptions + SET file_descr_text = ?, file_descr_part_no = ?, file_descr_complete = ?, updated_at = ? + WHERE user_id = ? AND file_descr_id = ? + |] + (rfdText, 1 :: Int, True, currentTs, userId, fileDescrId) + updateCIFileStatus db user fileId $ CIFSSndTransfer 1 1 + updateSndFileStatus db sft FSConnected + +createExtraSndFTDescrs :: DB.Connection -> User -> FileTransferId -> [Text] -> IO () +createExtraSndFTDescrs db User {userId} fileId rfdTexts = do + currentTs <- getCurrentTime + forM_ rfdTexts $ \rfdText -> + DB.execute + db + "INSERT INTO extra_xftp_file_descriptions (file_id, user_id, file_descr_text, created_at, updated_at) VALUES (?,?,?,?,?)" + (fileId, userId, rfdText, currentTs, currentTs) + +updateSndFTDeliveryXFTP :: DB.Connection -> SndFileTransfer -> Int64 -> IO () +updateSndFTDeliveryXFTP db SndFileTransfer {connId, fileId, fileDescrId} msgDeliveryId = + DB.execute + db + "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_descr_id = ?" + (msgDeliveryId, connId, fileId, fileDescrId) + +setSndFTAgentDeleted :: DB.Connection -> User -> FileTransferId -> IO () +setSndFTAgentDeleted db User {userId} fileId = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE files SET agent_snd_file_deleted = 1, updated_at = ? WHERE user_id = ? AND file_id = ?" + (currentTs, userId, fileId) + +getXFTPSndFileDBId :: DB.Connection -> User -> AgentSndFileId -> ExceptT StoreError IO FileTransferId +getXFTPSndFileDBId db User {userId} aSndFileId = + ExceptT . firstRow fromOnly (SESndFileNotFoundXFTP aSndFileId) $ + DB.query db "SELECT file_id FROM files WHERE user_id = ? AND agent_snd_file_id = ?" (userId, aSndFileId) + +getXFTPRcvFileDBId :: DB.Connection -> AgentRcvFileId -> ExceptT StoreError IO FileTransferId +getXFTPRcvFileDBId db aRcvFileId = + ExceptT . firstRow fromOnly (SERcvFileNotFoundXFTP aRcvFileId) $ + DB.query db "SELECT file_id FROM rcv_files WHERE agent_rcv_file_id = ?" (Only aRcvFileId) + +updateFileCancelled :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () +updateFileCancelled db User {userId} fileId ciFileStatus = do + currentTs <- getCurrentTime + DB.execute db "UPDATE files SET cancelled = 1, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) + +updateCIFileStatus :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () +updateCIFileStatus db User {userId} fileId ciFileStatus = do + currentTs <- getCurrentTime + DB.execute db "UPDATE files SET ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) + +getSharedMsgIdByFileId :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO SharedMsgId +getSharedMsgIdByFileId db userId fileId = + ExceptT . firstRow fromOnly (SESharedMsgIdNotFoundByFileId fileId) $ + DB.query + db + [sql| + SELECT i.shared_msg_id + FROM chat_items i + JOIN files f ON f.chat_item_id = i.chat_item_id + WHERE f.user_id = ? AND f.file_id = ? + |] + (userId, fileId) + +getFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 +getFileIdBySharedMsgId db userId contactId sharedMsgId = + ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ + DB.query + db + [sql| + SELECT f.file_id + FROM files f + JOIN chat_items i ON i.chat_item_id = f.chat_item_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ? + |] + (userId, contactId, sharedMsgId) + +getGroupFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 +getGroupFileIdBySharedMsgId db userId groupId sharedMsgId = + ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ + DB.query + db + [sql| + SELECT f.file_id + FROM files f + JOIN chat_items i ON i.chat_item_id = f.chat_item_id + WHERE i.user_id = ? AND i.group_id = ? AND i.shared_msg_id = ? + |] + (userId, groupId, sharedMsgId) + +getDirectFileIdBySharedMsgId :: DB.Connection -> User -> Contact -> SharedMsgId -> ExceptT StoreError IO Int64 +getDirectFileIdBySharedMsgId db User {userId} Contact {contactId} sharedMsgId = + ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ + DB.query + db + [sql| + SELECT f.file_id + FROM files f + JOIN chat_items i ON i.chat_item_id = f.chat_item_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ? + |] + (userId, contactId, sharedMsgId) + +getChatRefByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO ChatRef +getChatRefByFileId db User {userId} fileId = + liftIO getChatRef >>= \case + [(Just contactId, Nothing)] -> pure $ ChatRef CTDirect contactId + [(Nothing, Just groupId)] -> pure $ ChatRef CTGroup groupId + _ -> throwError $ SEInternalError "could not retrieve chat ref by file id" + where + getChatRef = + DB.query + db + [sql| + SELECT contact_id, group_id + FROM files + WHERE user_id = ? AND file_id = ? + LIMIT 1 + |] + (userId, fileId) + +createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection +createSndFileConnection_ db userId fileId agentConnId = do + currentTs <- getCurrentTime + createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing Nothing Nothing 0 currentTs + +updateSndFileStatus :: DB.Connection -> SndFileTransfer -> FileStatus -> IO () +updateSndFileStatus db SndFileTransfer {fileId, connId} status = do + currentTs <- getCurrentTime + DB.execute db "UPDATE snd_files SET file_status = ?, updated_at = ? WHERE file_id = ? AND connection_id = ?" (status, currentTs, fileId, connId) + +createSndFileChunk :: DB.Connection -> SndFileTransfer -> IO (Maybe Integer) +createSndFileChunk db SndFileTransfer {fileId, connId, fileSize, chunkSize} = do + chunkNo <- getLastChunkNo + insertChunk chunkNo + pure chunkNo + where + getLastChunkNo = do + ns <- DB.query db "SELECT chunk_number FROM snd_file_chunks WHERE file_id = ? AND connection_id = ? AND chunk_sent = 1 ORDER BY chunk_number DESC LIMIT 1" (fileId, connId) + pure $ case map fromOnly ns of + [] -> Just 1 + n : _ -> if n * chunkSize >= fileSize then Nothing else Just (n + 1) + insertChunk chunkNo_ = forM_ chunkNo_ $ \chunkNo -> do + currentTs <- getCurrentTime + DB.execute + db + "INSERT OR REPLACE INTO snd_file_chunks (file_id, connection_id, chunk_number, created_at, updated_at) VALUES (?,?,?,?,?)" + (fileId, connId, chunkNo, currentTs, currentTs) + +updateSndFileChunkMsg :: DB.Connection -> SndFileTransfer -> Integer -> AgentMsgId -> IO () +updateSndFileChunkMsg db SndFileTransfer {fileId, connId} chunkNo msgId = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE snd_file_chunks + SET chunk_agent_msg_id = ?, updated_at = ? + WHERE file_id = ? AND connection_id = ? AND chunk_number = ? + |] + (msgId, currentTs, fileId, connId, chunkNo) + +updateSndFileChunkSent :: DB.Connection -> SndFileTransfer -> AgentMsgId -> IO () +updateSndFileChunkSent db SndFileTransfer {fileId, connId} msgId = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE snd_file_chunks + SET chunk_sent = 1, updated_at = ? + WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id = ? + |] + (currentTs, fileId, connId, msgId) + +deleteSndFileChunks :: DB.Connection -> SndFileTransfer -> IO () +deleteSndFileChunks db SndFileTransfer {fileId, connId} = + DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId) + +createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer +createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do + currentTs <- liftIO getCurrentTime + rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr + let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_ + xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ + fileProtocol = if isJust rfd_ then FPXFTP else FPSMP + fileId <- liftIO $ do + DB.execute + db + "INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)" + (userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs) + insertedRowId db + liftIO $ + DB.execute + db + "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs) + pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing} + +createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer +createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do + currentTs <- liftIO getCurrentTime + rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr + let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_ + xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ + fileProtocol = if isJust rfd_ then FPXFTP else FPSMP + fileId <- liftIO $ do + DB.execute + db + "INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)" + (userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs) + insertedRowId db + liftIO $ + DB.execute + db + "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" + (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs) + pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId} + +createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr +createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do + when (fileDescrPartNo /= 0) $ throwError SERcvFileInvalidDescrPart + fileDescrId <- liftIO $ do + DB.execute + db + "INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs) + insertedRowId db + pure RcvFileDescr {fileDescrId, fileDescrPartNo, fileDescrText, fileDescrComplete} + +appendRcvFD :: DB.Connection -> UserId -> FileTransferId -> FileDescr -> ExceptT StoreError IO RcvFileDescr +appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do + currentTs <- liftIO getCurrentTime + liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case + Nothing -> do + rfd@RcvFileDescr {fileDescrId} <- createRcvFD_ db userId currentTs fd + liftIO $ + DB.execute + db + "UPDATE rcv_files SET file_descr_id = ?, updated_at = ? WHERE file_id = ?" + (fileDescrId, currentTs, fileId) + pure rfd + Just + RcvFileDescr + { fileDescrId, + fileDescrText = rfdText, + fileDescrPartNo = rfdPNo, + fileDescrComplete = rfdComplete + } -> do + when (fileDescrPartNo /= rfdPNo + 1 || rfdComplete) $ throwError SERcvFileInvalidDescrPart + let fileDescrText' = rfdText <> fileDescrText + liftIO $ + DB.execute + db + [sql| + UPDATE xftp_file_descriptions + SET file_descr_text = ?, file_descr_part_no = ?, file_descr_complete = ? + WHERE file_descr_id = ? + |] + (fileDescrText', fileDescrPartNo, fileDescrComplete, fileDescrId) + pure RcvFileDescr {fileDescrId, fileDescrText = fileDescrText', fileDescrPartNo, fileDescrComplete} + +getRcvFileDescrByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr +getRcvFileDescrByFileId db fileId = do + liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case + Nothing -> throwError $ SERcvFileDescrNotFound fileId + Just rfd -> pure rfd + +getRcvFileDescrByFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr) +getRcvFileDescrByFileId_ db fileId = + maybeFirstRow toRcvFileDescr $ + DB.query + db + [sql| + SELECT d.file_descr_id, d.file_descr_text, d.file_descr_part_no, d.file_descr_complete + FROM xftp_file_descriptions d + JOIN rcv_files f ON f.file_descr_id = d.file_descr_id + WHERE f.file_id = ? + LIMIT 1 + |] + (Only fileId) + where + toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr + toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) = + RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete} + +updateRcvFileAgentId :: DB.Connection -> FileTransferId -> Maybe AgentRcvFileId -> IO () +updateRcvFileAgentId db fileId aFileId = do + currentTs <- getCurrentTime + DB.execute db "UPDATE rcv_files SET agent_rcv_file_id = ?, updated_at = ? WHERE file_id = ?" (aFileId, currentTs, fileId) + +getRcvFileTransferById :: DB.Connection -> FileTransferId -> ExceptT StoreError IO (User, RcvFileTransfer) +getRcvFileTransferById db fileId = do + user <- getUserByFileId db fileId + (user,) <$> getRcvFileTransfer db user fileId + +getRcvFileTransfer :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO RcvFileTransfer +getRcvFileTransfer db User {userId} fileId = do + rftRow <- + ExceptT . firstRow id (SERcvFileNotFound fileId) $ + DB.query + db + [sql| + SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name, + f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name, + f.file_path, r.file_inline, r.rcv_file_inline, r.agent_rcv_file_id, r.agent_rcv_file_deleted, c.connection_id, c.agent_conn_id + FROM rcv_files r + JOIN files f USING (file_id) + LEFT JOIN connections c ON r.file_id = c.rcv_file_id + LEFT JOIN contacts cs USING (contact_id) + LEFT JOIN group_members m USING (group_member_id) + WHERE f.user_id = ? AND f.file_id = ? + |] + (userId, fileId) + rfd_ <- liftIO $ getRcvFileDescrByFileId_ db fileId + rcvFileTransfer rfd_ rftRow + where + rcvFileTransfer :: + Maybe RcvFileDescr -> + (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, Bool) :. (Maybe Int64, Maybe AgentConnId) -> + ExceptT StoreError IO RcvFileTransfer + rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileInline, rcvFileInline, agentRcvFileId, agentRcvFileDeleted) :. (connId_, agentConnId_)) = + case contactName_ <|> memberName_ of + Nothing -> throwError $ SERcvFileInvalid fileId + Just name -> do + case fileStatus' of + FSNew -> pure $ ft name RFSNew + FSAccepted -> ft name . RFSAccepted <$> rfi + FSConnected -> ft name . RFSConnected <$> rfi + FSComplete -> ft name . RFSComplete <$> rfi + FSCancelled -> ft name . RFSCancelled <$> rfi_ + where + ft senderDisplayName fileStatus = + let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing} + xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted}) <$> rfd_ + in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId} + rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_ + rfi_ = case (filePath_, connId_, agentConnId_) of + (Just filePath, connId, agentConnId) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId} + _ -> pure Nothing + cancelled = fromMaybe False cancelled_ + +acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem +acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath = ExceptT $ do + currentTs <- getCurrentTime + acceptRcvFT_ db user fileId filePath Nothing currentTs + DB.execute + db + "INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs) + connId <- insertedRowId db + setCommandConnId db user cmdId connId + runExceptT $ getChatItemByFileId db user fileId + +getContactByFileId :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact +getContactByFileId db user@User {userId} fileId = do + cId <- getContactIdByFileId + getContact db user cId + where + getContactIdByFileId = + ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $ + DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, fileId) + +acceptRcvInlineFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem +acceptRcvInlineFT db user fileId filePath = do + liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime + getChatItemByFileId db user fileId + +startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO () +startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline = + acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime + +xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem +xftpAcceptRcvFT db user fileId filePath = do + liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime + getChatItemByFileId db user fileId + +acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO () +acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do + DB.execute + db + "UPDATE files SET file_path = ?, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" + (filePath, CIFSRcvAccepted, currentTs, userId, fileId) + DB.execute + db + "UPDATE rcv_files SET rcv_file_inline = ?, file_status = ?, updated_at = ? WHERE file_id = ?" + (rcvFileInline, FSAccepted, currentTs, fileId) + +setRcvFileToReceive :: DB.Connection -> FileTransferId -> IO () +setRcvFileToReceive db fileId = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE rcv_files SET to_receive = 1, updated_at = ? WHERE file_id = ?" + (currentTs, fileId) + +getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer] +getRcvFilesToReceive db user@User {userId} = do + cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime + fileIds :: [Int64] <- + map fromOnly + <$> DB.query + db + [sql| + SELECT r.file_id + FROM rcv_files r + JOIN files f ON f.file_id = r.file_id + WHERE f.user_id = ? AND r.file_status = ? + AND r.to_receive = 1 AND r.created_at > ? + |] + (userId, FSNew, cutoffTs) + rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds + +setRcvFTAgentDeleted :: DB.Connection -> FileTransferId -> IO () +setRcvFTAgentDeleted db fileId = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE rcv_files SET agent_rcv_file_deleted = 1, updated_at = ? WHERE file_id = ?" + (currentTs, fileId) + +updateRcvFileStatus :: DB.Connection -> FileTransferId -> FileStatus -> IO () +updateRcvFileStatus db fileId status = do + currentTs <- getCurrentTime + DB.execute db "UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?" (status, currentTs, fileId) + +createRcvFileChunk :: DB.Connection -> RcvFileTransfer -> Integer -> AgentMsgId -> IO RcvChunkStatus +createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, chunkSize} chunkNo msgId = do + status <- getLastChunkNo + unless (status == RcvChunkError) $ do + currentTs <- getCurrentTime + DB.execute + db + "INSERT OR REPLACE INTO rcv_file_chunks (file_id, chunk_number, chunk_agent_msg_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (fileId, chunkNo, msgId, currentTs, currentTs) + pure status + where + getLastChunkNo = do + ns <- DB.query db "SELECT chunk_number FROM rcv_file_chunks WHERE file_id = ? ORDER BY chunk_number DESC LIMIT 1" (Only fileId) + pure $ case map fromOnly ns of + [] + | chunkNo == 1 -> + if chunkSize >= fileSize + then RcvChunkFinal + else RcvChunkOk + | otherwise -> RcvChunkError + n : _ + | chunkNo == n -> RcvChunkDuplicate + | chunkNo == n + 1 -> + let prevSize = n * chunkSize + in if prevSize >= fileSize + then RcvChunkError + else + if prevSize + chunkSize >= fileSize + then RcvChunkFinal + else RcvChunkOk + | otherwise -> RcvChunkError + +updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO () +updatedRcvFileChunkStored db RcvFileTransfer {fileId} chunkNo = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE rcv_file_chunks + SET chunk_stored = 1, updated_at = ? + WHERE file_id = ? AND chunk_number = ? + |] + (currentTs, fileId, chunkNo) + +deleteRcvFileChunks :: DB.Connection -> RcvFileTransfer -> IO () +deleteRcvFileChunks db RcvFileTransfer {fileId} = + DB.execute db "DELETE FROM rcv_file_chunks WHERE file_id = ?" (Only fileId) + +updateFileTransferChatItemId :: DB.Connection -> FileTransferId -> ChatItemId -> UTCTime -> IO () +updateFileTransferChatItemId db fileId ciId currentTs = + DB.execute db "UPDATE files SET chat_item_id = ?, updated_at = ? WHERE file_id = ?" (ciId, currentTs, fileId) + +getFileTransferProgress :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransfer, [Integer]) +getFileTransferProgress db user fileId = do + ft <- getFileTransfer db user fileId + liftIO $ + (ft,) . map fromOnly <$> case ft of + FTSnd _ [] -> pure [Only 0] + FTSnd _ _ -> DB.query db "SELECT COUNT(*) FROM snd_file_chunks WHERE file_id = ? and chunk_sent = 1 GROUP BY connection_id" (Only fileId) + FTRcv _ -> DB.query db "SELECT COUNT(*) FROM rcv_file_chunks WHERE file_id = ? AND chunk_stored = 1" (Only fileId) + +getFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransfer +getFileTransfer db user@User {userId} fileId = + fileTransfer =<< liftIO getFileTransferRow + where + fileTransfer :: [(Maybe Int64, Maybe Int64)] -> ExceptT StoreError IO FileTransfer + fileTransfer [(Nothing, Just _)] = FTRcv <$> getRcvFileTransfer db user fileId + fileTransfer _ = do + (ftm, fts) <- getSndFileTransfer db user fileId + pure $ FTSnd {fileTransferMeta = ftm, sndFileTransfers = fts} + getFileTransferRow :: IO [(Maybe Int64, Maybe Int64)] + getFileTransferRow = + DB.query + db + [sql| + SELECT s.file_id, r.file_id + FROM files f + LEFT JOIN snd_files s ON s.file_id = f.file_id + LEFT JOIN rcv_files r ON r.file_id = f.file_id + WHERE user_id = ? AND f.file_id = ? + |] + (userId, fileId) + +getSndFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer]) +getSndFileTransfer db user fileId = do + fileTransferMeta <- getFileTransferMeta db user fileId + sndFileTransfers <- getSndFileTransfers db user fileId + pure (fileTransferMeta, sndFileTransfers) + +getSndFileTransfers :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO [SndFileTransfer] +getSndFileTransfers db User {userId} fileId = ExceptT $ getSndFileTransfers_ db userId fileId + +getSndFileTransfers_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError [SndFileTransfer]) +getSndFileTransfers_ db userId fileId = + mapM sndFileTransfer + <$> DB.query + db + [sql| + SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.connection_id, c.agent_conn_id, s.group_member_id, + cs.local_display_name, m.local_display_name + FROM snd_files s + JOIN files f USING (file_id) + JOIN connections c USING (connection_id) + LEFT JOIN contacts cs USING (contact_id) + LEFT JOIN group_members m USING (group_member_id) + WHERE f.user_id = ? AND f.file_id = ? + |] + (userId, fileId) + where + sndFileTransfer :: (FileStatus, String, Integer, Integer, FilePath) :. (Maybe Int64, Maybe InlineFileMode, Int64, AgentConnId, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer + sndFileTransfer ((fileStatus, fileName, fileSize, chunkSize, filePath) :. (fileDescrId, fileInline, connId, agentConnId, groupMemberId, contactName_, memberName_)) = + case contactName_ <|> memberName_ of + Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId, groupMemberId} + Nothing -> Left $ SESndFileInvalid fileId + +getFileTransferMeta :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta +getFileTransferMeta db User {userId} fileId = + ExceptT . firstRow fileTransferMeta (SEFileNotFound fileId) $ + DB.query + db + [sql| + SELECT file_name, file_size, chunk_size, file_path, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled + FROM files + WHERE user_id = ? AND file_id = ? + |] + (userId, fileId) + where + fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta + fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) = + let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted}) <$> aSndFileId_ + in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_} + +getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo] +getContactFileInfo db User {userId} Contact {contactId} = + map toFileInfo + <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ?") (userId, contactId) + +updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem +updateDirectCIFileStatus db user fileId fileStatus = do + aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId + case (cType, testEquality d $ msgDirection @d) of + (SCTDirect, Just Refl) -> do + liftIO $ updateCIFileStatus db user fileId fileStatus + pure $ AChatItem SCTDirect d cInfo $ updateFileStatus ci fileStatus + _ -> pure aci diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs new file mode 100644 index 0000000000..7a09df5ab0 --- /dev/null +++ b/src/Simplex/Chat/Store/Groups.hs @@ -0,0 +1,1295 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Groups + ( -- * Util methods + GroupInfoRow, + GroupMemberRow, + MaybeGroupMemberRow, + toGroupInfo, + toGroupMember, + toMaybeGroupMember, + -- * Group functions + createGroupLink, + getGroupLinkConnection, + deleteGroupLink, + getGroupLink, + getGroupLinkId, + setGroupLinkMemberRole, + getGroupAndMember, + createNewGroup, + createGroupInvitation, + setGroupInvitationChatItemId, + getGroup, + getGroupInfo, + updateGroupProfile, + getGroupIdByName, + getGroupMemberIdByName, + getGroupInfoByName, + getGroupMember, + getGroupMemberById, + getGroupMembers, + getGroupMembersForExpiration, + deleteGroupConnectionsAndFiles, + deleteGroupItemsAndMembers, + deleteGroup, + getUserGroups, + getUserGroupDetails, + getContactGroupPreferences, + checkContactHasGroups, + getGroupInvitation, + createNewContactMember, + createNewContactMemberAsync, + getContactViaMember, + setNewContactMemberConnRequest, + getMemberInvitation, + createMemberConnection, + createMemberConnectionAsync, + updateGroupMemberStatus, + updateGroupMemberStatusById, + createNewGroupMember, + checkGroupMemberHasItems, + deleteGroupMember, + deleteGroupMemberConnection, + updateGroupMemberRole, + createIntroductions, + updateIntroStatus, + saveIntroInvitation, + createIntroReMember, + createIntroToMemberContact, + saveMemberInvitation, + getViaGroupMember, + getViaGroupContact, + getMatchingContacts, + createSentProbe, + createSentProbeHash, + deleteSentProbe, + matchReceivedProbe, + matchReceivedProbeHash, + matchSentProbe, + mergeContactRecords, + updateGroupSettings, + getXGrpMemIntroContDirect, + getXGrpMemIntroContGroup, + ) +where + +import Control.Monad.Except +import Crypto.Random (ChaChaDRG) +import Data.Either (rights) +import Data.Int (Int64) +import Data.Maybe (fromMaybe, isNothing) +import Data.Text (Text) +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import Simplex.Chat.Messages +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (ConnId, UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Util (eitherToMaybe) +import UnliftIO.STM + +type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe GroupPreferences, UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow + +type GroupMemberRow = ((Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus) :. (Maybe Int64, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences)) + +type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus) :. (Maybe Int64, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences)) + +toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo +toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, groupPreferences, createdAt, updatedAt, chatTs) :. userMemberRow) = + let membership = toGroupMember userContactId userMemberRow + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + fullGroupPreferences = mergeGroupPreferences groupPreferences + groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences} + in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs} + +toGroupMember :: Int64 -> GroupMemberRow -> GroupMember +toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) = + let memberProfile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + invitedBy = toInvitedBy userContactId invitedById + activeConn = Nothing + in GroupMember {..} + +toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember +toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus) :. (invitedById, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image, contactLink, Just localAlias, contactPreferences)) = + Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences)) +toMaybeGroupMember _ _ = Nothing + +createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> ExceptT StoreError IO () +createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq groupLinkId memberRole = + checkConstraint (SEDuplicateGroupLink groupInfo) . liftIO $ do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, group_link_member_role, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" + (userId, groupId, groupLinkId, "group_link_" <> localDisplayName, cReq, memberRole, True, currentTs, currentTs) + userContactLinkId <- insertedRowId db + void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs + +getGroupLinkConnection :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO Connection +getGroupLinkConnection db User {userId} groupInfo@GroupInfo {groupId} = + ExceptT . firstRow toConnection (SEGroupLinkNotFound groupInfo) $ + DB.query + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM connections c + JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id + WHERE c.user_id = ? AND uc.user_id = ? AND uc.group_id = ? + |] + (userId, userId, groupId) + +deleteGroupLink :: DB.Connection -> User -> GroupInfo -> IO () +deleteGroupLink db User {userId} GroupInfo {groupId} = do + DB.execute + db + [sql| + DELETE FROM connections WHERE connection_id IN ( + SELECT connection_id + FROM connections c + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.group_id = ? + ) + |] + (userId, groupId) + DB.execute + db + [sql| + DELETE FROM display_names + WHERE user_id = ? + AND local_display_name in ( + SELECT cr.local_display_name + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.group_id = ? + ) + |] + (userId, userId, groupId) + DB.execute + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT cr.contact_profile_id + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.group_id = ? + ) + |] + (userId, groupId) + DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId) + +getGroupLink :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO (Int64, ConnReqContact, GroupMemberRole) +getGroupLink db User {userId} gInfo@GroupInfo {groupId} = + ExceptT . firstRow groupLink (SEGroupLinkNotFound gInfo) $ + DB.query db "SELECT user_contact_link_id, conn_req_contact, group_link_member_role FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId) + where + groupLink (linkId, cReq, mRole_) = (linkId, cReq, fromMaybe GRMember mRole_) + +getGroupLinkId :: DB.Connection -> User -> GroupInfo -> IO (Maybe GroupLinkId) +getGroupLinkId db User {userId} GroupInfo {groupId} = + fmap join . maybeFirstRow fromOnly $ + DB.query db "SELECT group_link_id FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId) + +setGroupLinkMemberRole :: DB.Connection -> User -> Int64 -> GroupMemberRole -> IO () +setGroupLinkMemberRole db User {userId} userContactLinkId memberRole = + DB.execute db "UPDATE user_contact_links SET group_link_member_role = ? WHERE user_id = ? AND user_contact_link_id = ?" (memberRole, userId, userContactLinkId) + +getGroupAndMember :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupMember) +getGroupAndMember db User {userId, userContactId} groupMemberId = + ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $ + DB.query + db + [sql| + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + -- GroupInfo {membership} + mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + -- GroupInfo {membership = GroupMember {memberProfile}} + pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, + -- from GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM group_members m + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + JOIN groups g ON g.group_id = m.group_id + JOIN group_profiles gp USING (group_profile_id) + JOIN group_members mu ON g.group_id = mu.group_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + LEFT JOIN connections c ON c.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.group_member_id = m.group_member_id + ) + WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? + |] + (groupMemberId, userId, userContactId) + where + toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) + toGroupAndMember (groupInfoRow :. memberRow :. connRow) = + let groupInfo = toGroupInfo userContactId groupInfoRow + member = toGroupMember userContactId memberRow + in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) + +-- | creates completely new group with a single member - the current user +createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> ExceptT StoreError IO GroupInfo +createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do + let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile + fullGroupPreferences = mergeGroupPreferences groupPreferences + currentTs <- getCurrentTime + withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do + groupId <- liftIO $ do + DB.execute + db + "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO groups (local_display_name, user_id, group_profile_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?)" + (ldn, userId, profileId, True, currentTs, currentTs, currentTs) + insertedRowId db + memberId <- liftIO $ encodedRandomBytes gVar 12 + membership <- createContactMemberInv_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing currentTs + let chatSettings = ChatSettings {enableNtfs = True} + pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs} + +-- | creates a new group record for the group the current user was invited to, or returns an existing one +createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId) +createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do + liftIO getInvitationGroupId_ >>= \case + Nothing -> createGroupInvitation_ + Just gId -> do + gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db user gId + hostId <- getHostMemberId_ db user gId + let GroupMember {groupMemberId, memberId, memberRole} = membership + MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember + liftIO . when (memberId /= memberId' || memberRole /= memberRole') $ + DB.execute db "UPDATE group_members SET member_id = ?, member_role = ? WHERE group_member_id = ?" (memberId', memberRole', groupMemberId) + gInfo' <- + if p' == groupProfile + then pure gInfo + else updateGroupProfile db user gInfo groupProfile + pure (gInfo', hostId) + where + getInvitationGroupId_ :: IO (Maybe Int64) + getInvitationGroupId_ = + maybeFirstRow fromOnly $ + DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId) + createGroupInvitation_ :: ExceptT StoreError IO (GroupInfo, GroupMemberId) + createGroupInvitation_ = do + let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile + fullGroupPreferences = mergeGroupPreferences groupPreferences + ExceptT $ + withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do + currentTs <- liftIO getCurrentTime + groupId <- liftIO $ do + DB.execute + db + "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?,?)" + (profileId, localDisplayName, connRequest, customUserProfileId, userId, True, currentTs, currentTs, currentTs) + insertedRowId db + GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs + membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs + let chatSettings = ChatSettings {enableNtfs = True} + pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId) + +getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId +getHostMemberId_ db User {userId} groupId = + ExceptT . firstRow fromOnly (SEHostMemberIdNotFound groupId) $ + DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND member_category = ?" (userId, groupId, GCHostMember) + +createContactMemberInv_ :: IsContact a => DB.Connection -> User -> GroupId -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ProfileId -> UTCTime -> ExceptT StoreError IO GroupMember +createContactMemberInv_ db User {userId, userContactId} groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy incognitoProfileId createdAt = do + incognitoProfile <- forM incognitoProfileId $ \profileId -> getProfileById db userId profileId + (localDisplayName, memberProfile) <- case (incognitoProfile, incognitoProfileId) of + (Just profile@LocalProfile {displayName}, Just profileId) -> + (,profile) <$> insertMemberIncognitoProfile_ displayName profileId + _ -> (,profile' userOrContact) <$> liftIO insertMember_ + groupMemberId <- liftIO $ insertedRowId db + pure + GroupMember + { groupMemberId, + groupId, + memberId, + memberRole, + memberCategory, + memberStatus, + invitedBy, + localDisplayName, + memberProfile, + memberContactId = Just $ contactId' userOrContact, + memberContactProfileId = localProfileId (profile' userOrContact), + activeConn = Nothing + } + where + insertMember_ :: IO ContactName + insertMember_ = do + let localDisplayName = localDisplayName' userOrContact + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy) + :. (userId, localDisplayName' userOrContact, contactId' userOrContact, localProfileId $ profile' userOrContact, createdAt, createdAt) + ) + pure localDisplayName + insertMemberIncognitoProfile_ :: ContactName -> ProfileId -> ExceptT StoreError IO ContactName + insertMemberIncognitoProfile_ incognitoDisplayName customUserProfileId = ExceptT $ + withLocalDisplayName db userId incognitoDisplayName $ \incognitoLdn -> do + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, member_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy) + :. (userId, incognitoLdn, contactId' userOrContact, localProfileId $ profile' userOrContact, customUserProfileId, createdAt, createdAt) + ) + pure $ Right incognitoLdn + +setGroupInvitationChatItemId :: DB.Connection -> User -> GroupId -> ChatItemId -> IO () +setGroupInvitationChatItemId db User {userId} groupId chatItemId = do + currentTs <- getCurrentTime + DB.execute db "UPDATE groups SET chat_item_id = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (chatItemId, currentTs, userId, groupId) + +-- TODO return the last connection that is ready, not any last connection +-- requires updating connection status +getGroup :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO Group +getGroup db user groupId = do + gInfo <- getGroupInfo db user groupId + members <- liftIO $ getGroupMembers db user gInfo + pure $ Group gInfo members + +deleteGroupConnectionsAndFiles :: DB.Connection -> User -> GroupInfo -> [GroupMember] -> IO () +deleteGroupConnectionsAndFiles db User {userId} GroupInfo {groupId} members = do + forM_ members $ \m -> DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId' m) + DB.execute db "DELETE FROM files WHERE user_id = ? AND group_id = ?" (userId, groupId) + +deleteGroupItemsAndMembers :: DB.Connection -> User -> GroupInfo -> [GroupMember] -> IO () +deleteGroupItemsAndMembers db user@User {userId} GroupInfo {groupId} members = do + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId) + void $ runExceptT cleanupHostGroupLinkConn_ -- to allow repeat connection via the same group link if one was used + DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_id = ?" (userId, groupId) + forM_ members $ \m@GroupMember {memberProfile = LocalProfile {profileId}} -> do + cleanupMemberProfileAndName_ db user m + when (memberIncognito m) $ deleteUnusedIncognitoProfileById_ db user profileId + where + cleanupHostGroupLinkConn_ = do + hostId <- getHostMemberId_ db user groupId + liftIO $ + DB.execute + db + [sql| + UPDATE connections SET via_contact_uri_hash = NULL, xcontact_id = NULL + WHERE user_id = ? AND via_group_link = 1 AND contact_id IN ( + SELECT contact_id + FROM group_members + WHERE user_id = ? AND group_member_id = ? + ) + |] + (userId, userId, hostId) + +deleteGroup :: DB.Connection -> User -> GroupInfo -> IO () +deleteGroup db user@User {userId} GroupInfo {groupId, localDisplayName, membership = membership@GroupMember {memberProfile = LocalProfile {profileId}}} = do + deleteGroupProfile_ db userId groupId + DB.execute db "DELETE FROM groups WHERE user_id = ? AND group_id = ?" (userId, groupId) + DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + when (memberIncognito membership) $ deleteUnusedIncognitoProfileById_ db user profileId + +deleteGroupProfile_ :: DB.Connection -> UserId -> GroupId -> IO () +deleteGroupProfile_ db userId groupId = + DB.execute + db + [sql| + DELETE FROM group_profiles + WHERE group_profile_id in ( + SELECT group_profile_id + FROM groups + WHERE user_id = ? AND group_id = ? + ) + |] + (userId, groupId) + +getUserGroups :: DB.Connection -> User -> IO [Group] +getUserGroups db user@User {userId} = do + groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId) + rights <$> mapM (runExceptT . getGroup db user) groupIds + +getUserGroupDetails :: DB.Connection -> User -> IO [GroupInfo] +getUserGroupDetails db User {userId, userContactId} = + map (toGroupInfo userContactId) + <$> DB.query + db + [sql| + SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + mu.group_member_id, g.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, + mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences + FROM groups g + JOIN group_profiles gp USING (group_profile_id) + JOIN group_members mu USING (group_id) + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + WHERE g.user_id = ? AND mu.contact_id = ? + |] + (userId, userContactId) + +getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences] +getContactGroupPreferences db User {userId} Contact {contactId} = do + map (mergeGroupPreferences . fromOnly) + <$> DB.query + db + [sql| + SELECT gp.preferences + FROM groups g + JOIN group_profiles gp USING (group_profile_id) + JOIN group_members m USING (group_id) + WHERE g.user_id = ? AND m.contact_id = ? + |] + (userId, contactId) + +checkContactHasGroups :: DB.Connection -> User -> Contact -> IO (Maybe GroupId) +checkContactHasGroups db User {userId} Contact {contactId} = + maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId) + +getGroupInfoByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupInfo +getGroupInfoByName db user gName = do + gId <- getGroupIdByName db user gName + getGroupInfo db user gId + +groupMemberQuery :: Query +groupMemberQuery = + [sql| + SELECT + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM group_members m + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + LEFT JOIN connections c ON c.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.group_member_id = m.group_member_id + ) + |] + +getGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember +getGroupMember db user@User {userId} groupId groupMemberId = + ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound groupMemberId) $ + DB.query + db + (groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?") + (groupId, groupMemberId, userId) + +getGroupMemberById :: DB.Connection -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember +getGroupMemberById db user@User {userId} groupMemberId = + ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound groupMemberId) $ + DB.query + db + (groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ?") + (groupMemberId, userId) + +getGroupMembers :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] +getGroupMembers db user@User {userId, userContactId} GroupInfo {groupId} = do + map (toContactMember user) + <$> DB.query + db + (groupMemberQuery <> " WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)") + (groupId, userId, userContactId) + +getGroupMembersForExpiration :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] +getGroupMembersForExpiration db user@User {userId, userContactId} GroupInfo {groupId} = do + map (toContactMember user) + <$> DB.query + db + ( groupMemberQuery + <> [sql| + WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) + AND m.member_status IN (?, ?, ?) + AND m.group_member_id NOT IN ( + SELECT DISTINCT group_member_id FROM chat_items + ) + |] + ) + (groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) + +toContactMember :: User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember +toContactMember User {userContactId} (memberRow :. connRow) = + (toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow} + +getGroupInvitation :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation +getGroupInvitation db user groupId = + getConnRec_ user >>= \case + Just connRequest -> do + groupInfo@GroupInfo {membership} <- getGroupInfo db user groupId + when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined + hostId <- getHostMemberId_ db user groupId + fromMember <- getGroupMember db user groupId hostId + pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo} + _ -> throwError SEGroupInvitationNotFound + where + getConnRec_ :: User -> ExceptT StoreError IO (Maybe ConnReqInvitation) + getConnRec_ User {userId} = ExceptT $ do + firstRow fromOnly (SEGroupNotFound groupId) $ + DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId) + +createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember +createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole agentConnId connRequest = + createWithRandomId gVar $ \memId -> do + createdAt <- liftIO getCurrentTime + member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt + void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt + pure member + where + createMember_ memberId createdAt = do + insertMember_ + groupMemberId <- liftIO $ insertedRowId db + pure + GroupMember + { groupMemberId, + groupId, + memberId, + memberRole, + memberCategory = GCInviteeMember, + memberStatus = GSMemInvited, + invitedBy = IBUser, + localDisplayName, + memberProfile = profile, + memberContactId = Just contactId, + memberContactProfileId = localProfileId profile, + activeConn = Nothing + } + where + insertMember_ = + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, sent_inv_queue_info, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser) + :. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt) + ) + +createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> ExceptT StoreError IO () +createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) = + createWithRandomId gVar $ \memId -> do + createdAt <- liftIO getCurrentTime + insertMember_ (MemberId memId) createdAt + groupMemberId <- liftIO $ insertedRowId db + Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt + setCommandConnId db user cmdId connId + where + insertMember_ memberId createdAt = + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser) + :. (userId, localDisplayName, contactId, localProfileId profile, createdAt, createdAt) + ) + +getContactViaMember :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact) +getContactViaMember db user@User {userId} GroupMember {groupMemberId} = + maybeFirstRow (toContact user) $ + DB.query + db + [sql| + SELECT + -- Contact + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + -- Connection + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, + c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM contacts ct + JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id + JOIN connections c ON c.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.contact_id = ct.contact_id + ) + JOIN group_members m ON m.contact_id = ct.contact_id + WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0 + |] + (userId, groupMemberId) + +setNewContactMemberConnRequest :: DB.Connection -> User -> GroupMember -> ConnReqInvitation -> IO () +setNewContactMemberConnRequest db User {userId} GroupMember {groupMemberId} connRequest = do + currentTs <- getCurrentTime + DB.execute db "UPDATE group_members SET sent_inv_queue_info = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?" (connRequest, currentTs, userId, groupMemberId) + +getMemberInvitation :: DB.Connection -> User -> Int64 -> IO (Maybe ConnReqInvitation) +getMemberInvitation db User {userId} groupMemberId = + fmap join . maybeFirstRow fromOnly $ + DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId) + +createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> IO () +createMemberConnection db userId GroupMember {groupMemberId} agentConnId = do + currentTs <- getCurrentTime + void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs + +createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> IO () +createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) = do + currentTs <- getCurrentTime + Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs + setCommandConnId db user cmdId connId + +updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO () +updateGroupMemberStatus db userId GroupMember {groupMemberId} = updateGroupMemberStatusById db userId groupMemberId + +updateGroupMemberStatusById :: DB.Connection -> UserId -> GroupMemberId -> GroupMemberStatus -> IO () +updateGroupMemberStatusById db userId groupMemberId memStatus = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE group_members + SET member_status = ?, updated_at = ? + WHERE user_id = ? AND group_member_id = ? + |] + (memStatus, currentTs, userId, groupMemberId) + +-- | add new member with profile +createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember +createNewGroupMember db user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile {displayName, fullName, image, contactLink, preferences}) memCategory memStatus = + ExceptT . withLocalDisplayName db userId displayName $ \localDisplayName -> do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs) + memProfileId <- insertedRowId db + let newMember = + NewGroupMember + { memInfo, + memCategory, + memStatus, + memInvitedBy = IBUnknown, + localDisplayName, + memContactId = Nothing, + memProfileId + } + Right <$> createNewMember_ db user gInfo newMember currentTs + +createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember +createNewMember_ + db + User {userId, userContactId} + GroupInfo {groupId} + NewGroupMember + { memInfo = MemberInfo memberId memberRole memberProfile, + memCategory = memberCategory, + memStatus = memberStatus, + memInvitedBy = invitedBy, + localDisplayName, + memContactId = memberContactId, + memProfileId = memberContactProfileId + } + createdAt = do + let invitedById = fromInvitedBy userContactId invitedBy + activeConn = Nothing + DB.execute + db + [sql| + INSERT INTO group_members + (group_id, member_id, member_role, member_category, member_status, + invited_by, user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + (groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt) + groupMemberId <- insertedRowId db + pure GroupMember {groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile = toLocalProfile memberContactProfileId memberProfile "", memberContactId, memberContactProfileId, activeConn} + +checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId) +checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} = + maybeFirstRow fromOnly $ DB.query db "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ? LIMIT 1" (userId, groupId, groupMemberId) + +deleteGroupMember :: DB.Connection -> User -> GroupMember -> IO () +deleteGroupMember db user@User {userId} m@GroupMember {groupMemberId, groupId, memberProfile = LocalProfile {profileId}} = do + deleteGroupMemberConnection db user m + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ?" (userId, groupId, groupMemberId) + DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId) + cleanupMemberProfileAndName_ db user m + when (memberIncognito m) $ deleteUnusedIncognitoProfileById_ db user profileId + +cleanupMemberProfileAndName_ :: DB.Connection -> User -> GroupMember -> IO () +cleanupMemberProfileAndName_ db User {userId} GroupMember {groupMemberId, memberContactId, memberContactProfileId, localDisplayName} = + -- check record has no memberContactId (contact_id) - it means contact has been deleted and doesn't use profile & ldn + when (isNothing memberContactId) $ do + -- check other group member records don't use profile & ldn + sameProfileMember :: (Maybe GroupMemberId) <- maybeFirstRow fromOnly $ DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND contact_profile_id = ? AND group_member_id != ? LIMIT 1" (userId, memberContactProfileId, groupMemberId) + when (isNothing sameProfileMember) $ do + DB.execute db "DELETE FROM contact_profiles WHERE user_id = ? AND contact_profile_id = ?" (userId, memberContactProfileId) + DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + +deleteGroupMemberConnection :: DB.Connection -> User -> GroupMember -> IO () +deleteGroupMemberConnection db User {userId} GroupMember {groupMemberId} = + DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId) + +updateGroupMemberRole :: DB.Connection -> User -> GroupMember -> GroupMemberRole -> IO () +updateGroupMemberRole db User {userId} GroupMember {groupMemberId} memRole = + DB.execute db "UPDATE group_members SET member_role = ? WHERE user_id = ? AND group_member_id = ?" (memRole, userId, groupMemberId) + +createIntroductions :: DB.Connection -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro] +createIntroductions db members toMember = do + let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members + if null reMembers + then pure [] + else do + currentTs <- getCurrentTime + mapM (insertIntro_ currentTs) reMembers + where + insertIntro_ :: UTCTime -> GroupMember -> IO GroupMemberIntro + insertIntro_ ts reMember = do + DB.execute + db + [sql| + INSERT INTO group_member_intros + (re_group_member_id, to_group_member_id, intro_status, created_at, updated_at) + VALUES (?,?,?,?,?) + |] + (groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, ts, ts) + introId <- insertedRowId db + pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing} + +updateIntroStatus :: DB.Connection -> Int64 -> GroupMemberIntroStatus -> IO () +updateIntroStatus db introId introStatus = do + currentTs <- getCurrentTime + DB.executeNamed + db + [sql| + UPDATE group_member_intros + SET intro_status = :intro_status, updated_at = :updated_at + WHERE group_member_intro_id = :intro_id + |] + [":intro_status" := introStatus, ":updated_at" := currentTs, ":intro_id" := introId] + +saveIntroInvitation :: DB.Connection -> GroupMember -> GroupMember -> IntroInvitation -> ExceptT StoreError IO GroupMemberIntro +saveIntroInvitation db reMember toMember introInv = do + intro <- getIntroduction_ db reMember toMember + liftIO $ do + currentTs <- getCurrentTime + DB.executeNamed + db + [sql| + UPDATE group_member_intros + SET intro_status = :intro_status, + group_queue_info = :group_queue_info, + direct_queue_info = :direct_queue_info, + updated_at = :updated_at + WHERE group_member_intro_id = :intro_id + |] + [ ":intro_status" := GMIntroInvReceived, + ":group_queue_info" := groupConnReq (introInv :: IntroInvitation), + ":direct_queue_info" := directConnReq introInv, + ":updated_at" := currentTs, + ":intro_id" := introId intro + ] + pure intro {introInvitation = Just introInv, introStatus = GMIntroInvReceived} + +saveMemberInvitation :: DB.Connection -> GroupMember -> IntroInvitation -> IO () +saveMemberInvitation db GroupMember {groupMemberId} IntroInvitation {groupConnReq, directConnReq} = do + currentTs <- getCurrentTime + DB.executeNamed + db + [sql| + UPDATE group_members + SET member_status = :member_status, + group_queue_info = :group_queue_info, + direct_queue_info = :direct_queue_info, + updated_at = :updated_at + WHERE group_member_id = :group_member_id + |] + [ ":member_status" := GSMemIntroInvited, + ":group_queue_info" := groupConnReq, + ":direct_queue_info" := directConnReq, + ":updated_at" := currentTs, + ":group_member_id" := groupMemberId + ] + +getIntroduction_ :: DB.Connection -> GroupMember -> GroupMember -> ExceptT StoreError IO GroupMemberIntro +getIntroduction_ db reMember toMember = ExceptT $ do + toIntro + <$> DB.query + db + [sql| + SELECT group_member_intro_id, group_queue_info, direct_queue_info, intro_status + FROM group_member_intros + WHERE re_group_member_id = ? AND to_group_member_id = ? + |] + (groupMemberId' reMember, groupMemberId' toMember) + where + toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro + toIntro [(introId, groupConnReq, directConnReq, introStatus)] = + let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq + in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation} + toIntro _ = Left SEIntroNotFound + +createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember +createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do + let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn + currentTs <- liftIO getCurrentTime + Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId memberContactId Nothing customUserProfileId cLevel currentTs + liftIO $ setCommandConnId db user directCmdId directConnId + (localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing + liftIO $ do + let newMember = + NewGroupMember + { memInfo, + memCategory = GCPreMember, + memStatus = GSMemIntroduced, + memInvitedBy = IBUnknown, + localDisplayName, + memContactId = Just contactId, + memProfileId + } + member <- createNewMember_ db user gInfo newMember currentTs + conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId memberContactId cLevel currentTs + liftIO $ setCommandConnId db user groupCmdId groupConnId + pure (member :: GroupMember) {activeConn = Just conn} + +createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> IO () +createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do + let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn + currentTs <- getCurrentTime + Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel currentTs + setCommandConnId db user groupCmdId groupConnId + Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId viaContactId Nothing customUserProfileId cLevel currentTs + setCommandConnId db user directCmdId directConnId + contactId <- createMemberContact_ directConnId currentTs + updateMember_ contactId currentTs + where + createMemberContact_ :: Int64 -> UTCTime -> IO Int64 + createMemberContact_ connId ts = do + DB.execute + db + [sql| + INSERT INTO contacts (contact_profile_id, via_group, local_display_name, user_id, created_at, updated_at) + SELECT contact_profile_id, group_id, ?, ?, ?, ? + FROM group_members + WHERE group_member_id = ? + |] + (localDisplayName, userId, ts, ts, groupMemberId) + contactId <- insertedRowId db + DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, ts, connId) + pure contactId + updateMember_ :: Int64 -> UTCTime -> IO () + updateMember_ contactId ts = + DB.executeNamed + db + [sql| + UPDATE group_members + SET contact_id = :contact_id, updated_at = :updated_at + WHERE group_member_id = :group_member_id + |] + [":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId] + +createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection +createMemberConnection_ db userId groupMemberId agentConnId viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId viaContact Nothing Nothing + +getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember)) +getViaGroupMember db User {userId, userContactId} Contact {contactId} = + maybeFirstRow toGroupAndMember $ + DB.query + db + [sql| + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + -- GroupInfo {membership} + mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + -- GroupInfo {membership = GroupMember {memberProfile}} + pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, + -- via GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM group_members m + JOIN contacts ct ON ct.contact_id = m.contact_id + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group + JOIN group_profiles gp USING (group_profile_id) + JOIN group_members mu ON g.group_id = mu.group_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + LEFT JOIN connections c ON c.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.group_member_id = m.group_member_id + ) + WHERE ct.user_id = ? AND ct.contact_id = ? AND mu.contact_id = ? AND ct.deleted = 0 + |] + (userId, contactId, userContactId) + where + toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) + toGroupAndMember (groupInfoRow :. memberRow :. connRow) = + let groupInfo = toGroupInfo userContactId groupInfoRow + member = toGroupMember userContactId memberRow + in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) + +getViaGroupContact :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact) +getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = + maybeFirstRow toContact' $ + DB.query + db + [sql| + SELECT + ct.contact_id, ct.contact_profile_id, ct.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, ct.via_group, ct.contact_used, ct.enable_ntfs, + p.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM contacts ct + JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id + JOIN connections c ON c.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.contact_id = ct.contact_id + ) + JOIN groups g ON g.group_id = ct.via_group + JOIN group_members m ON m.group_id = g.group_id AND m.contact_id = ct.contact_id + WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0 + |] + (userId, groupMemberId) + where + toContact' :: ((ContactId, ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)) :. ConnectionRow -> Contact + toContact' (((contactId, profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = + let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + activeConn = toConnection connRow + mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} + +updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo +updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences} + | displayName == newName = liftIO $ do + currentTs <- getCurrentTime + updateGroupProfile_ currentTs + pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences} + | otherwise = + ExceptT . withLocalDisplayName db userId newName $ \ldn -> do + currentTs <- getCurrentTime + updateGroupProfile_ currentTs + updateGroup_ ldn currentTs + pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences} + where + fullGroupPreferences = mergeGroupPreferences groupPreferences + updateGroupProfile_ currentTs = + DB.execute + db + [sql| + UPDATE group_profiles + SET display_name = ?, full_name = ?, description = ?, image = ?, preferences = ?, updated_at = ? + WHERE group_profile_id IN ( + SELECT group_profile_id + FROM groups + WHERE user_id = ? AND group_id = ? + ) + |] + (newName, fullName, description, image, groupPreferences, currentTs, userId, groupId) + updateGroup_ ldn currentTs = do + DB.execute + db + "UPDATE groups SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" + (ldn, currentTs, userId, groupId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) + +getGroupInfo :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO GroupInfo +getGroupInfo db User {userId, userContactId} groupId = + ExceptT . firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $ + DB.query + db + [sql| + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + -- GroupMember - membership + mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences + FROM groups g + JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id + JOIN group_members mu ON mu.group_id = g.group_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ? + |] + (groupId, userId, userContactId) + +getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId +getGroupIdByName db User {userId} gName = + ExceptT . firstRow fromOnly (SEGroupNotFoundByName gName) $ + DB.query db "SELECT group_id FROM groups WHERE user_id = ? AND local_display_name = ?" (userId, gName) + +getGroupMemberIdByName :: DB.Connection -> User -> GroupId -> ContactName -> ExceptT StoreError IO GroupMemberId +getGroupMemberIdByName db User {userId} groupId groupMemberName = + ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound groupId groupMemberName) $ + DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName) + + + + +getMatchingContacts :: DB.Connection -> User -> Contact -> IO [Contact] +getMatchingContacts db user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, image}} = do + contactIds <- + map fromOnly + <$> DB.query + db + [sql| + SELECT ct.contact_id + FROM contacts ct + JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id + WHERE ct.user_id = ? AND ct.contact_id != ? + AND ct.deleted = 0 + AND p.display_name = ? AND p.full_name = ? + AND ((p.image IS NULL AND ? IS NULL) OR p.image = ?) + |] + (userId, contactId, displayName, fullName, image, image) + rights <$> mapM (runExceptT . getContact db user) contactIds + +createSentProbe :: DB.Connection -> TVar ChaChaDRG -> UserId -> Contact -> ExceptT StoreError IO (Probe, Int64) +createSentProbe db gVar userId _to@Contact {contactId} = + createWithRandomBytes 32 gVar $ \probe -> do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO sent_probes (contact_id, probe, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (contactId, probe, userId, currentTs, currentTs) + (Probe probe,) <$> insertedRowId db + +createSentProbeHash :: DB.Connection -> UserId -> Int64 -> Contact -> IO () +createSentProbeHash db userId probeId _to@Contact {contactId} = do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO sent_probe_hashes (sent_probe_id, contact_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (probeId, contactId, userId, currentTs, currentTs) + +deleteSentProbe :: DB.Connection -> UserId -> Int64 -> IO () +deleteSentProbe db userId probeId = + DB.execute + db + "DELETE FROM sent_probes WHERE user_id = ? AND sent_probe_id = ?" + (userId, probeId) + +matchReceivedProbe :: DB.Connection -> User -> Contact -> Probe -> IO (Maybe Contact) +matchReceivedProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = do + let probeHash = C.sha256Hash probe + contactIds <- + map fromOnly + <$> DB.query + db + [sql| + SELECT c.contact_id + FROM contacts c + JOIN received_probes r ON r.contact_id = c.contact_id + WHERE c.user_id = ? AND c.deleted = 0 AND r.probe_hash = ? AND r.probe IS NULL + |] + (userId, probeHash) + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO received_probes (contact_id, probe, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (contactId, probe, probeHash, userId, currentTs, currentTs) + case contactIds of + [] -> pure Nothing + cId : _ -> eitherToMaybe <$> runExceptT (getContact db user cId) + +matchReceivedProbeHash :: DB.Connection -> User -> Contact -> ProbeHash -> IO (Maybe (Contact, Probe)) +matchReceivedProbeHash db user@User {userId} _from@Contact {contactId} (ProbeHash probeHash) = do + namesAndProbes <- + DB.query + db + [sql| + SELECT c.contact_id, r.probe + FROM contacts c + JOIN received_probes r ON r.contact_id = c.contact_id + WHERE c.user_id = ? AND c.deleted = 0 AND r.probe_hash = ? AND r.probe IS NOT NULL + |] + (userId, probeHash) + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO received_probes (contact_id, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (contactId, probeHash, userId, currentTs, currentTs) + case namesAndProbes of + [] -> pure Nothing + (cId, probe) : _ -> + either (const Nothing) (Just . (,Probe probe)) + <$> runExceptT (getContact db user cId) + +matchSentProbe :: DB.Connection -> User -> Contact -> Probe -> IO (Maybe Contact) +matchSentProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = do + contactIds <- + map fromOnly + <$> DB.query + db + [sql| + SELECT c.contact_id + FROM contacts c + JOIN sent_probes s ON s.contact_id = c.contact_id + JOIN sent_probe_hashes h ON h.sent_probe_id = s.sent_probe_id + WHERE c.user_id = ? AND c.deleted = 0 AND s.probe = ? AND h.contact_id = ? + |] + (userId, probe, contactId) + case contactIds of + [] -> pure Nothing + cId : _ -> eitherToMaybe <$> runExceptT (getContact db user cId) + +mergeContactRecords :: DB.Connection -> UserId -> Contact -> Contact -> IO () +mergeContactRecords db userId ct1 ct2 = do + let (toCt, fromCt) = toFromContacts ct1 ct2 + Contact {contactId = toContactId} = toCt + Contact {contactId = fromContactId, localDisplayName} = fromCt + currentTs <- getCurrentTime + -- TODO next query fixes incorrect unused contacts deletion; consider more thorough fix + when (contactDirect toCt && not (contactUsed toCt)) $ + DB.execute + db + "UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" + (currentTs, userId, toContactId) + DB.execute + db + "UPDATE connections SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?" + (toContactId, currentTs, fromContactId, userId) + DB.execute + db + "UPDATE connections SET via_contact = ?, updated_at = ? WHERE via_contact = ? AND user_id = ?" + (toContactId, currentTs, fromContactId, userId) + DB.execute + db + "UPDATE group_members SET invited_by = ?, updated_at = ? WHERE invited_by = ? AND user_id = ?" + (toContactId, currentTs, fromContactId, userId) + DB.execute + db + "UPDATE chat_items SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?" + (toContactId, currentTs, fromContactId, userId) + DB.executeNamed + db + [sql| + UPDATE group_members + SET contact_id = :to_contact_id, + local_display_name = (SELECT local_display_name FROM contacts WHERE contact_id = :to_contact_id), + contact_profile_id = (SELECT contact_profile_id FROM contacts WHERE contact_id = :to_contact_id), + updated_at = :updated_at + WHERE contact_id = :from_contact_id + AND user_id = :user_id + |] + [ ":to_contact_id" := toContactId, + ":from_contact_id" := fromContactId, + ":user_id" := userId, + ":updated_at" := currentTs + ] + deleteContactProfile_ db userId fromContactId + DB.execute db "DELETE FROM contacts WHERE contact_id = ? AND user_id = ?" (fromContactId, userId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) + where + toFromContacts :: Contact -> Contact -> (Contact, Contact) + toFromContacts c1 c2 + | d1 && not d2 = (c1, c2) + | d2 && not d1 = (c2, c1) + | ctCreatedAt c1 <= ctCreatedAt c2 = (c1, c2) + | otherwise = (c2, c1) + where + d1 = directOrUsed c1 + d2 = directOrUsed c2 + ctCreatedAt Contact {createdAt} = createdAt + +updateGroupSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () +updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs} = + DB.execute db "UPDATE groups SET enable_ntfs = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, userId, groupId) + +getXGrpMemIntroContDirect :: DB.Connection -> User -> Contact -> IO (Maybe (Int64, XGrpMemIntroCont)) +getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do + fmap join . maybeFirstRow toCont $ + DB.query + db + [sql| + SELECT ch.connection_id, g.group_id, m.group_member_id, m.member_id, c.conn_req_inv + FROM contacts ct + JOIN group_members m ON m.contact_id = ct.contact_id + LEFT JOIN connections c ON c.connection_id = ( + SELECT MAX(cc.connection_id) + FROM connections cc + WHERE cc.group_member_id = m.group_member_id + ) + JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group + JOIN group_members mh ON mh.group_id = g.group_id + LEFT JOIN connections ch ON ch.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.group_member_id = mh.group_member_id + ) + WHERE ct.user_id = ? AND ct.contact_id = ? AND ct.deleted = 0 AND mh.member_category = ? + |] + (userId, contactId, GCHostMember) + where + toCont :: (Int64, GroupId, GroupMemberId, MemberId, Maybe ConnReqInvitation) -> Maybe (Int64, XGrpMemIntroCont) + toCont (hostConnId, groupId, groupMemberId, memberId, connReq_) = case connReq_ of + Just groupConnReq -> Just (hostConnId, XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}) + _ -> Nothing + +getXGrpMemIntroContGroup :: DB.Connection -> User -> GroupMember -> IO (Maybe (Int64, ConnReqInvitation)) +getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do + fmap join . maybeFirstRow toCont $ + DB.query + db + [sql| + SELECT ch.connection_id, c.conn_req_inv + FROM group_members m + JOIN contacts ct ON ct.contact_id = m.contact_id + LEFT JOIN connections c ON c.connection_id = ( + SELECT MAX(cc.connection_id) + FROM connections cc + WHERE cc.contact_id = ct.contact_id + ) + JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group + JOIN group_members mh ON mh.group_id = g.group_id + LEFT JOIN connections ch ON ch.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.group_member_id = mh.group_member_id + ) + WHERE m.user_id = ? AND m.group_member_id = ? AND mh.member_category = ? AND ct.deleted = 0 + |] + (userId, groupMemberId, GCHostMember) + where + toCont :: (Int64, Maybe ConnReqInvitation) -> Maybe (Int64, ConnReqInvitation) + toCont (hostConnId, connReq_) = case connReq_ of + Just connReq -> Just (hostConnId, connReq) + _ -> Nothing diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs new file mode 100644 index 0000000000..efc78f8df2 --- /dev/null +++ b/src/Simplex/Chat/Store/Messages.hs @@ -0,0 +1,1805 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Messages + ( getContactConnIds_, + getDirectChatReactions_, + toDirectChatItem, + -- * Message and chat item functions + deleteContactCIs, + getGroupFileInfo, + deleteGroupCIs, + createNewSndMessage, + createSndMsgDelivery, + createNewMessageAndRcvMsgDelivery, + createSndMsgDeliveryEvent, + createRcvMsgDeliveryEvent, + createPendingGroupMessage, + getPendingGroupMessages, + deletePendingGroupMessage, + deleteOldMessages, + updateChatTs, + createNewSndChatItem, + createNewRcvChatItem, + createNewChatItemNoMsg, + getChatPreviews, + getDirectChat, + getGroupChat, + getDirectChatItemsLast, + getAllChatItems, + getAChatItem, + updateDirectChatItem, + updateDirectChatItem', + addInitialAndNewCIVersions, + createChatItemVersion, + deleteDirectChatItem, + markDirectChatItemDeleted, + updateGroupChatItem, + deleteGroupChatItem, + updateGroupChatItemModerated, + markGroupChatItemDeleted, + updateDirectChatItemsRead, + getDirectUnreadTimedItems, + setDirectChatItemDeleteAt, + updateGroupChatItemsRead, + getGroupUnreadTimedItems, + setGroupChatItemDeleteAt, + getChatRefViaItemId, + getChatItemVersions, + getDirectCIReactions, + getDirectReactions, + setDirectReaction, + getGroupCIReactions, + getGroupReactions, + setGroupReaction, + getChatItemIdByAgentMsgId, + getDirectChatItem, + getDirectChatItemBySharedMsgId, + getDirectChatItemByAgentMsgId, + getGroupChatItem, + getGroupChatItemBySharedMsgId, + getGroupMemberCIBySharedMsgId, + getGroupMemberChatItemLast, + getDirectChatItemIdByText, + getDirectChatItemIdByText', + getGroupChatItemIdByText, + getGroupChatItemIdByText', + getChatItemByFileId, + getChatItemByGroupId, + updateDirectChatItemStatus, + getTimedItems, + getChatItemTTL, + setChatItemTTL, + getContactExpiredFileInfo, + deleteContactExpiredCIs, + getGroupExpiredFileInfo, + deleteGroupExpiredCIs, + ) +where + +import Control.Monad.Except +import Crypto.Random (ChaChaDRG) +import Data.Bifunctor (first) +import Data.ByteString.Char8 (ByteString) +import Data.Either (fromRight, rights) +import Data.Int (Int64) +import Data.List (sortOn) +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Ord (Down (..)) +import Data.Text (Text) +import Data.Time (addUTCTime) +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import Simplex.Chat.Markdown +import Simplex.Chat.Messages +import Simplex.Chat.Messages.CIContent +import Simplex.Chat.Protocol +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Groups +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow) +import Simplex.Messaging.Util (eitherToMaybe) +import UnliftIO.STM + +deleteContactCIs :: DB.Connection -> User -> Contact -> IO () +deleteContactCIs db user@User {userId} ct@Contact {contactId} = do + connIds <- getContactConnIds_ db user ct + forM_ connIds $ \connId -> + DB.execute db "DELETE FROM messages WHERE connection_id = ?" (Only connId) + DB.execute db "DELETE FROM chat_item_reactions WHERE contact_id = ?" (Only contactId) + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) + +getContactConnIds_ :: DB.Connection -> User -> Contact -> IO [Int64] +getContactConnIds_ db User {userId} Contact {contactId} = + map fromOnly + <$> DB.query db "SELECT connection_id FROM connections WHERE user_id = ? AND contact_id = ?" (userId, contactId) + +getGroupFileInfo :: DB.Connection -> User -> GroupInfo -> IO [CIFileInfo] +getGroupFileInfo db User {userId} GroupInfo {groupId} = + map toFileInfo + <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ?") (userId, groupId) + +deleteGroupCIs :: DB.Connection -> User -> GroupInfo -> IO () +deleteGroupCIs db User {userId} GroupInfo {groupId} = do + DB.execute db "DELETE FROM messages WHERE group_id = ?" (Only groupId) + DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ?" (Only groupId) + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId) + +createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage e) -> ExceptT StoreError IO SndMessage +createNewSndMessage db gVar connOrGroupId mkMessage = + createWithRandomId gVar $ \sharedMsgId -> do + let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId + createdAt <- getCurrentTime + DB.execute + db + [sql| + INSERT INTO messages ( + msg_sent, chat_msg_event, msg_body, connection_id, group_id, + shared_msg_id, shared_msg_id_user, created_at, updated_at + ) VALUES (?,?,?,?,?,?,?,?,?) + |] + (MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt) + msgId <- insertedRowId db + pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody} + where + (connId_, groupId_) = case connOrGroupId of + ConnectionId connId -> (Just connId, Nothing) + GroupId groupId -> (Nothing, Just groupId) + +createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64 +createSndMsgDelivery db sndMsgDelivery messageId = do + currentTs <- getCurrentTime + msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs + createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs + pure msgDeliveryId + +createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage +createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} = do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO messages (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id) VALUES (?,?,?,?,?,?,?,?)" + (MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_) + msgId <- insertedRowId db + DB.execute + db + "INSERT INTO msg_deliveries (message_id, connection_id, agent_msg_id, agent_msg_meta, agent_ack_cmd_id, chat_ts, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs) + msgDeliveryId <- insertedRowId db + createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs + pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody} + where + (connId_, groupId_) = case connOrGroupId of + ConnectionId connId' -> (Just connId', Nothing) + GroupId groupId -> (Nothing, Just groupId) + +createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO () +createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do + msgDeliveryId <- getMsgDeliveryId_ db connId agentMsgId + liftIO $ do + currentTs <- getCurrentTime + createMsgDeliveryEvent_ db msgDeliveryId sndMsgDeliveryStatus currentTs + +createRcvMsgDeliveryEvent :: DB.Connection -> Int64 -> CommandId -> MsgDeliveryStatus 'MDRcv -> IO () +createRcvMsgDeliveryEvent db connId cmdId rcvMsgDeliveryStatus = do + msgDeliveryId <- getMsgDeliveryIdByCmdId_ db connId cmdId + forM_ msgDeliveryId $ \mdId -> do + currentTs <- getCurrentTime + createMsgDeliveryEvent_ db mdId rcvMsgDeliveryStatus currentTs + +createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> UTCTime -> IO Int64 +createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId createdAt = do + DB.execute + db + [sql| + INSERT INTO msg_deliveries + (message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts, created_at, updated_at) + VALUES (?,?,?,NULL,?,?,?) + |] + (messageId, connId, agentMsgId, createdAt, createdAt, createdAt) + insertedRowId db + +createMsgDeliveryEvent_ :: DB.Connection -> Int64 -> MsgDeliveryStatus d -> UTCTime -> IO () +createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do + DB.execute + db + [sql| + INSERT INTO msg_delivery_events + (msg_delivery_id, delivery_status, created_at, updated_at) + VALUES (?,?,?,?) + |] + (msgDeliveryId, msgDeliveryStatus, createdAt, createdAt) + +getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> ExceptT StoreError IO Int64 +getMsgDeliveryId_ db connId agentMsgId = + ExceptT . firstRow fromOnly (SENoMsgDelivery connId agentMsgId) $ + DB.query + db + [sql| + SELECT msg_delivery_id + FROM msg_deliveries m + WHERE m.connection_id = ? AND m.agent_msg_id = ? + LIMIT 1 + |] + (connId, agentMsgId) + +getMsgDeliveryIdByCmdId_ :: DB.Connection -> Int64 -> CommandId -> IO (Maybe AgentMsgId) +getMsgDeliveryIdByCmdId_ db connId cmdId = + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT msg_delivery_id + FROM msg_deliveries + WHERE connection_id = ? AND agent_ack_cmd_id = ? + LIMIT 1 + |] + (connId, cmdId) + +createPendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> Maybe Int64 -> IO () +createPendingGroupMessage db groupMemberId messageId introId_ = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + INSERT INTO pending_group_messages + (group_member_id, message_id, group_member_intro_id, created_at, updated_at) VALUES (?,?,?,?,?) + |] + (groupMemberId, messageId, introId_, currentTs, currentTs) + +getPendingGroupMessages :: DB.Connection -> Int64 -> IO [PendingGroupMessage] +getPendingGroupMessages db groupMemberId = + map pendingGroupMessage + <$> DB.query + db + [sql| + SELECT pgm.message_id, m.chat_msg_event, m.msg_body, pgm.group_member_intro_id + FROM pending_group_messages pgm + JOIN messages m USING (message_id) + WHERE pgm.group_member_id = ? + ORDER BY pgm.message_id ASC + |] + (Only groupMemberId) + where + pendingGroupMessage (msgId, cmEventTag, msgBody, introId_) = + PendingGroupMessage {msgId, cmEventTag, msgBody, introId_} + +deletePendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> IO () +deletePendingGroupMessage db groupMemberId messageId = + DB.execute db "DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ?" (groupMemberId, messageId) + +deleteOldMessages :: DB.Connection -> UTCTime -> IO () +deleteOldMessages db createdAtCutoff = do + DB.execute db "DELETE FROM messages WHERE created_at <= ?" (Only createdAtCutoff) + +type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId) + +updateChatTs :: DB.Connection -> User -> ChatDirection c d -> UTCTime -> IO () +updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirection of + DirectChat Contact {contactId} -> + DB.execute + db + "UPDATE contacts SET chat_ts = ? WHERE user_id = ? AND contact_id = ?" + (chatTs, userId, contactId) + GroupChat GroupInfo {groupId} -> + DB.execute + db + "UPDATE groups SET chat_ts = ? WHERE user_id = ? AND group_id = ?" + (chatTs, userId, groupId) + _ -> pure () + +createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId +createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem timed live createdAt = + createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow timed live createdAt createdAt + where + createdByMsgId = if msgId == 0 then Nothing else Just msgId + quoteRow :: NewQuoteRow + quoteRow = case quotedItem of + Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) + Just CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content} -> + uncurry (quotedSharedMsgId,Just sentAt,Just content,,) $ case chatDir of + CIQDirectSnd -> (Just True, Nothing) + CIQDirectRcv -> (Just False, Nothing) + CIQGroupSnd -> (Just True, Nothing) + CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) + CIQGroupRcv Nothing -> (Just False, Nothing) + +createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c)) +createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent timed live itemTs createdAt = do + ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs createdAt + quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg + pure (ciId, quotedItem) + where + quotedMsg = cmToQuotedMsg chatMsgEvent + quoteRow :: NewQuoteRow + quoteRow = case quotedMsg of + Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) + Just QuotedMsg {msgRef = MsgRef {msgId = sharedMsgId, sentAt, sent, memberId}, content} -> + uncurry (sharedMsgId,Just sentAt,Just content,,) $ case chatDirection of + CDDirectRcv _ -> (Just $ not sent, Nothing) + CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ -> + (Just $ Just userMemberId == memberId, memberId) + +createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId +createNewChatItemNoMsg db user chatDirection ciContent = + createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing False + where + quoteRow :: NewQuoteRow + quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing) + +createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO ChatItemId +createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow timed live itemTs createdAt = do + DB.execute + db + [sql| + INSERT INTO chat_items ( + -- user and IDs + user_id, created_by_msg_id, contact_id, group_id, group_member_id, + -- meta + item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at, + -- quote + quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ((userId, msgId_) :. idsRow :. itemRow :. quoteRow) + ciId <- insertedRowId db + forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt + pure ciId + where + itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime) + itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed + idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64) + idsRow = case chatDirection of + CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing) + CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing) + CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId) + CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing) + +ciTimedRow :: Maybe CITimed -> (Maybe Int, Maybe UTCTime) +ciTimedRow (Just CITimed {ttl, deleteAt}) = (Just ttl, deleteAt) +ciTimedRow _ = (Nothing, Nothing) + +insertChatItemMessage_ :: DB.Connection -> ChatItemId -> MessageId -> UTCTime -> IO () +insertChatItemMessage_ db ciId msgId ts = DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, ts, ts) + +getChatItemQuote_ :: DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c) +getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} = + case chatDirection of + CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent) + CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} -> + case memberId of + Just mId + | mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId + | mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId mId + | otherwise -> getGroupChatItemQuote_ groupId mId + _ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing + where + ciQuote :: Maybe ChatItemId -> CIQDirection c -> CIQuote c + ciQuote itemId dir = CIQuote dir itemId msgId sentAt content . parseMaybeMarkdownList $ msgContentText content + getDirectChatItemQuote_ :: Int64 -> Bool -> IO (CIQuote 'CTDirect) + getDirectChatItemQuote_ contactId userSent = do + fmap ciQuoteDirect . maybeFirstRow fromOnly $ + DB.query + db + "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ? AND item_sent = ?" + (userId, contactId, msgId, userSent) + where + ciQuoteDirect :: Maybe ChatItemId -> CIQuote 'CTDirect + ciQuoteDirect = (`ciQuote` if userSent then CIQDirectSnd else CIQDirectRcv) + getUserGroupChatItemId_ :: Int64 -> IO (Maybe ChatItemId) + getUserGroupChatItemId_ groupId = + maybeFirstRow fromOnly $ + DB.query + db + "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? AND item_sent = ? AND group_member_id IS NULL" + (userId, groupId, msgId, MDSnd) + getGroupChatItemId_ :: Int64 -> MemberId -> IO (Maybe ChatItemId) + getGroupChatItemId_ groupId mId = + maybeFirstRow fromOnly $ + DB.query + db + "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? AND item_sent = ? AND group_member_id = ?" + (userId, groupId, msgId, MDRcv, mId) + getGroupChatItemQuote_ :: Int64 -> MemberId -> IO (CIQuote 'CTGroup) + getGroupChatItemQuote_ groupId mId = do + ciQuoteGroup + <$> DB.queryNamed + db + [sql| + SELECT i.chat_item_id, + -- GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, + p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences + FROM group_members m + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + LEFT JOIN contacts c ON m.contact_id = c.contact_id + LEFT JOIN chat_items i ON i.group_id = m.group_id + AND m.group_member_id = i.group_member_id + AND i.shared_msg_id = :msg_id + WHERE m.user_id = :user_id AND m.group_id = :group_id AND m.member_id = :member_id + |] + [":user_id" := userId, ":group_id" := groupId, ":member_id" := mId, ":msg_id" := msgId] + where + ciQuoteGroup :: [Only (Maybe ChatItemId) :. GroupMemberRow] -> CIQuote 'CTGroup + ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing + ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow + +getChatPreviews :: DB.Connection -> User -> Bool -> IO [AChat] +getChatPreviews db user withPCC = do + directChats <- getDirectChatPreviews_ db user + groupChats <- getGroupChatPreviews_ db user + cReqChats <- getContactRequestChatPreviews_ db user + connChats <- getContactConnectionChatPreviews_ db user withPCC + pure $ sortOn (Down . ts) (directChats <> groupChats <> cReqChats <> connChats) + where + ts :: AChat -> UTCTime + ts (AChat _ Chat {chatInfo, chatItems}) = case chatInfoChatTs chatInfo of + Just chatTs -> chatTs + Nothing -> case chatItems of + ci : _ -> max (chatItemTs ci) (chatInfoUpdatedAt chatInfo) + _ -> chatInfoUpdatedAt chatInfo + +getDirectChatPreviews_ :: DB.Connection -> User -> IO [AChat] +getDirectChatPreviews_ db user@User {userId} = do + currentTs <- getCurrentTime + map (toDirectChatPreview currentTs) + <$> DB.query + db + [sql| + SELECT + -- Contact + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + -- Connection + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, + c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, + -- ChatStats + COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), ct.unread_chat, + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- DirectQuote + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent + FROM contacts ct + JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id + JOIN connections c ON c.contact_id = ct.contact_id + LEFT JOIN ( + SELECT contact_id, MAX(chat_item_id) AS MaxId + FROM chat_items + GROUP BY contact_id + ) MaxIds ON MaxIds.contact_id = ct.contact_id + LEFT JOIN chat_items i ON i.contact_id = MaxIds.contact_id + AND i.chat_item_id = MaxIds.MaxId + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + LEFT JOIN ( + SELECT contact_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread + FROM chat_items + WHERE item_status = ? + GROUP BY contact_id + ) ChatStats ON ChatStats.contact_id = ct.contact_id + LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id + WHERE ct.user_id = ? + AND ((c.conn_level = 0 AND c.via_group_link = 0) OR ct.contact_used = 1) + AND ct.deleted = 0 + AND c.connection_id = ( + SELECT cc_connection_id FROM ( + SELECT + cc.connection_id AS cc_connection_id, + (CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord + FROM connections cc + WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id + ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC + LIMIT 1 + ) + ) + ORDER BY i.item_ts DESC + |] + (CISRcvNew, userId, ConnReady, ConnSndReady) + where + toDirectChatPreview :: UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat + toDirectChatPreview currentTs (contactRow :. connRow :. statsRow :. ciRow_) = + let contact = toContact user $ contactRow :. connRow + ci_ = toDirectChatItemList currentTs ciRow_ + stats = toChatStats statsRow + in AChat SCTDirect $ Chat (DirectChat contact) ci_ stats + +getGroupChatPreviews_ :: DB.Connection -> User -> IO [AChat] +getGroupChatPreviews_ db User {userId, userContactId} = do + currentTs <- getCurrentTime + map (toGroupChatPreview currentTs) + <$> DB.query + db + [sql| + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + -- GroupMember - membership + mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, + -- ChatStats + COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), g.unread_chat, + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- Maybe GroupMember - sender + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, + p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, + -- quoted ChatItem + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, + -- quoted GroupMember + rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, + rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, + -- deleted by GroupMember + dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, + dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, + dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences + FROM groups g + JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id + JOIN group_members mu ON mu.group_id = g.group_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + LEFT JOIN ( + SELECT group_id, MAX(chat_item_id) AS MaxId + FROM chat_items + GROUP BY group_id + ) MaxIds ON MaxIds.group_id = g.group_id + LEFT JOIN chat_items i ON i.group_id = MaxIds.group_id + AND i.chat_item_id = MaxIds.MaxId + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + LEFT JOIN ( + SELECT group_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread + FROM chat_items + WHERE item_status = ? + GROUP BY group_id + ) ChatStats ON ChatStats.group_id = g.group_id + LEFT JOIN group_members m ON m.group_member_id = i.group_member_id + LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.group_id = i.group_id + LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id + LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id) + LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id + LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id) + WHERE g.user_id = ? AND mu.contact_id = ? + ORDER BY i.item_ts DESC + |] + (CISRcvNew, userId, userContactId) + where + toGroupChatPreview :: UTCTime -> GroupInfoRow :. ChatStatsRow :. MaybeGroupChatItemRow -> AChat + toGroupChatPreview currentTs (groupInfoRow :. statsRow :. ciRow_) = + let groupInfo = toGroupInfo userContactId groupInfoRow + ci_ = toGroupChatItemList currentTs userContactId ciRow_ + stats = toChatStats statsRow + in AChat SCTGroup $ Chat (GroupChat groupInfo) ci_ stats + +getContactRequestChatPreviews_ :: DB.Connection -> User -> IO [AChat] +getContactRequestChatPreviews_ db User {userId} = + map toContactRequestChatPreview + <$> DB.query + db + [sql| + SELECT + cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id, + c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at + FROM contact_requests cr + JOIN connections c ON c.user_contact_link_id = cr.user_contact_link_id + JOIN contact_profiles p ON p.contact_profile_id = cr.contact_profile_id + JOIN user_contact_links uc ON uc.user_contact_link_id = cr.user_contact_link_id + WHERE cr.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL + |] + (userId, userId) + where + toContactRequestChatPreview :: ContactRequestRow -> AChat + toContactRequestChatPreview cReqRow = + let cReq = toContactRequest cReqRow + stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + in AChat SCTContactRequest $ Chat (ContactRequest cReq) [] stats + +getContactConnectionChatPreviews_ :: DB.Connection -> User -> Bool -> IO [AChat] +getContactConnectionChatPreviews_ _ _ False = pure [] +getContactConnectionChatPreviews_ db User {userId} _ = + map toContactConnectionChatPreview + <$> DB.query + db + [sql| + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at + FROM connections + WHERE user_id = ? AND conn_type = ? AND contact_id IS NULL AND conn_level = 0 AND via_contact IS NULL AND (via_group_link = 0 || (via_group_link = 1 AND group_link_id IS NOT NULL)) + |] + (userId, ConnContact) + where + toContactConnectionChatPreview :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, LocalAlias, UTCTime, UTCTime) -> AChat + toContactConnectionChatPreview connRow = + let conn = toPendingContactConnection connRow + stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + in AChat SCTContactConnection $ Chat (ContactConnection conn) [] stats + +getDirectChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect) +getDirectChat db user contactId pagination search_ = do + let search = fromMaybe "" search_ + ct <- getContact db user contactId + liftIO . getDirectChatReactions_ db ct =<< case pagination of + CPLast count -> getDirectChatLast_ db user ct count search + CPAfter afterId count -> getDirectChatAfter_ db user ct afterId count search + CPBefore beforeId count -> getDirectChatBefore_ db user ct beforeId count search + +getDirectChatLast_ :: DB.Connection -> User -> Contact -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) +getDirectChatLast_ db user ct@Contact {contactId} count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + chatItems <- getDirectChatItemsLast db user contactId count search + pure $ Chat (DirectChat ct) (reverse chatItems) stats + +-- the last items in reverse order (the last item in the conversation is the first in the returned list) +getDirectChatItemsLast :: DB.Connection -> User -> ContactId -> Int -> String -> ExceptT StoreError IO [CChatItem 'CTDirect] +getDirectChatItemsLast db User {userId} contactId count search = ExceptT $ do + currentTs <- getCurrentTime + mapM (toDirectChatItem currentTs) + <$> DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- DirectQuote + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent + FROM chat_items i + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%' + ORDER BY i.chat_item_id DESC + LIMIT ? + |] + (userId, contactId, search, count) + +getDirectChatAfter_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) +getDirectChatAfter_ db User {userId} ct@Contact {contactId} afterChatItemId count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + chatItems <- ExceptT getDirectChatItemsAfter_ + pure $ Chat (DirectChat ct) chatItems stats + where + getDirectChatItemsAfter_ :: IO (Either StoreError [CChatItem 'CTDirect]) + getDirectChatItemsAfter_ = do + currentTs <- getCurrentTime + mapM (toDirectChatItem currentTs) + <$> DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- DirectQuote + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent + FROM chat_items i + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%' + AND i.chat_item_id > ? + ORDER BY i.chat_item_id ASC + LIMIT ? + |] + (userId, contactId, search, afterChatItemId, count) + +getDirectChatBefore_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) +getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + chatItems <- ExceptT getDirectChatItemsBefore_ + pure $ Chat (DirectChat ct) (reverse chatItems) stats + where + getDirectChatItemsBefore_ :: IO (Either StoreError [CChatItem 'CTDirect]) + getDirectChatItemsBefore_ = do + currentTs <- getCurrentTime + mapM (toDirectChatItem currentTs) + <$> DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- DirectQuote + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent + FROM chat_items i + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%' + AND i.chat_item_id < ? + ORDER BY i.chat_item_id DESC + LIMIT ? + |] + (userId, contactId, search, beforeChatItemId, count) + +getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChat db user groupId pagination search_ = do + let search = fromMaybe "" search_ + g <- getGroupInfo db user groupId + liftIO . getGroupChatReactions_ db g =<< case pagination of + CPLast count -> getGroupChatLast_ db user g count search + CPAfter afterId count -> getGroupChatAfter_ db user g afterId count search + CPBefore beforeId count -> getGroupChatBefore_ db user g beforeId count search + +getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChatLast_ db user@User {userId} g@GroupInfo {groupId} count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + chatItemIds <- liftIO getGroupChatItemIdsLast_ + chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds + pure $ Chat (GroupChat g) (reverse chatItems) stats + where + getGroupChatItemIdsLast_ :: IO [ChatItemId] + getGroupChatItemIdsLast_ = + map fromOnly + <$> DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' + ORDER BY item_ts DESC, chat_item_id DESC + LIMIT ? + |] + (userId, groupId, search, count) + +getGroupMemberChatItemLast :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupMemberChatItemLast db user@User {userId} groupId groupMemberId = do + chatItemId <- + ExceptT . firstRow fromOnly (SEChatItemNotFoundByGroupId groupId) $ + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND group_member_id = ? + ORDER BY item_ts DESC, chat_item_id DESC + LIMIT 1 + |] + (userId, groupId, groupMemberId) + getGroupChatItem db user groupId chatItemId + +getGroupChatAfter_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChatAfter_ db user@User {userId} g@GroupInfo {groupId} afterChatItemId count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + afterChatItem <- getGroupChatItem db user groupId afterChatItemId + chatItemIds <- liftIO $ getGroupChatItemIdsAfter_ (chatItemTs afterChatItem) + chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds + pure $ Chat (GroupChat g) chatItems stats + where + getGroupChatItemIdsAfter_ :: UTCTime -> IO [ChatItemId] + getGroupChatItemIdsAfter_ afterChatItemTs = + map fromOnly + <$> DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' + AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?)) + ORDER BY item_ts ASC, chat_item_id ASC + LIMIT ? + |] + (userId, groupId, search, afterChatItemTs, afterChatItemTs, afterChatItemId, count) + +getGroupChatBefore_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChatBefore_ db user@User {userId} g@GroupInfo {groupId} beforeChatItemId count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + beforeChatItem <- getGroupChatItem db user groupId beforeChatItemId + chatItemIds <- liftIO $ getGroupChatItemIdsBefore_ (chatItemTs beforeChatItem) + chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds + pure $ Chat (GroupChat g) (reverse chatItems) stats + where + getGroupChatItemIdsBefore_ :: UTCTime -> IO [ChatItemId] + getGroupChatItemIdsBefore_ beforeChatItemTs = + map fromOnly + <$> DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' + AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?)) + ORDER BY item_ts DESC, chat_item_id DESC + LIMIT ? + |] + (userId, groupId, search, beforeChatItemTs, beforeChatItemTs, beforeChatItemId, count) + +toChatItemRef :: (ChatItemId, Maybe Int64, Maybe Int64) -> Either StoreError (ChatRef, ChatItemId) +toChatItemRef = \case + (itemId, Just contactId, Nothing) -> Right (ChatRef CTDirect contactId, itemId) + (itemId, Nothing, Just groupId) -> Right (ChatRef CTGroup groupId, itemId) + (itemId, _, _) -> Left $ SEBadChatItem itemId + +updateDirectChatItemsRead :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO () +updateDirectChatItemsRead db User {userId} contactId itemsRange_ = do + currentTs <- getCurrentTime + case itemsRange_ of + Just (fromItemId, toItemId) -> + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND contact_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? + |] + (CISRcvRead, currentTs, userId, contactId, fromItemId, toItemId, CISRcvNew) + _ -> + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND contact_id = ? AND item_status = ? + |] + (CISRcvRead, currentTs, userId, contactId, CISRcvNew) + +getDirectUnreadTimedItems :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)] +getDirectUnreadTimedItems db User {userId} contactId itemsRange_ = case itemsRange_ of + Just (fromItemId, toItemId) -> + DB.query + db + [sql| + SELECT chat_item_id, timed_ttl + FROM chat_items + WHERE user_id = ? AND contact_id = ? + AND chat_item_id >= ? AND chat_item_id <= ? + AND item_status = ? + AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + AND (item_live IS NULL OR item_live = ?) + |] + (userId, contactId, fromItemId, toItemId, CISRcvNew, False) + _ -> + DB.query + db + [sql| + SELECT chat_item_id, timed_ttl + FROM chat_items + WHERE user_id = ? AND contact_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + |] + (userId, contactId, CISRcvNew) + +setDirectChatItemDeleteAt :: DB.Connection -> User -> ContactId -> ChatItemId -> UTCTime -> IO () +setDirectChatItemDeleteAt db User {userId} contactId chatItemId deleteAt = + DB.execute + db + "UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" + (deleteAt, userId, contactId, chatItemId) + +updateGroupChatItemsRead :: DB.Connection -> UserId -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO () +updateGroupChatItemsRead db userId groupId itemsRange_ = do + currentTs <- getCurrentTime + case itemsRange_ of + Just (fromItemId, toItemId) -> + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? + |] + (CISRcvRead, currentTs, userId, groupId, fromItemId, toItemId, CISRcvNew) + _ -> + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND item_status = ? + |] + (CISRcvRead, currentTs, userId, groupId, CISRcvNew) + +getGroupUnreadTimedItems :: DB.Connection -> User -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)] +getGroupUnreadTimedItems db User {userId} groupId itemsRange_ = case itemsRange_ of + Just (fromItemId, toItemId) -> + DB.query + db + [sql| + SELECT chat_item_id, timed_ttl + FROM chat_items + WHERE user_id = ? AND group_id = ? + AND chat_item_id >= ? AND chat_item_id <= ? + AND item_status = ? + AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + AND (item_live IS NULL OR item_live = ?) + |] + (userId, groupId, fromItemId, toItemId, CISRcvNew, False) + _ -> + DB.query + db + [sql| + SELECT chat_item_id, timed_ttl + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + |] + (userId, groupId, CISRcvNew) + +setGroupChatItemDeleteAt :: DB.Connection -> User -> GroupId -> ChatItemId -> UTCTime -> IO () +setGroupChatItemDeleteAt db User {userId} groupId chatItemId deleteAt = + DB.execute + db + "UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?" + (deleteAt, userId, groupId, chatItemId) + +type ChatStatsRow = (Int, ChatItemId, Bool) + +toChatStats :: ChatStatsRow -> ChatStats +toChatStats (unreadCount, minUnreadItemId, unreadChat) = ChatStats {unreadCount, minUnreadItemId, unreadChat} + +type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe ACIFileStatus, Maybe FileProtocol) + +type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool) + +type ChatItemRow = (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId) :. (Bool, Maybe UTCTime, Maybe Bool, UTCTime, UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow + +type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe AMsgDirection, Maybe Text, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId) :. (Maybe Bool, Maybe UTCTime, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow + +type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool) + +toDirectQuote :: QuoteRow -> Maybe (CIQuote 'CTDirect) +toDirectQuote qr@(_, _, _, _, quotedSent) = toQuote qr $ direction <$> quotedSent + where + direction sent = if sent then CIQDirectSnd else CIQDirectRcv + +toQuote :: QuoteRow -> Maybe (CIQDirection c) -> Maybe (CIQuote c) +toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir = + CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent) + +-- this function can be changed so it never fails, not only avoid failure on invalid json +toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) +toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. quoteRow) = + chatItem $ fromRight invalid $ dbParseACIContent itemContentText + where + invalid = ACIContent msgDir $ CIInvalidJSON itemContentText + chatItem itemContent = case (itemContent, itemStatus, fileStatus_) of + (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Just (AFS SMDSnd fileStatus)) -> + Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent (maybeCIFile fileStatus) + (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Nothing) -> + Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent Nothing + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just (AFS SMDRcv fileStatus)) -> + Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent (maybeCIFile fileStatus) + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Nothing) -> + Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent Nothing + _ -> badItem + maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) + maybeCIFile fileStatus = + case (fileId_, fileName_, fileSize_, fileProtocol_) of + (Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol} + _ -> Nothing + cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect + cItem d chatDir ciStatus content file = + CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, reactions = [], file} + badItem = Left $ SEBadChatItem itemId + ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d + ciMeta content status = + let itemDeleted' = if itemDeleted then Just (CIDeleted @'CTDirect deletedTs) else Nothing + itemEdited' = fromMaybe False itemEdited + in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt + ciTimed :: Maybe CITimed + ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} + +toDirectChatItemList :: UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect] +toDirectChatItemList currentTs (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) = + either (const []) (: []) $ toDirectChatItem currentTs (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) +toDirectChatItemList _ _ = [] + +type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow + +type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow + +toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) +toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_ + where + direction (Just True) _ = Just CIQGroupSnd + direction (Just False) (Just member) = Just . CIQGroupRcv $ Just member + direction (Just False) Nothing = Just $ CIQGroupRcv Nothing + direction _ _ = Nothing + +-- this function can be changed so it never fails, not only avoid failure on invalid json +toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) +toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do + chatItem $ fromRight invalid $ dbParseACIContent itemContentText + where + member_ = toMaybeGroupMember userContactId memberRow_ + quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_ + deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_ + invalid = ACIContent msgDir $ CIInvalidJSON itemContentText + chatItem itemContent = case (itemContent, itemStatus, member_, fileStatus_) of + (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) -> + Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent (maybeCIFile fileStatus) + (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) -> + Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent Nothing + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) -> + Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent (maybeCIFile fileStatus) + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) -> + Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent Nothing + _ -> badItem + maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) + maybeCIFile fileStatus = + case (fileId_, fileName_, fileSize_, fileProtocol_) of + (Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol} + _ -> Nothing + cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup + cItem d chatDir ciStatus content file = + CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, reactions = [], file} + badItem = Left $ SEBadChatItem itemId + ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d + ciMeta content status = + let itemDeleted' = + if itemDeleted + then Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) + else Nothing + itemEdited' = fromMaybe False itemEdited + in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt + ciTimed :: Maybe CITimed + ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} + +toGroupChatItemList :: UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] +toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = + either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) +toGroupChatItemList _ _ _ = [] + +getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem] +getAllChatItems db user@User {userId} pagination search_ = do + itemRefs <- + rights . map toChatItemRef <$> case pagination of + CPLast count -> liftIO $ getAllChatItemsLast_ count + CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId + CPBefore beforeId count -> liftIO . getAllChatItemsBefore_ beforeId count . aChatItemTs =<< getAChatItem_ beforeId + mapM (uncurry (getAChatItem db user) >=> liftIO . getACIReactions db) itemRefs + where + search = fromMaybe "" search_ + getAChatItem_ itemId = do + chatRef <- getChatRefViaItemId db user itemId + getAChatItem db user chatRef itemId + getAllChatItemsLast_ count = + reverse + <$> DB.query + db + [sql| + SELECT chat_item_id, contact_id, group_id + FROM chat_items + WHERE user_id = ? AND item_text LIKE '%' || ? || '%' + ORDER BY item_ts DESC, chat_item_id DESC + LIMIT ? + |] + (userId, search, count) + getAllChatItemsAfter_ afterId count afterTs = + DB.query + db + [sql| + SELECT chat_item_id, contact_id, group_id + FROM chat_items + WHERE user_id = ? AND item_text LIKE '%' || ? || '%' + AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?)) + ORDER BY item_ts ASC, chat_item_id ASC + LIMIT ? + |] + (userId, search, afterTs, afterTs, afterId, count) + getAllChatItemsBefore_ beforeId count beforeTs = + reverse + <$> DB.query + db + [sql| + SELECT chat_item_id, contact_id, group_id + FROM chat_items + WHERE user_id = ? AND item_text LIKE '%' || ? || '%' + AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?)) + ORDER BY item_ts DESC, chat_item_id DESC + LIMIT ? + |] + (userId, search, beforeTs, beforeTs, beforeId, count) + +getChatItemIdByAgentMsgId :: DB.Connection -> Int64 -> AgentMsgId -> IO (Maybe ChatItemId) +getChatItemIdByAgentMsgId db connId msgId = + fmap join . maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_item_messages + WHERE message_id = ( + SELECT message_id + FROM msg_deliveries + WHERE connection_id = ? AND agent_msg_id = ? + LIMIT 1 + ) + |] + (connId, msgId) + +updateDirectChatItemStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIStatus d -> ExceptT StoreError IO (ChatItem 'CTDirect d) +updateDirectChatItemStatus db user@User {userId} contactId itemId itemStatus = do + ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId + currentTs <- liftIO getCurrentTime + liftIO $ DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" (itemStatus, currentTs, userId, contactId, itemId) + pure ci {meta = (meta ci) {itemStatus}} + where + correctDir :: CChatItem c -> Either StoreError (ChatItem c d) + correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci + +updateDirectChatItem :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d) +updateDirectChatItem db user contactId itemId newContent live msgId_ = do + ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId + liftIO $ updateDirectChatItem' db user contactId ci newContent live msgId_ + where + correctDir :: CChatItem c -> Either StoreError (ChatItem c d) + correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci + +updateDirectChatItem' :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItem 'CTDirect d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTDirect d) +updateDirectChatItem' db User {userId} contactId ci newContent live msgId_ = do + currentTs <- liftIO getCurrentTime + let ci' = updatedChatItem ci newContent live currentTs + liftIO $ updateDirectChatItem_ db userId contactId ci' msgId_ + pure ci' + +updatedChatItem :: ChatItem c d -> CIContent d -> Bool -> UTCTime -> ChatItem c d +updatedChatItem ci@ChatItem {meta = meta@CIMeta {itemStatus, itemEdited, itemTimed, itemLive}} newContent live currentTs = + let newText = ciContentToText newContent + edited' = itemEdited || (itemLive /= Just True) + live' = (live &&) <$> itemLive + timed' = case (itemStatus, itemTimed, itemLive, live) of + (CISRcvNew, _, _, _) -> itemTimed + (_, Just CITimed {ttl, deleteAt = Nothing}, Just True, False) -> + -- timed item, sent or read, not set for deletion, was live, now not live + let deleteAt' = addUTCTime (realToFrac ttl) currentTs + in Just CITimed {ttl, deleteAt = Just deleteAt'} + _ -> itemTimed + in ci {content = newContent, meta = meta {itemText = newText, itemEdited = edited', itemTimed = timed', itemLive = live'}, formattedText = parseMaybeMarkdownList newText} + +-- this function assumes that direct item with correct chat direction already exists, +-- it should be checked before calling it +updateDirectChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> UserId -> Int64 -> ChatItem 'CTDirect d -> Maybe MessageId -> IO () +updateDirectChatItem_ db userId contactId ChatItem {meta, content} msgId_ = do + let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta + itemDeleted' = isJust itemDeleted + itemDeletedTs' = itemDeletedTs =<< itemDeleted + DB.execute + db + [sql| + UPDATE chat_items + SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_deleted_ts = ?, item_edited = ?, item_live = ?, updated_at = ?, timed_ttl = ?, timed_delete_at = ? + WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? + |] + ((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, contactId, itemId)) + forM_ msgId_ $ \msgId -> liftIO $ insertChatItemMessage_ db itemId msgId updatedAt + +addInitialAndNewCIVersions :: DB.Connection -> ChatItemId -> (UTCTime, MsgContent) -> (UTCTime, MsgContent) -> IO () +addInitialAndNewCIVersions db itemId (initialTs, initialMC) (newTs, newMC) = do + versionsCount <- getChatItemVersionsCount db itemId + when (versionsCount == 0) $ + createChatItemVersion db itemId initialTs initialMC + createChatItemVersion db itemId newTs newMC + +getChatItemVersionsCount :: DB.Connection -> ChatItemId -> IO Int +getChatItemVersionsCount db itemId = do + count <- + maybeFirstRow fromOnly $ + DB.query db "SELECT COUNT(1) FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId) + pure $ fromMaybe 0 count + +createChatItemVersion :: DB.Connection -> ChatItemId -> UTCTime -> MsgContent -> IO () +createChatItemVersion db itemId itemVersionTs msgContent = + DB.execute + db + [sql| + INSERT INTO chat_item_versions (chat_item_id, msg_content, item_version_ts) + VALUES (?,?,?) + |] + (itemId, toMCText msgContent, itemVersionTs) + +deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO () +deleteDirectChatItem db User {userId} Contact {contactId} (CChatItem _ ci) = do + let itemId = chatItemId' ci + deleteChatItemMessages_ db itemId + deleteChatItemVersions_ db itemId + deleteDirectCIReactions_ db contactId ci + DB.execute + db + [sql| + DELETE FROM chat_items + WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? + |] + (userId, contactId, itemId) + +deleteChatItemMessages_ :: DB.Connection -> ChatItemId -> IO () +deleteChatItemMessages_ db itemId = + DB.execute + db + [sql| + DELETE FROM messages + WHERE message_id IN ( + SELECT message_id + FROM chat_item_messages + WHERE chat_item_id = ? + ) + |] + (Only itemId) + +deleteChatItemVersions_ :: DB.Connection -> ChatItemId -> IO () +deleteChatItemVersions_ db itemId = + DB.execute db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId) + +markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> MessageId -> UTCTime -> IO () +markDirectChatItemDeleted db User {userId} Contact {contactId} (CChatItem _ ci) msgId deletedTs = do + currentTs <- liftIO getCurrentTime + let itemId = chatItemId' ci + insertChatItemMessage_ db itemId msgId currentTs + DB.execute + db + [sql| + UPDATE chat_items + SET item_deleted = 1, item_deleted_ts = ?, updated_at = ? + WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? + |] + (deletedTs, currentTs, userId, contactId, itemId) + +getDirectChatItemBySharedMsgId :: DB.Connection -> User -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect) +getDirectChatItemBySharedMsgId db user@User {userId} contactId sharedMsgId = do + itemId <- getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId + getDirectChatItem db user contactId itemId + +getDirectChatItemByAgentMsgId :: DB.Connection -> User -> ContactId -> Int64 -> AgentMsgId -> IO (Maybe (CChatItem 'CTDirect)) +getDirectChatItemByAgentMsgId db user contactId connId msgId = do + itemId_ <- getChatItemIdByAgentMsgId db connId msgId + maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getDirectChatItem db user contactId) itemId_ + +getDirectChatItemIdBySharedMsgId_ :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 +getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId = + ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ? + ORDER BY chat_item_id DESC + LIMIT 1 + |] + (userId, contactId, sharedMsgId) + +getDirectChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTDirect) +getDirectChatItem db User {userId} contactId itemId = ExceptT $ do + currentTs <- getCurrentTime + join <$> firstRow (toDirectChatItem currentTs) (SEChatItemNotFound itemId) getItem + where + getItem = + DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- DirectQuote + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent + FROM chat_items i + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id = ? + |] + (userId, contactId, itemId) + +getDirectChatItemIdByText :: DB.Connection -> UserId -> Int64 -> SMsgDirection d -> Text -> ExceptT StoreError IO ChatItemId +getDirectChatItemIdByText db userId contactId msgDir quotedMsg = + ExceptT . firstRow fromOnly (SEChatItemNotFoundByText quotedMsg) $ + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND contact_id = ? AND item_sent = ? AND item_text LIKE ? + ORDER BY chat_item_id DESC + LIMIT 1 + |] + (userId, contactId, msgDir, quotedMsg <> "%") + +getDirectChatItemIdByText' :: DB.Connection -> User -> ContactId -> Text -> ExceptT StoreError IO ChatItemId +getDirectChatItemIdByText' db User {userId} contactId msg = + ExceptT . firstRow fromOnly (SEChatItemNotFoundByText msg) $ + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND contact_id = ? AND item_text LIKE ? + ORDER BY chat_item_id DESC + LIMIT 1 + |] + (userId, contactId, msg <> "%") + +updateGroupChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTGroup d) +updateGroupChatItem db user groupId ci newContent live msgId_ = do + currentTs <- liftIO getCurrentTime + let ci' = updatedChatItem ci newContent live currentTs + liftIO $ updateGroupChatItem_ db user groupId ci' msgId_ + pure ci' + +-- this function assumes that the group item with correct chat direction already exists, +-- it should be checked before calling it +updateGroupChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> Maybe MessageId -> IO () +updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ = do + let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta + itemDeleted' = isJust itemDeleted + itemDeletedTs' = itemDeletedTs =<< itemDeleted + DB.execute + db + [sql| + UPDATE chat_items + SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_deleted_ts = ?, item_edited = ?, item_live = ?, updated_at = ?, timed_ttl = ?, timed_delete_at = ? + WHERE user_id = ? AND group_id = ? AND chat_item_id = ? + |] + ((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId)) + forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt + +deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO () +deleteGroupChatItem db User {userId} g@GroupInfo {groupId} (CChatItem _ ci) = do + let itemId = chatItemId' ci + deleteChatItemMessages_ db itemId + deleteChatItemVersions_ db itemId + deleteGroupCIReactions_ db g ci + DB.execute + db + [sql| + DELETE FROM chat_items + WHERE user_id = ? AND group_id = ? AND chat_item_id = ? + |] + (userId, groupId, itemId) + +updateGroupChatItemModerated :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> GroupMember -> UTCTime -> IO AChatItem +updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) m@GroupMember {groupMemberId} deletedTs = do + currentTs <- getCurrentTime + let toContent = msgDirToModeratedContent_ msgDir + toText = ciModeratedText + itemId = chatItemId' ci + deleteChatItemMessages_ db itemId + deleteChatItemVersions_ db itemId + liftIO $ + DB.execute + db + [sql| + UPDATE chat_items + SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, item_content = ?, item_text = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND chat_item_id = ? + |] + (deletedTs, groupMemberId, toContent, toText, currentTs, userId, groupId, itemId) + pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just currentTs) m)}, formattedText = Nothing}) + +markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> UTCTime -> IO () +markGroupChatItemDeleted db User {userId} GroupInfo {groupId} (CChatItem _ ci) msgId byGroupMember_ deletedTs = do + currentTs <- liftIO getCurrentTime + let itemId = chatItemId' ci + deletedByGroupMemberId = case byGroupMember_ of + Just GroupMember {groupMemberId} -> Just groupMemberId + _ -> Nothing + insertChatItemMessage_ db itemId msgId currentTs + DB.execute + db + [sql| + UPDATE chat_items + SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND chat_item_id = ? + |] + (deletedTs, deletedByGroupMemberId, currentTs, userId, groupId, itemId) + +getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do + itemId <- + ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ? + ORDER BY chat_item_id DESC + LIMIT 1 + |] + (userId, groupId, groupMemberId, sharedMsgId) + getGroupChatItem db user groupId itemId + +getGroupMemberCIBySharedMsgId :: DB.Connection -> User -> GroupId -> MemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupMemberCIBySharedMsgId db user@User {userId} groupId memberId sharedMsgId = do + itemId <- + ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ + DB.query + db + [sql| + SELECT i.chat_item_id + FROM chat_items i + JOIN group_members m ON m.group_id = i.group_id + AND ((i.group_member_id IS NULL AND m.member_category = ?) + OR i.group_member_id = m.group_member_id) + WHERE i.user_id = ? AND i.group_id = ? AND m.member_id = ? AND i.shared_msg_id = ? + ORDER BY i.chat_item_id DESC + LIMIT 1 + |] + (GCUserMember, userId, groupId, memberId, sharedMsgId) + getGroupChatItem db user groupId itemId + +getGroupChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do + currentTs <- getCurrentTime + join <$> firstRow (toGroupChatItem currentTs userContactId) (SEChatItemNotFound itemId) getItem + where + getItem = + DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, + p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, + -- quoted ChatItem + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, + -- quoted GroupMember + rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, + rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, + -- deleted by GroupMember + dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, + dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, + dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences + FROM chat_items i + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + LEFT JOIN group_members m ON m.group_member_id = i.group_member_id + LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.group_id = i.group_id + LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id + LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id) + LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id + LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id) + WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ? + |] + (userId, groupId, itemId) + +getGroupChatItemIdByText :: DB.Connection -> User -> GroupId -> Maybe ContactName -> Text -> ExceptT StoreError IO ChatItemId +getGroupChatItemIdByText db User {userId, localDisplayName = userName} groupId contactName_ quotedMsg = + ExceptT . firstRow fromOnly (SEChatItemNotFoundByText quotedMsg) $ case contactName_ of + Nothing -> anyMemberChatItem_ + Just cName + | userName == cName -> userChatItem_ + | otherwise -> memberChatItem_ cName + where + anyMemberChatItem_ = + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_text like ? + ORDER BY chat_item_id DESC + LIMIT 1 + |] + (userId, groupId, quotedMsg <> "%") + userChatItem_ = + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND group_member_id IS NULL AND item_text like ? + ORDER BY chat_item_id DESC + LIMIT 1 + |] + (userId, groupId, quotedMsg <> "%") + memberChatItem_ cName = + DB.query + db + [sql| + SELECT i.chat_item_id + FROM chat_items i + JOIN group_members m ON m.group_member_id = i.group_member_id + JOIN contacts c ON c.contact_id = m.contact_id + WHERE i.user_id = ? AND i.group_id = ? AND c.local_display_name = ? AND i.item_text like ? + ORDER BY i.chat_item_id DESC + LIMIT 1 + |] + (userId, groupId, cName, quotedMsg <> "%") + +getGroupChatItemIdByText' :: DB.Connection -> User -> GroupId -> Text -> ExceptT StoreError IO ChatItemId +getGroupChatItemIdByText' db User {userId} groupId msg = + ExceptT . firstRow fromOnly (SEChatItemNotFoundByText msg) $ + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_text like ? + ORDER BY chat_item_id DESC + LIMIT 1 + |] + (userId, groupId, msg <> "%") + +getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem +getChatItemByFileId db user@User {userId} fileId = do + (chatRef, itemId) <- + ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $ + DB.query + db + [sql| + SELECT i.chat_item_id, i.contact_id, i.group_id + FROM chat_items i + JOIN files f ON f.chat_item_id = i.chat_item_id + WHERE f.user_id = ? AND f.file_id = ? + LIMIT 1 + |] + (userId, fileId) + getAChatItem db user chatRef itemId + +getChatItemByGroupId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem +getChatItemByGroupId db user@User {userId} groupId = do + (chatRef, itemId) <- + ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $ + DB.query + db + [sql| + SELECT i.chat_item_id, i.contact_id, i.group_id + FROM chat_items i + JOIN groups g ON g.chat_item_id = i.chat_item_id + WHERE g.user_id = ? AND g.group_id = ? + LIMIT 1 + |] + (userId, groupId) + getAChatItem db user chatRef itemId + +getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef +getChatRefViaItemId db User {userId} itemId = do + ExceptT . firstRow' toChatRef (SEChatItemNotFound itemId) $ + DB.query db "SELECT contact_id, group_id FROM chat_items WHERE user_id = ? AND chat_item_id = ?" (userId, itemId) + where + toChatRef = \case + (Just contactId, Nothing) -> Right $ ChatRef CTDirect contactId + (Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId + (_, _) -> Left $ SEBadChatItem itemId + +getAChatItem :: DB.Connection -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem +getAChatItem db user chatRef itemId = case chatRef of + ChatRef CTDirect contactId -> do + ct <- getContact db user contactId + (CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId + pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci + ChatRef CTGroup groupId -> do + gInfo <- getGroupInfo db user groupId + (CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId + pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci + _ -> throwError $ SEChatItemNotFound itemId + +getChatItemVersions :: DB.Connection -> ChatItemId -> IO [ChatItemVersion] +getChatItemVersions db itemId = do + map toChatItemVersion + <$> DB.query + db + [sql| + SELECT chat_item_version_id, msg_content, item_version_ts, created_at + FROM chat_item_versions + WHERE chat_item_id = ? + ORDER BY chat_item_version_id DESC + |] + (Only itemId) + where + toChatItemVersion :: (Int64, MsgContent, UTCTime, UTCTime) -> ChatItemVersion + toChatItemVersion (chatItemVersionId, msgContent, itemVersionTs, createdAt) = + let formattedText = parseMaybeMarkdownList $ msgContentText msgContent + in ChatItemVersion {chatItemVersionId, msgContent, formattedText, itemVersionTs, createdAt} + +getDirectChatReactions_ :: DB.Connection -> Contact -> Chat 'CTDirect -> IO (Chat 'CTDirect) +getDirectChatReactions_ db ct c@Chat {chatItems} = do + chatItems' <- forM chatItems $ \(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) -> do + reactions <- maybe (pure []) (getDirectCIReactions db ct) itemSharedMsgId + pure $ CChatItem md ci {reactions} + pure c {chatItems = chatItems'} + +getGroupChatReactions_ :: DB.Connection -> GroupInfo -> Chat 'CTGroup -> IO (Chat 'CTGroup) +getGroupChatReactions_ db g c@Chat {chatItems} = do + chatItems' <- forM chatItems $ \(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) -> do + let GroupMember {memberId} = chatItemMember g ci + reactions <- maybe (pure []) (getGroupCIReactions db g memberId) itemSharedMsgId + pure $ CChatItem md ci {reactions} + pure c {chatItems = chatItems'} + +getDirectCIReactions :: DB.Connection -> Contact -> SharedMsgId -> IO [CIReactionCount] +getDirectCIReactions db Contact {contactId} itemSharedMsgId = + map toCIReaction + <$> DB.query + db + [sql| + SELECT reaction, MAX(reaction_sent), COUNT(chat_item_reaction_id) + FROM chat_item_reactions + WHERE contact_id = ? AND shared_msg_id = ? + GROUP BY reaction + |] + (contactId, itemSharedMsgId) + +getGroupCIReactions :: DB.Connection -> GroupInfo -> MemberId -> SharedMsgId -> IO [CIReactionCount] +getGroupCIReactions db GroupInfo {groupId} itemMemberId itemSharedMsgId = + map toCIReaction + <$> DB.query + db + [sql| + SELECT reaction, MAX(reaction_sent), COUNT(chat_item_reaction_id) + FROM chat_item_reactions + WHERE group_id = ? AND item_member_id = ? AND shared_msg_id = ? + GROUP BY reaction + |] + (groupId, itemMemberId, itemSharedMsgId) + +getACIReactions :: DB.Connection -> AChatItem -> IO AChatItem +getACIReactions db aci@(AChatItem _ md chat ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) = case itemSharedMsgId of + Just itemSharedMId -> case chat of + DirectChat ct -> do + reactions <- getDirectCIReactions db ct itemSharedMId + pure $ AChatItem SCTDirect md chat ci {reactions} + GroupChat g -> do + let GroupMember {memberId} = chatItemMember g ci + reactions <- getGroupCIReactions db g memberId itemSharedMId + pure $ AChatItem SCTGroup md chat ci {reactions} + _ -> pure aci + _ -> pure aci + +deleteDirectCIReactions_ :: DB.Connection -> ContactId -> ChatItem 'CTDirect d -> IO () +deleteDirectCIReactions_ db contactId ChatItem {meta = CIMeta {itemSharedMsgId}} = + forM_ itemSharedMsgId $ \itemSharedMId -> + DB.execute db "DELETE FROM chat_item_reactions WHERE contact_id = ? AND shared_msg_id = ?" (contactId, itemSharedMId) + +deleteGroupCIReactions_ :: DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> IO () +deleteGroupCIReactions_ db g@GroupInfo {groupId} ci@ChatItem {meta = CIMeta {itemSharedMsgId}} = + forM_ itemSharedMsgId $ \itemSharedMId -> do + let GroupMember {memberId} = chatItemMember g ci + DB.execute + db + "DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id = ?" + (groupId, itemSharedMId, memberId) + +toCIReaction :: (MsgReaction, Bool, Int) -> CIReactionCount +toCIReaction (reaction, userReacted, totalReacted) = CIReactionCount {reaction, userReacted, totalReacted} + +getDirectReactions :: DB.Connection -> Contact -> SharedMsgId -> Bool -> IO [MsgReaction] +getDirectReactions db ct itemSharedMId sent = + map fromOnly + <$> DB.query + db + [sql| + SELECT reaction + FROM chat_item_reactions + WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? + |] + (contactId' ct, itemSharedMId, sent) + +setDirectReaction :: DB.Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () +setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs + | add = + DB.execute + db + [sql| + INSERT INTO chat_item_reactions + (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) + VALUES (?,?,?,?,?,?) + |] + (contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs) + | otherwise = + DB.execute + db + [sql| + DELETE FROM chat_item_reactions + WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ? + |] + (contactId' ct, itemSharedMId, sent, reaction) + +getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction] +getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent = + map fromOnly + <$> DB.query + db + [sql| + SELECT reaction + FROM chat_item_reactions + WHERE group_id = ? AND group_member_id = ? AND item_member_id = ? AND shared_msg_id = ? AND reaction_sent = ? + |] + (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent) + +setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () +setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reaction add msgId reactionTs + | add = + DB.execute + db + [sql| + INSERT INTO chat_item_reactions + (group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) + VALUES (?,?,?,?,?,?,?,?) + |] + (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs) + | otherwise = + DB.execute + db + [sql| + DELETE FROM chat_item_reactions + WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ? + |] + (groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction) + +getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)] +getTimedItems db User {userId} startTimedThreadCutoff = + mapMaybe toCIRefDeleteAt + <$> DB.query + db + [sql| + SELECT chat_item_id, contact_id, group_id, timed_delete_at + FROM chat_items + WHERE user_id = ? AND timed_delete_at IS NOT NULL AND timed_delete_at <= ? + |] + (userId, startTimedThreadCutoff) + where + toCIRefDeleteAt :: (ChatItemId, Maybe ContactId, Maybe GroupId, UTCTime) -> Maybe ((ChatRef, ChatItemId), UTCTime) + toCIRefDeleteAt = \case + (itemId, Just contactId, Nothing, deleteAt) -> Just ((ChatRef CTDirect contactId, itemId), deleteAt) + (itemId, Nothing, Just groupId, deleteAt) -> Just ((ChatRef CTGroup groupId, itemId), deleteAt) + _ -> Nothing + +getChatItemTTL :: DB.Connection -> User -> IO (Maybe Int64) +getChatItemTTL db User {userId} = + fmap join . maybeFirstRow fromOnly $ DB.query db "SELECT chat_item_ttl FROM settings WHERE user_id = ? LIMIT 1" (Only userId) + +setChatItemTTL :: DB.Connection -> User -> Maybe Int64 -> IO () +setChatItemTTL db User {userId} chatItemTTL = do + currentTs <- getCurrentTime + r :: (Maybe Int64) <- maybeFirstRow fromOnly $ DB.query db "SELECT 1 FROM settings WHERE user_id = ? LIMIT 1" (Only userId) + case r of + Just _ -> do + DB.execute + db + "UPDATE settings SET chat_item_ttl = ?, updated_at = ? WHERE user_id = ?" + (chatItemTTL, currentTs, userId) + Nothing -> do + DB.execute + db + "INSERT INTO settings (user_id, chat_item_ttl, created_at, updated_at) VALUES (?,?,?,?)" + (userId, chatItemTTL, currentTs, currentTs) + +getContactExpiredFileInfo :: DB.Connection -> User -> Contact -> UTCTime -> IO [CIFileInfo] +getContactExpiredFileInfo db User {userId} Contact {contactId} expirationDate = + map toFileInfo + <$> DB.query + db + (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ? AND i.created_at <= ?") + (userId, contactId, expirationDate) + +deleteContactExpiredCIs :: DB.Connection -> User -> Contact -> UTCTime -> IO () +deleteContactExpiredCIs db user@User {userId} ct@Contact {contactId} expirationDate = do + connIds <- getContactConnIds_ db user ct + forM_ connIds $ \connId -> + DB.execute db "DELETE FROM messages WHERE connection_id = ? AND created_at <= ?" (connId, expirationDate) + DB.execute db "DELETE FROM chat_item_reactions WHERE contact_id = ? AND created_at <= ?" (contactId, expirationDate) + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ? AND created_at <= ?" (userId, contactId, expirationDate) + +getGroupExpiredFileInfo :: DB.Connection -> User -> GroupInfo -> UTCTime -> UTCTime -> IO [CIFileInfo] +getGroupExpiredFileInfo db User {userId} GroupInfo {groupId} expirationDate createdAtCutoff = + map toFileInfo + <$> DB.query + db + (fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ? AND i.item_ts <= ? AND i.created_at <= ?") + (userId, groupId, expirationDate, createdAtCutoff) + +deleteGroupExpiredCIs :: DB.Connection -> User -> GroupInfo -> UTCTime -> UTCTime -> IO () +deleteGroupExpiredCIs db User {userId} GroupInfo {groupId} expirationDate createdAtCutoff = do + DB.execute db "DELETE FROM messages WHERE group_id = ? AND created_at <= ?" (groupId, min expirationDate createdAtCutoff) + DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ? AND reaction_ts <= ? AND created_at <= ?" (groupId, expirationDate, createdAtCutoff) + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND item_ts <= ? AND created_at <= ?" (userId, groupId, expirationDate, createdAtCutoff) diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs new file mode 100644 index 0000000000..32929f0229 --- /dev/null +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Simplex.Chat.Store.Migrations (migrations) where + +import Data.List (sortOn) +import Database.SQLite.Simple (Query (..)) +import Simplex.Chat.Migrations.M20220101_initial +import Simplex.Chat.Migrations.M20220122_v1_1 +import Simplex.Chat.Migrations.M20220205_chat_item_status +import Simplex.Chat.Migrations.M20220210_deduplicate_contact_requests +import Simplex.Chat.Migrations.M20220224_messages_fks +import Simplex.Chat.Migrations.M20220301_smp_servers +import Simplex.Chat.Migrations.M20220302_profile_images +import Simplex.Chat.Migrations.M20220304_msg_quotes +import Simplex.Chat.Migrations.M20220321_chat_item_edited +import Simplex.Chat.Migrations.M20220404_files_status_fields +import Simplex.Chat.Migrations.M20220514_profiles_user_id +import Simplex.Chat.Migrations.M20220626_auto_reply +import Simplex.Chat.Migrations.M20220702_calls +import Simplex.Chat.Migrations.M20220715_groups_chat_item_id +import Simplex.Chat.Migrations.M20220811_chat_items_indices +import Simplex.Chat.Migrations.M20220812_incognito_profiles +import Simplex.Chat.Migrations.M20220818_chat_notifications +import Simplex.Chat.Migrations.M20220822_groups_host_conn_custom_user_profile_id +import Simplex.Chat.Migrations.M20220823_delete_broken_group_event_chat_items +import Simplex.Chat.Migrations.M20220824_profiles_local_alias +import Simplex.Chat.Migrations.M20220909_commands +import Simplex.Chat.Migrations.M20220926_connection_alias +import Simplex.Chat.Migrations.M20220928_settings +import Simplex.Chat.Migrations.M20221001_shared_msg_id_indices +import Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items +import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id +import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id +import Simplex.Chat.Migrations.M20221012_inline_files +import Simplex.Chat.Migrations.M20221019_unread_chat +import Simplex.Chat.Migrations.M20221021_auto_accept__group_links +import Simplex.Chat.Migrations.M20221024_contact_used +import Simplex.Chat.Migrations.M20221025_chat_settings +import Simplex.Chat.Migrations.M20221029_group_link_id +import Simplex.Chat.Migrations.M20221112_server_password +import Simplex.Chat.Migrations.M20221115_server_cfg +import Simplex.Chat.Migrations.M20221129_delete_group_feature_items +import Simplex.Chat.Migrations.M20221130_delete_item_deleted +import Simplex.Chat.Migrations.M20221209_verified_connection +import Simplex.Chat.Migrations.M20221210_idxs +import Simplex.Chat.Migrations.M20221211_group_description +import Simplex.Chat.Migrations.M20221212_chat_items_timed +import Simplex.Chat.Migrations.M20221214_live_message +import Simplex.Chat.Migrations.M20221222_chat_ts +import Simplex.Chat.Migrations.M20221223_idx_chat_items_item_status +import Simplex.Chat.Migrations.M20221230_idxs +import Simplex.Chat.Migrations.M20230107_connections_auth_err_counter +import Simplex.Chat.Migrations.M20230111_users_agent_user_id +import Simplex.Chat.Migrations.M20230117_fkey_indexes +import Simplex.Chat.Migrations.M20230118_recreate_smp_servers +import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx +import Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id +import Simplex.Chat.Migrations.M20230303_group_link_role +import Simplex.Chat.Migrations.M20230317_hidden_profiles +import Simplex.Chat.Migrations.M20230318_file_description +import Simplex.Chat.Migrations.M20230321_agent_file_deleted +import Simplex.Chat.Migrations.M20230328_files_protocol +import Simplex.Chat.Migrations.M20230402_protocol_servers +import Simplex.Chat.Migrations.M20230411_extra_xftp_file_descriptions +import Simplex.Chat.Migrations.M20230420_rcv_files_to_receive +import Simplex.Chat.Migrations.M20230422_profile_contact_links +import Simplex.Chat.Migrations.M20230504_recreate_msg_delivery_events_cleanup_messages +import Simplex.Chat.Migrations.M20230505_chat_item_versions +import Simplex.Chat.Migrations.M20230511_reactions +import Simplex.Chat.Migrations.M20230519_item_deleted_ts +import Simplex.Chat.Migrations.M20230526_indexes +import Simplex.Chat.Migrations.M20230529_indexes +import Simplex.Chat.Migrations.M20230608_deleted_contacts +import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) + +schemaMigrations :: [(String, Query, Maybe Query)] +schemaMigrations = + [ ("20220101_initial", m20220101_initial, Nothing), + ("20220122_v1_1", m20220122_v1_1, Nothing), + ("20220205_chat_item_status", m20220205_chat_item_status, Nothing), + ("20220210_deduplicate_contact_requests", m20220210_deduplicate_contact_requests, Nothing), + ("20220224_messages_fks", m20220224_messages_fks, Nothing), + ("20220301_smp_servers", m20220301_smp_servers, Nothing), + ("20220302_profile_images", m20220302_profile_images, Nothing), + ("20220304_msg_quotes", m20220304_msg_quotes, Nothing), + ("20220321_chat_item_edited", m20220321_chat_item_edited, Nothing), + ("20220404_files_status_fields", m20220404_files_status_fields, Nothing), + ("20220514_profiles_user_id", m20220514_profiles_user_id, Nothing), + ("20220626_auto_reply", m20220626_auto_reply, Nothing), + ("20220702_calls", m20220702_calls, Nothing), + ("20220715_groups_chat_item_id", m20220715_groups_chat_item_id, Nothing), + ("20220811_chat_items_indices", m20220811_chat_items_indices, Nothing), + ("20220812_incognito_profiles", m20220812_incognito_profiles, Nothing), + ("20220818_chat_notifications", m20220818_chat_notifications, Nothing), + ("20220822_groups_host_conn_custom_user_profile_id", m20220822_groups_host_conn_custom_user_profile_id, Nothing), + ("20220823_delete_broken_group_event_chat_items", m20220823_delete_broken_group_event_chat_items, Nothing), + ("20220824_profiles_local_alias", m20220824_profiles_local_alias, Nothing), + ("20220909_commands", m20220909_commands, Nothing), + ("20220926_connection_alias", m20220926_connection_alias, Nothing), + ("20220928_settings", m20220928_settings, Nothing), + ("20221001_shared_msg_id_indices", m20221001_shared_msg_id_indices, Nothing), + ("20221003_delete_broken_integrity_error_chat_items", m20221003_delete_broken_integrity_error_chat_items, Nothing), + ("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id, Nothing), + ("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id, Nothing), + ("20221012_inline_files", m20221012_inline_files, Nothing), + ("20221019_unread_chat", m20221019_unread_chat, Nothing), + ("20221021_auto_accept__group_links", m20221021_auto_accept__group_links, Nothing), + ("20221024_contact_used", m20221024_contact_used, Nothing), + ("20221025_chat_settings", m20221025_chat_settings, Nothing), + ("20221029_group_link_id", m20221029_group_link_id, Nothing), + ("20221112_server_password", m20221112_server_password, Nothing), + ("20221115_server_cfg", m20221115_server_cfg, Nothing), + ("20221129_delete_group_feature_items", m20221129_delete_group_feature_items, Nothing), + ("20221130_delete_item_deleted", m20221130_delete_item_deleted, Nothing), + ("20221209_verified_connection", m20221209_verified_connection, Nothing), + ("20221210_idxs", m20221210_idxs, Nothing), + ("20221211_group_description", m20221211_group_description, Nothing), + ("20221212_chat_items_timed", m20221212_chat_items_timed, Nothing), + ("20221214_live_message", m20221214_live_message, Nothing), + ("20221222_chat_ts", m20221222_chat_ts, Nothing), + ("20221223_idx_chat_items_item_status", m20221223_idx_chat_items_item_status, Nothing), + ("20221230_idxs", m20221230_idxs, Nothing), + ("20230107_connections_auth_err_counter", m20230107_connections_auth_err_counter, Nothing), + ("20230111_users_agent_user_id", m20230111_users_agent_user_id, Nothing), + ("20230117_fkey_indexes", m20230117_fkey_indexes, Nothing), + ("20230118_recreate_smp_servers", m20230118_recreate_smp_servers, Nothing), + ("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx, Nothing), + ("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id, Nothing), + ("20230303_group_link_role", m20230303_group_link_role, Nothing), + ("20230317_hidden_profiles", m20230317_hidden_profiles, Just down_m20230317_hidden_profiles), + ("20230318_file_description", m20230318_file_description, Just down_m20230318_file_description), + ("20230321_agent_file_deleted", m20230321_agent_file_deleted, Just down_m20230321_agent_file_deleted), + ("20230328_files_protocol", m20230328_files_protocol, Just down_m20230328_files_protocol), + ("20230402_protocol_servers", m20230402_protocol_servers, Just down_m20230402_protocol_servers), + ("20230411_extra_xftp_file_descriptions", m20230411_extra_xftp_file_descriptions, Just down_m20230411_extra_xftp_file_descriptions), + ("20230420_rcv_files_to_receive", m20230420_rcv_files_to_receive, Just down_m20230420_rcv_files_to_receive), + ("20230422_profile_contact_links", m20230422_profile_contact_links, Just down_m20230422_profile_contact_links), + ("20230504_recreate_msg_delivery_events_cleanup_messages", m20230504_recreate_msg_delivery_events_cleanup_messages, Just down_m20230504_recreate_msg_delivery_events_cleanup_messages), + ("20230505_chat_item_versions", m20230505_chat_item_versions, Just down_m20230505_chat_item_versions), + ("20230511_reactions", m20230511_reactions, Just down_m20230511_reactions), + ("20230519_item_deleted_ts", m20230519_item_deleted_ts, Just down_m20230519_item_deleted_ts), + ("20230526_indexes", m20230526_indexes, Just down_m20230526_indexes), + ("20230529_indexes", m20230529_indexes, Just down_m20230529_indexes), + ("20230608_deleted_contacts", m20230608_deleted_contacts, Just down_m20230608_deleted_contacts) + ] + +-- | The list of migrations in ascending order by date +migrations :: [Migration] +migrations = sortOn name $ map migration schemaMigrations + where + migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down} diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs new file mode 100644 index 0000000000..121f563c24 --- /dev/null +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Profiles + ( AutoAccept (..), + UserContactLink (..), + createUserRecord, + createUserRecordAt, + getUsersInfo, + getUsers, + setActiveUser, + getSetActiveUser, + getUser, + getUserIdByName, + getUserByAConnId, + getUserByASndFileId, + getUserByARcvFileId, + getUserByContactId, + getUserByGroupId, + getUserByFileId, + getUserFileInfo, + deleteUserRecord, + updateUserPrivacy, + updateUserProfile, + setUserProfileContactLink, + getUserContactProfiles, + createUserContactLink, + getUserAddressConnections, + getUserContactLinks, + deleteUserAddress, + getUserAddress, + getUserContactLinkById, + updateUserAddressAutoAccept, + getProtocolServers, + overwriteProtocolServers, + createCall, + deleteCalls, + getCalls, + createCommand, + setCommandConnId, + deleteCommand, + updateCommandStatus, + getCommandDataByCorrId, + ) +where + +import Control.Monad.Except +import Data.Aeson (ToJSON) +import qualified Data.Aeson as J +import Data.Functor (($>)) +import Data.Int (Int64) +import qualified Data.List.NonEmpty as L +import Data.Maybe (fromMaybe) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import GHC.Generics (Generic) +import Simplex.Chat.Call +import Simplex.Chat.Messages +import Simplex.Chat.Protocol +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..)) +import Simplex.Messaging.Transport.Client (TransportHost) +import Simplex.Messaging.Util (safeDecodeUtf8) + +createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User +createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime + +createUserRecordAt :: DB.Connection -> AgentUserId -> Profile -> Bool -> UTCTime -> ExceptT StoreError IO User +createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, image, preferences = userPreferences} activeUser currentTs = + checkConstraint SEDuplicateName . liftIO $ do + when activeUser $ DB.execute_ db "UPDATE users SET active_user = 0" + DB.execute + db + "INSERT INTO users (agent_user_id, local_display_name, active_user, contact_id, show_ntfs, created_at, updated_at) VALUES (?,?,?,0,?,?,?)" + (auId, displayName, activeUser, True, currentTs, currentTs) + userId <- insertedRowId db + DB.execute + db + "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (displayName, displayName, userId, currentTs, currentTs) + DB.execute + db + "INSERT INTO contact_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (displayName, fullName, image, userId, userPreferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO contacts (contact_profile_id, local_display_name, user_id, is_user, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (profileId, displayName, userId, True, currentTs, currentTs) + contactId <- insertedRowId db + DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId) + pure $ toUser $ (userId, auId, contactId, profileId, activeUser, displayName, fullName, image, Nothing, userPreferences, True) :. (Nothing, Nothing) + +getUsersInfo :: DB.Connection -> IO [UserInfo] +getUsersInfo db = getUsers db >>= mapM getUserInfo + where + getUserInfo :: User -> IO UserInfo + getUserInfo user@User {userId} = do + ctCount <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT COUNT(1) + FROM chat_items i + JOIN contacts ct USING (contact_id) + WHERE i.user_id = ? AND i.item_status = ? AND (ct.enable_ntfs = 1 OR ct.enable_ntfs IS NULL) AND ct.deleted = 0 + |] + (userId, CISRcvNew) + gCount <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT COUNT(1) + FROM chat_items i + JOIN groups g USING (group_id) + WHERE i.user_id = ? AND i.item_status = ? AND (g.enable_ntfs = 1 OR g.enable_ntfs IS NULL) + |] + (userId, CISRcvNew) + pure UserInfo {user, unreadCount = fromMaybe 0 ctCount + fromMaybe 0 gCount} + +getUsers :: DB.Connection -> IO [User] +getUsers db = + map toUser <$> DB.query_ db userQuery + +setActiveUser :: DB.Connection -> UserId -> IO () +setActiveUser db userId = do + DB.execute_ db "UPDATE users SET active_user = 0" + DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?" (Only userId) + +getSetActiveUser :: DB.Connection -> UserId -> ExceptT StoreError IO User +getSetActiveUser db userId = do + liftIO $ setActiveUser db userId + getUser db userId + +getUser :: DB.Connection -> UserId -> ExceptT StoreError IO User +getUser db userId = + ExceptT . firstRow toUser (SEUserNotFound userId) $ + DB.query db (userQuery <> " WHERE u.user_id = ?") (Only userId) + +getUserIdByName :: DB.Connection -> UserName -> ExceptT StoreError IO Int64 +getUserIdByName db uName = + ExceptT . firstRow fromOnly (SEUserNotFoundByName uName) $ + DB.query db "SELECT user_id FROM users WHERE local_display_name = ?" (Only uName) + +getUserByAConnId :: DB.Connection -> AgentConnId -> IO (Maybe User) +getUserByAConnId db agentConnId = + maybeFirstRow toUser $ + DB.query db (userQuery <> " JOIN connections c ON c.user_id = u.user_id WHERE c.agent_conn_id = ?") (Only agentConnId) + +getUserByASndFileId :: DB.Connection -> AgentSndFileId -> IO (Maybe User) +getUserByASndFileId db aSndFileId = + maybeFirstRow toUser $ + DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.agent_snd_file_id = ?") (Only aSndFileId) + +getUserByARcvFileId :: DB.Connection -> AgentRcvFileId -> IO (Maybe User) +getUserByARcvFileId db aRcvFileId = + maybeFirstRow toUser $ + DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id JOIN rcv_files r ON r.file_id = f.file_id WHERE r.agent_rcv_file_id = ?") (Only aRcvFileId) + +getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User +getUserByContactId db contactId = + ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $ + DB.query db (userQuery <> " JOIN contacts ct ON ct.user_id = u.user_id WHERE ct.contact_id = ? AND ct.deleted = 0") (Only contactId) + +getUserByGroupId :: DB.Connection -> GroupId -> ExceptT StoreError IO User +getUserByGroupId db groupId = + ExceptT . firstRow toUser (SEUserNotFoundByGroupId groupId) $ + DB.query db (userQuery <> " JOIN groups g ON g.user_id = u.user_id WHERE g.group_id = ?") (Only groupId) + +getUserByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO User +getUserByFileId db fileId = + ExceptT . firstRow toUser (SEUserNotFoundByFileId fileId) $ + DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.file_id = ?") (Only fileId) + +getUserFileInfo :: DB.Connection -> User -> IO [CIFileInfo] +getUserFileInfo db User {userId} = + map toFileInfo + <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ?") (Only userId) + +deleteUserRecord :: DB.Connection -> User -> IO () +deleteUserRecord db User {userId} = + DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) + +updateUserPrivacy :: DB.Connection -> User -> IO () +updateUserPrivacy db User {userId, showNtfs, viewPwdHash} = + DB.execute + db + [sql| + UPDATE users + SET view_pwd_hash = ?, view_pwd_salt = ?, show_ntfs = ? + WHERE user_id = ? + |] + (hashSalt viewPwdHash :. (showNtfs, userId)) + where + hashSalt = L.unzip . fmap (\UserPwdHash {hash, salt} -> (hash, salt)) + +updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User +updateUserProfile db user p' + | displayName == newName = do + liftIO $ updateContactProfile_ db userId profileId p' + pure user {profile, fullPreferences} + | otherwise = + checkConstraint SEDuplicateName . liftIO $ do + currentTs <- getCurrentTime + DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId) + DB.execute + db + "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (newName, newName, userId, currentTs, currentTs) + updateContactProfile_' db userId profileId p' currentTs + updateContact_ db userId userContactId localDisplayName newName currentTs + pure user {localDisplayName = newName, profile, fullPreferences} + where + User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user + Profile {displayName = newName, preferences} = p' + profile = toLocalProfile profileId p' localAlias + fullPreferences = mergePreferences Nothing preferences + +setUserProfileContactLink :: DB.Connection -> User -> Maybe UserContactLink -> IO User +setUserProfileContactLink db user@User {userId, profile = p@LocalProfile {profileId}} ucl_ = do + ts <- getCurrentTime + DB.execute + db + [sql| + UPDATE contact_profiles + SET contact_link = ?, updated_at = ? + WHERE user_id = ? AND contact_profile_id = ? + |] + (connReqContact_, ts, userId, profileId) + pure (user :: User) {profile = p {contactLink = connReqContact_}} + where + connReqContact_ = case ucl_ of + Just UserContactLink {connReqContact} -> Just connReqContact + _ -> Nothing + +-- only used in tests +getUserContactProfiles :: DB.Connection -> User -> IO [Profile] +getUserContactProfiles db User {userId} = + map toContactProfile + <$> DB.query + db + [sql| + SELECT display_name, full_name, image, contact_link, preferences + FROM contact_profiles + WHERE user_id = ? + |] + (Only userId) + where + toContactProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) -> (Profile) + toContactProfile (displayName, fullName, image, contactLink, preferences) = Profile {displayName, fullName, image, contactLink, preferences} + +createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> ExceptT StoreError IO () +createUserContactLink db User {userId} agentConnId cReq = + checkConstraint SEDuplicateContactLink . liftIO $ do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?)" + (userId, cReq, currentTs, currentTs) + userContactLinkId <- insertedRowId db + void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs + +getUserAddressConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection] +getUserAddressConnections db User {userId} = do + cs <- liftIO getUserAddressConnections_ + if null cs then throwError SEUserContactLinkNotFound else pure cs + where + getUserAddressConnections_ :: IO [Connection] + getUserAddressConnections_ = + map toConnection + <$> DB.query + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM connections c + JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id + WHERE c.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL + |] + (userId, userId) + +getUserContactLinks :: DB.Connection -> User -> IO [(Connection, UserContact)] +getUserContactLinks db User {userId} = + map toUserContactConnection + <$> DB.query + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, + uc.user_contact_link_id, uc.conn_req_contact, uc.group_id + FROM connections c + JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id + WHERE c.user_id = ? AND uc.user_id = ? + |] + (userId, userId) + where + toUserContactConnection :: (ConnectionRow :. (Int64, ConnReqContact, Maybe GroupId)) -> (Connection, UserContact) + toUserContactConnection (connRow :. (userContactLinkId, connReqContact, groupId)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact, groupId}) + +deleteUserAddress :: DB.Connection -> User -> IO () +deleteUserAddress db user@User {userId} = do + DB.execute + db + [sql| + DELETE FROM connections WHERE connection_id IN ( + SELECT connection_id + FROM connections c + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL + ) + |] + (Only userId) + DB.executeNamed + db + [sql| + DELETE FROM display_names + WHERE user_id = :user_id + AND local_display_name in ( + SELECT cr.local_display_name + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL + ) + |] + [":user_id" := userId] + DB.executeNamed + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT cr.contact_profile_id + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL + ) + |] + [":user_id" := userId] + void $ setUserProfileContactLink db user Nothing + DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL" (Only userId) + +data UserContactLink = UserContactLink + { connReqContact :: ConnReqContact, + autoAccept :: Maybe AutoAccept + } + deriving (Show, Generic) + +instance ToJSON UserContactLink where toEncoding = J.genericToEncoding J.defaultOptions + +data AutoAccept = AutoAccept + { acceptIncognito :: Bool, + autoReply :: Maybe MsgContent + } + deriving (Show, Generic) + +instance ToJSON AutoAccept where toEncoding = J.genericToEncoding J.defaultOptions + +toUserContactLink :: (ConnReqContact, Bool, Bool, Maybe MsgContent) -> UserContactLink +toUserContactLink (connReq, autoAccept, acceptIncognito, autoReply) = + UserContactLink connReq $ + if autoAccept then Just AutoAccept {acceptIncognito, autoReply} else Nothing + +getUserAddress :: DB.Connection -> User -> ExceptT StoreError IO UserContactLink +getUserAddress db User {userId} = + ExceptT . firstRow toUserContactLink SEUserContactLinkNotFound $ + DB.query + db + [sql| + SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content + FROM user_contact_links + WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL + |] + (Only userId) + +getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (UserContactLink, Maybe GroupId, GroupMemberRole)) +getUserContactLinkById db userId userContactLinkId = + maybeFirstRow (\(ucl :. (groupId_, mRole_)) -> (toUserContactLink ucl, groupId_, fromMaybe GRMember mRole_)) $ + DB.query + db + [sql| + SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role + FROM user_contact_links + WHERE user_id = ? + AND user_contact_link_id = ? + |] + (userId, userContactLinkId) + +updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink +updateUserAddressAutoAccept db user@User {userId} autoAccept = do + link <- getUserAddress db user + liftIO updateUserAddressAutoAccept_ $> link {autoAccept} + where + updateUserAddressAutoAccept_ = + DB.execute + db + [sql| + UPDATE user_contact_links + SET auto_accept = ?, auto_accept_incognito = ?, auto_reply_msg_content = ? + WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL + |] + (ucl :. Only userId) + ucl = case autoAccept of + Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply) + _ -> (False, False, Nothing) + + + + +getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p] +getProtocolServers db User {userId} = + map toServerCfg + <$> DB.query + db + [sql| + SELECT host, port, key_hash, basic_auth, preset, tested, enabled + FROM protocol_servers + WHERE user_id = ? AND protocol = ?; + |] + (userId, decodeLatin1 $ strEncode protocol) + where + protocol = protocolTypeI @p + toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg p + toServerCfg (host, port, keyHash, auth_, preset, tested, enabled) = + let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_) + in ServerCfg {server, preset, tested, enabled} + +overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO () +overwriteProtocolServers db User {userId} servers = + checkConstraint SEUniqueID . ExceptT $ do + currentTs <- getCurrentTime + DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, protocol) + forM_ servers $ \ServerCfg {server, preset, tested, enabled} -> do + let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server + DB.execute + db + [sql| + INSERT INTO protocol_servers + (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?) + |] + ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs)) + pure $ Right () + where + protocol = decodeLatin1 $ strEncode $ protocolTypeI @p + +createCall :: DB.Connection -> User -> Call -> UTCTime -> IO () +createCall db user@User {userId} Call {contactId, callId, chatItemId, callState} callTs = do + currentTs <- getCurrentTime + deleteCalls db user contactId + DB.execute + db + [sql| + INSERT INTO calls + (contact_id, shared_call_id, chat_item_id, call_state, call_ts, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?) + |] + (contactId, callId, chatItemId, callState, callTs, userId, currentTs, currentTs) + +deleteCalls :: DB.Connection -> User -> ContactId -> IO () +deleteCalls db User {userId} contactId = do + DB.execute db "DELETE FROM calls WHERE user_id = ? AND contact_id = ?" (userId, contactId) + +getCalls :: DB.Connection -> IO [Call] +getCalls db = + map toCall + <$> DB.query_ + db + [sql| + SELECT + contact_id, shared_call_id, chat_item_id, call_state, call_ts + FROM calls + ORDER BY call_ts ASC + |] + where + toCall :: (ContactId, CallId, ChatItemId, CallState, UTCTime) -> Call + toCall (contactId, callId, chatItemId, callState, callTs) = Call {contactId, callId, chatItemId, callState, callTs} + +createCommand :: DB.Connection -> User -> Maybe Int64 -> CommandFunction -> IO CommandId +createCommand db User {userId} connId commandFunction = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + INSERT INTO commands (connection_id, command_function, command_status, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?) + |] + (connId, commandFunction, CSCreated, userId, currentTs, currentTs) + insertedRowId db + +deleteCommand :: DB.Connection -> User -> CommandId -> IO () +deleteCommand db User {userId} cmdId = + DB.execute db "DELETE FROM commands WHERE user_id = ? AND command_id = ?" (userId, cmdId) + +updateCommandStatus :: DB.Connection -> User -> CommandId -> CommandStatus -> IO () +updateCommandStatus db User {userId} cmdId status = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE commands + SET command_status = ?, updated_at = ? + WHERE user_id = ? AND command_id = ? + |] + (status, updatedAt, userId, cmdId) + +getCommandDataByCorrId :: DB.Connection -> User -> ACorrId -> IO (Maybe CommandData) +getCommandDataByCorrId db User {userId} corrId = + maybeFirstRow toCommandData $ + DB.query + db + [sql| + SELECT command_id, connection_id, command_function, command_status + FROM commands + WHERE user_id = ? AND command_id = ? + |] + (userId, commandId corrId) + where + toCommandData :: (CommandId, Maybe Int64, CommandFunction, CommandStatus) -> CommandData + toCommandData (cmdId, cmdConnId, cmdFunction, cmdStatus) = CommandData {cmdId, cmdConnId, cmdFunction, cmdStatus} diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs new file mode 100644 index 0000000000..f46ff35b3d --- /dev/null +++ b/src/Simplex/Chat/Store/Shared.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Shared where + +import Control.Concurrent.STM (stateTVar) +import Control.Exception (Exception) +import qualified Control.Exception as E +import Control.Monad.Except +import Crypto.Random (ChaChaDRG, randomBytesGenerate) +import Data.Aeson (ToJSON) +import qualified Data.Aeson as J +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Base64 as B64 +import Data.Int (Int64) +import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), Query, SQLError, (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import GHC.Generics (Generic) +import Simplex.Chat.Messages +import Simplex.Chat.Protocol +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) +import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) +import UnliftIO.STM + +-- These error type constructors must be added to mobile apps +data StoreError + = SEDuplicateName + | SEUserNotFound {userId :: UserId} + | SEUserNotFoundByName {contactName :: ContactName} + | SEUserNotFoundByContactId {contactId :: ContactId} + | SEUserNotFoundByGroupId {groupId :: GroupId} + | SEUserNotFoundByFileId {fileId :: FileTransferId} + | SEUserNotFoundByContactRequestId {contactRequestId :: Int64} + | SEContactNotFound {contactId :: ContactId} + | SEContactNotFoundByName {contactName :: ContactName} + | SEContactNotReady {contactName :: ContactName} + | SEDuplicateContactLink + | SEUserContactLinkNotFound + | SEContactRequestNotFound {contactRequestId :: Int64} + | SEContactRequestNotFoundByName {contactName :: ContactName} + | SEGroupNotFound {groupId :: GroupId} + | SEGroupNotFoundByName {groupName :: GroupName} + | SEGroupMemberNameNotFound {groupId :: GroupId, groupMemberName :: ContactName} + | SEGroupMemberNotFound {groupMemberId :: GroupMemberId} + | SEGroupWithoutUser + | SEDuplicateGroupMember + | SEGroupAlreadyJoined + | SEGroupInvitationNotFound + | SESndFileNotFound {fileId :: FileTransferId} + | SESndFileInvalid {fileId :: FileTransferId} + | SERcvFileNotFound {fileId :: FileTransferId} + | SERcvFileDescrNotFound {fileId :: FileTransferId} + | SEFileNotFound {fileId :: FileTransferId} + | SERcvFileInvalid {fileId :: FileTransferId} + | SERcvFileInvalidDescrPart + | SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId} + | SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId} + | SESndFileNotFoundXFTP {agentSndFileId :: AgentSndFileId} + | SERcvFileNotFoundXFTP {agentRcvFileId :: AgentRcvFileId} + | SEConnectionNotFound {agentConnId :: AgentConnId} + | SEConnectionNotFoundById {connId :: Int64} + | SEPendingConnectionNotFound {connId :: Int64} + | SEIntroNotFound + | SEUniqueID + | SEInternalError {message :: String} + | SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId} + | SEBadChatItem {itemId :: ChatItemId} + | SEChatItemNotFound {itemId :: ChatItemId} + | SEChatItemNotFoundByText {text :: Text} + | SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId} + | SEChatItemNotFoundByFileId {fileId :: FileTransferId} + | SEChatItemNotFoundByGroupId {groupId :: GroupId} + | SEProfileNotFound {profileId :: Int64} + | SEDuplicateGroupLink {groupInfo :: GroupInfo} + | SEGroupLinkNotFound {groupInfo :: GroupInfo} + | SEHostMemberIdNotFound {groupId :: Int64} + | SEContactNotFoundByFileId {fileId :: FileTransferId} + deriving (Show, Exception, Generic) + +instance ToJSON StoreError where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SE" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SE" + +insertedRowId :: DB.Connection -> IO Int64 +insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()" + +checkConstraint :: StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a +checkConstraint err action = ExceptT $ runExceptT action `E.catch` (pure . Left . handleSQLError err) + +handleSQLError :: StoreError -> SQLError -> StoreError +handleSQLError err e + | DB.sqlError e == DB.ErrorConstraint = err + | otherwise = SEInternalError $ show e + +fileInfoQuery :: Query +fileInfoQuery = + [sql| + SELECT f.file_id, f.ci_file_status, f.file_path + FROM chat_items i + JOIN files f ON f.chat_item_id = i.chat_item_id + |] + +toFileInfo :: (Int64, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo +toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath} + +type EntityIdsRow = (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64) + +type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, Bool, Maybe GroupLinkId, Maybe Int64, ConnStatus, ConnType, LocalAlias) :. EntityIdsRow :. (UTCTime, Maybe Text, Maybe UTCTime, Int) + +type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe Bool, Maybe GroupLinkId, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe Int) + +toConnection :: ConnectionRow -> Connection +toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter)) = + let entityId = entityId_ connType + connectionCode = SecurityCode <$> code_ <*> verifiedAt_ + in Connection {connId, agentConnId = AgentConnId acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias, entityId, connectionCode, authErrCounter, createdAt} + where + entityId_ :: ConnType -> Maybe Int64 + entityId_ ConnContact = contactId + entityId_ ConnMember = groupMemberId + entityId_ ConnRcvFile = rcvFileId + entityId_ ConnSndFile = sndFileId + entityId_ ConnUserContact = userContactLinkId + +toMaybeConnection :: MaybeConnectionRow -> Maybe Connection +toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just authErrCounter)) = + Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter)) +toMaybeConnection _ = Nothing + +createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> IO Connection +createConnection_ db userId connType entityId acId viaContact viaUserContactLink customUserProfileId connLevel currentTs = do + viaLinkGroupId :: Maybe Int64 <- fmap join . forM viaUserContactLink $ \ucLinkId -> + maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? AND group_id IS NOT NULL" (userId, ucLinkId) + let viaGroupLink = isJust viaLinkGroupId + DB.execute + db + [sql| + INSERT INTO connections ( + user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, custom_user_profile_id, conn_status, conn_type, + contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (userId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, customUserProfileId, ConnNew, connType) + :. (ent ConnContact, ent ConnMember, ent ConnSndFile, ent ConnRcvFile, ent ConnUserContact, currentTs, currentTs) + ) + connId <- insertedRowId db + pure Connection {connId, agentConnId = AgentConnId acId, connType, entityId, viaContact, viaUserContactLink, viaGroupLink, groupLinkId = Nothing, customUserProfileId, connLevel, connStatus = ConnNew, localAlias = "", createdAt = currentTs, connectionCode = Nothing, authErrCounter = 0} + where + ent ct = if connType == ct then entityId else Nothing + +setCommandConnId :: DB.Connection -> User -> CommandId -> Int64 -> IO () +setCommandConnId db User {userId} cmdId connId = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE commands + SET connection_id = ?, updated_at = ? + WHERE user_id = ? AND command_id = ? + |] + (connId, updatedAt, userId, cmdId) + +createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> LocalAlias -> Maybe Int64 -> UTCTime -> Maybe UTCTime -> ExceptT StoreError IO (Text, ContactId, ProfileId) +createContact_ db userId connId Profile {displayName, fullName, image, contactLink, preferences} localAlias viaGroup currentTs chatTs = + ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do + DB.execute + db + "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, local_alias, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" + (displayName, fullName, image, contactLink, userId, localAlias, preferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO contacts (contact_profile_id, local_display_name, user_id, via_group, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?)" + (profileId, ldn, userId, viaGroup, currentTs, currentTs, chatTs) + contactId <- insertedRowId db + DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId) + pure $ Right (ldn, contactId, profileId) + +deleteUnusedIncognitoProfileById_ :: DB.Connection -> User -> ProfileId -> IO () +deleteUnusedIncognitoProfileById_ db User {userId} profile_id = + DB.executeNamed + db + [sql| + DELETE FROM contact_profiles + WHERE user_id = :user_id AND contact_profile_id = :profile_id AND incognito = 1 + AND 1 NOT IN ( + SELECT 1 FROM connections + WHERE user_id = :user_id AND custom_user_profile_id = :profile_id LIMIT 1 + ) + AND 1 NOT IN ( + SELECT 1 FROM group_members + WHERE user_id = :user_id AND member_profile_id = :profile_id LIMIT 1 + ) + |] + [":user_id" := userId, ":profile_id" := profile_id] + +type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) + +toContact :: User -> ContactRow :. ConnectionRow -> Contact +toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = + let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + activeConn = toConnection connRow + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} + +toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact +toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = + let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + in case toMaybeConnection connRow of + Just activeConn -> + let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} + _ -> Left $ SEContactNotReady localDisplayName + +getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile +getProfileById db userId profileId = + ExceptT . firstRow toProfile (SEProfileNotFound profileId) $ + DB.query + db + [sql| + SELECT cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, cp.preferences -- , ct.user_preferences + FROM contact_profiles cp + WHERE cp.user_id = ? AND cp.contact_profile_id = ? + |] + (userId, profileId) + where + toProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences) -> LocalProfile + toProfile (displayName, fullName, image, contactLink, localAlias, preferences) = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + +type ContactRequestRow = (Int64, ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact) :. (Maybe XContactId, Maybe Preferences, UTCTime, UTCTime) + +toContactRequest :: ContactRequestRow -> UserContactRequest +toContactRequest ((contactRequestId, localDisplayName, agentInvitationId, userContactLinkId, agentContactConnId, profileId, displayName, fullName, image, contactLink) :. (xContactId, preferences, createdAt, updatedAt)) = do + let profile = Profile {displayName, fullName, image, contactLink, preferences} + in UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, localDisplayName, profileId, profile, xContactId, createdAt, updatedAt} + +userQuery :: Query +userQuery = + [sql| + SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.local_display_name, ucp.full_name, ucp.image, ucp.contact_link, ucp.preferences, u.show_ntfs, u.view_pwd_hash, u.view_pwd_salt + FROM users u + JOIN contacts uct ON uct.contact_id = u.contact_id + JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id + |] + +toUser :: (UserId, UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences, Bool) :. (Maybe B64UrlByteString, Maybe B64UrlByteString) -> User +toUser ((userId, auId, userContactId, profileId, activeUser, displayName, fullName, image, contactLink, userPreferences, showNtfs) :. (viewPwdHash_, viewPwdSalt_)) = + User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, fullPreferences, showNtfs, viewPwdHash} + where + profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences = userPreferences, localAlias = ""} + fullPreferences = mergePreferences Nothing userPreferences + viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_ + +toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, LocalAlias, UTCTime, UTCTime) -> PendingContactConnection +toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt) = + PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt} + +-- | Saves unique local display name based on passed displayName, suffixed with _N if required. +-- This function should be called inside transaction. +withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO (Either StoreError a)) -> IO (Either StoreError a) +withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreateName` 20) + where + getLdnSuffix :: IO Int + getLdnSuffix = + maybe 0 ((+ 1) . fromOnly) . listToMaybe + <$> DB.queryNamed + db + [sql| + SELECT ldn_suffix FROM display_names + WHERE user_id = :user_id AND ldn_base = :display_name + ORDER BY ldn_suffix DESC + LIMIT 1 + |] + [":user_id" := userId, ":display_name" := displayName] + tryCreateName :: Int -> Int -> IO (Either StoreError a) + tryCreateName _ 0 = pure $ Left SEDuplicateName + tryCreateName ldnSuffix attempts = do + currentTs <- getCurrentTime + let ldn = displayName <> (if ldnSuffix == 0 then "" else T.pack $ '_' : show ldnSuffix) + E.try (insertName ldn currentTs) >>= \case + Right () -> action ldn + Left e + | DB.sqlError e == DB.ErrorConstraint -> tryCreateName (ldnSuffix + 1) (attempts - 1) + | otherwise -> E.throwIO e + where + insertName ldn ts = + DB.execute + db + [sql| + INSERT INTO display_names + (local_display_name, ldn_base, ldn_suffix, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?) + |] + (ldn, displayName, ldnSuffix, userId, ts, ts) + +createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a +createWithRandomId = createWithRandomBytes 12 + +createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a +createWithRandomBytes size gVar create = tryCreate 3 + where + tryCreate :: Int -> ExceptT StoreError IO a + tryCreate 0 = throwError SEUniqueID + tryCreate n = do + id' <- liftIO $ encodedRandomBytes gVar size + liftIO (E.try $ create id') >>= \case + Right x -> pure x + Left e + | DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1) + | otherwise -> throwError . SEInternalError $ show e + +encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString +encodedRandomBytes gVar = fmap B64.encode . randomBytes gVar + +randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString +randomBytes gVar = atomically . stateTVar gVar . randomBytesGenerate diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 6cc5cc1d0d..13eb391f00 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -23,6 +23,7 @@ import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatDataba import Simplex.Chat.Core import Simplex.Chat.Options import Simplex.Chat.Store +import Simplex.Chat.Store.Profiles import Simplex.Chat.Terminal import Simplex.Chat.Terminal.Output (newChatTerminal) import Simplex.Chat.Types (AgentUserId (..), Profile, User (..)) diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index db8d634571..ec7a87cfea 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -18,7 +18,7 @@ import Data.Maybe (fromMaybe) import Data.String import qualified Data.Text as T import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), InlineFilesConfig (..), defaultInlineFilesConfig) -import Simplex.Chat.Store (getUserContactProfiles) +import Simplex.Chat.Store.Profiles (getUserContactProfiles) import Simplex.Chat.Types import Simplex.Messaging.Agent.Store.SQLite (withTransaction) import Simplex.Messaging.Encoding.String diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 339dee6bb2..f8d4438293 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -6,6 +6,7 @@ import ChatTests.Utils import Control.Monad.Except import Simplex.Chat.Mobile import Simplex.Chat.Store +import Simplex.Chat.Store.Profiles import Simplex.Chat.Types (AgentUserId (..), Profile (..)) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..)) import System.FilePath (()) From 5c105cb74673daa714de96f47ee1b6243b3cc413 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 18 Jun 2023 12:46:38 +0100 Subject: [PATCH 5/9] core: mark chats as favorite (#2591) --- simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 14 +++++--- .../Migrations/M20230618_favorite_chats.hs | 20 ++++++++++++ src/Simplex/Chat/Migrations/chat_schema.sql | 4 ++- src/Simplex/Chat/Store/Connections.hs | 10 +++--- src/Simplex/Chat/Store/Direct.hs | 10 +++--- src/Simplex/Chat/Store/Groups.hs | 32 +++++++++---------- src/Simplex/Chat/Store/Messages.hs | 4 +-- src/Simplex/Chat/Store/Migrations.hs | 4 ++- src/Simplex/Chat/Store/Shared.hs | 10 +++--- src/Simplex/Chat/Types.hs | 10 ++++-- 11 files changed, 77 insertions(+), 42 deletions(-) create mode 100644 src/Simplex/Chat/Migrations/M20230618_favorite_chats.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index b2ba047ce4..8620f881d7 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -101,6 +101,7 @@ library Simplex.Chat.Migrations.M20230526_indexes Simplex.Chat.Migrations.M20230529_indexes Simplex.Chat.Migrations.M20230608_deleted_contacts + Simplex.Chat.Migrations.M20230618_favorite_chats Simplex.Chat.Mobile Simplex.Chat.Mobile.WebRTC Simplex.Chat.Options diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c186c26d22..4582ef4767 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1173,11 +1173,17 @@ processChatCommand = \case ok user _ -> throwChatError CEGroupMemberNotActive ShowMessages (ChatName cType name) ntfOn -> withUser $ \user -> do - chatId <- case cType of - CTDirect -> withStore $ \db -> getContactIdByName db user name - CTGroup -> withStore $ \db -> getGroupIdByName db user name + (chatId, chatSettings) <- case cType of + CTDirect -> withStore $ \db -> do + ctId <- getContactIdByName db user name + Contact {chatSettings} <- getContact db user ctId + pure (ctId, chatSettings) + CTGroup -> withStore $ \db -> do + gId <- getGroupIdByName db user name + GroupInfo {chatSettings} <- getGroupInfo db user gId + pure (gId, chatSettings) _ -> throwChatError $ CECommandError "not supported" - processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ ChatSettings ntfOn + processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ chatSettings {enableNtfs = ntfOn} ContactInfo cName -> withContactName cName APIContactInfo GroupMemberInfo gName mName -> withMemberName gName mName APIGroupMemberInfo SwitchContact cName -> withContactName cName APISwitchContact diff --git a/src/Simplex/Chat/Migrations/M20230618_favorite_chats.hs b/src/Simplex/Chat/Migrations/M20230618_favorite_chats.hs new file mode 100644 index 0000000000..66f65a926b --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20230618_favorite_chats.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20230618_favorite_chats where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20230618_favorite_chats :: Query +m20230618_favorite_chats = + [sql| +ALTER TABLE contacts ADD COLUMN favorite INTEGER NOT NULL DEFAULT 0; +ALTER TABLE groups ADD COLUMN favorite INTEGER NOT NULL DEFAULT 0; +|] + +down_m20230618_favorite_chats :: Query +down_m20230618_favorite_chats = + [sql| +ALTER TABLE contacts DROP COLUMN favorite; +ALTER TABLE groups DROP COLUMN favorite; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 95f22cef39..05c7857a24 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -64,6 +64,7 @@ CREATE TABLE contacts( user_preferences TEXT DEFAULT '{}' CHECK(user_preferences NOT NULL), chat_ts TEXT, deleted INTEGER NOT NULL DEFAULT 0, + favorite INTEGER NOT NULL DEFAULT 0, FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE CASCADE @@ -135,7 +136,8 @@ CREATE TABLE groups( enable_ntfs INTEGER, host_conn_custom_user_profile_id INTEGER REFERENCES contact_profiles ON DELETE SET NULL, unread_chat INTEGER DEFAULT 0 CHECK(unread_chat NOT NULL), - chat_ts TEXT, -- received + chat_ts TEXT, + favorite INTEGER NOT NULL DEFAULT 0, -- received FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE CASCADE diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index da685f4d75..5b0b07281a 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -60,17 +60,17 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do db [sql| SELECT - c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, c.via_group, c.contact_used, c.enable_ntfs, + c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, c.via_group, c.contact_used, c.enable_ntfs, c.favorite, p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts FROM contacts c JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0 |] (userId, contactId) - toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)] -> Either StoreError Contact - toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)] = + toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool, Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)] -> Either StoreError Contact + toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_, favorite) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)] = let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, favorite} mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" @@ -82,7 +82,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do [sql| SELECT -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 27aeab7cf5..2f3344bb66 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -134,7 +134,7 @@ getConnReqContactXContactId db user@User {userId} cReqHash = do [sql| SELECT -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.favorite, cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, @@ -421,7 +421,7 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profi [sql| SELECT -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.favorite, cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, @@ -566,7 +566,7 @@ getContact_ db user@User {userId} contactId deleted = [sql| SELECT -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.favorite, cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, @@ -673,8 +673,8 @@ updateConnectionStatus db Connection {connId} connStatus = do DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId) updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () -updateContactSettings db User {userId} contactId ChatSettings {enableNtfs} = - DB.execute db "UPDATE contacts SET enable_ntfs = ? WHERE user_id = ? AND contact_id = ?" (enableNtfs, userId, contactId) +updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, favorite} = + DB.execute db "UPDATE contacts SET enable_ntfs = ?, favorite = ? WHERE user_id = ? AND contact_id = ?" (enableNtfs, favorite, userId, contactId) setConnConnReqInv :: DB.Connection -> User -> Int64 -> ConnReqInvitation -> IO () setConnConnReqInv db User {userId} connId connReq = do diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 7a09df5ab0..acf722a3ac 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -102,16 +102,16 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Util (eitherToMaybe) import UnliftIO.STM -type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe GroupPreferences, UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow +type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow type GroupMemberRow = ((Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus) :. (Maybe Int64, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences)) type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus) :. (Maybe Int64, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences)) toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo -toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, groupPreferences, createdAt, updatedAt, chatTs) :. userMemberRow) = +toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) = let membership = toGroupMember userContactId userMemberRow - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, favorite} fullGroupPreferences = mergeGroupPreferences groupPreferences groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences} in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs} @@ -217,7 +217,7 @@ getGroupAndMember db User {userId, userContactId} groupMemberId = [sql| SELECT -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -269,7 +269,7 @@ createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do insertedRowId db memberId <- liftIO $ encodedRandomBytes gVar 12 membership <- createContactMemberInv_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing currentTs - let chatSettings = ChatSettings {enableNtfs = True} + let chatSettings = ChatSettings {enableNtfs = True, favorite = False} pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs} -- | creates a new group record for the group the current user was invited to, or returns an existing one @@ -314,7 +314,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo insertedRowId db GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs - let chatSettings = ChatSettings {enableNtfs = True} + let chatSettings = ChatSettings {enableNtfs = True, favorite = False} pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId) getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId @@ -451,7 +451,7 @@ getUserGroupDetails db User {userId, userContactId} = <$> DB.query db [sql| - SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, mu.group_member_id, g.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences FROM groups g @@ -632,7 +632,7 @@ getContactViaMember db user@User {userId} GroupMember {groupMemberId} = [sql| SELECT -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.favorite, cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, @@ -931,7 +931,7 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} = [sql| SELECT -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -971,7 +971,7 @@ getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = db [sql| SELECT - ct.contact_id, ct.contact_profile_id, ct.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, ct.via_group, ct.contact_used, ct.enable_ntfs, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, ct.via_group, ct.contact_used, ct.enable_ntfs, ct.favorite, p.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter @@ -988,10 +988,10 @@ getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = |] (userId, groupMemberId) where - toContact' :: ((ContactId, ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)) :. ConnectionRow -> Contact - toContact' (((contactId, profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = + toContact' :: ((ContactId, ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool, Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)) :. ConnectionRow -> Contact + toContact' (((contactId, profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_, favorite) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, favorite} activeConn = toConnection connRow mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} @@ -1038,7 +1038,7 @@ getGroupInfo db User {userId, userContactId} groupId = [sql| SELECT -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, -- GroupMember - membership mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -1231,8 +1231,8 @@ mergeContactRecords db userId ct1 ct2 = do ctCreatedAt Contact {createdAt} = createdAt updateGroupSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () -updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs} = - DB.execute db "UPDATE groups SET enable_ntfs = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, userId, groupId) +updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs, favorite} = + DB.execute db "UPDATE groups SET enable_ntfs = ?, favorite = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, favorite, userId, groupId) getXGrpMemIntroContDirect :: DB.Connection -> User -> Contact -> IO (Maybe (Int64, XGrpMemIntroCont)) getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index efc78f8df2..1b1df64a25 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -462,7 +462,7 @@ getDirectChatPreviews_ db user@User {userId} = do [sql| SELECT -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.favorite, cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, @@ -527,7 +527,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do [sql| SELECT -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, -- GroupMember - membership mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index 32929f0229..a155841b84 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -71,6 +71,7 @@ import Simplex.Chat.Migrations.M20230519_item_deleted_ts import Simplex.Chat.Migrations.M20230526_indexes import Simplex.Chat.Migrations.M20230529_indexes import Simplex.Chat.Migrations.M20230608_deleted_contacts +import Simplex.Chat.Migrations.M20230618_favorite_chats import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -141,7 +142,8 @@ schemaMigrations = ("20230519_item_deleted_ts", m20230519_item_deleted_ts, Just down_m20230519_item_deleted_ts), ("20230526_indexes", m20230526_indexes, Just down_m20230526_indexes), ("20230529_indexes", m20230529_indexes, Just down_m20230529_indexes), - ("20230608_deleted_contacts", m20230608_deleted_contacts, Just down_m20230608_deleted_contacts) + ("20230608_deleted_contacts", m20230608_deleted_contacts, Just down_m20230608_deleted_contacts), + ("20230618_favorite_chats", m20230618_favorite_chats, Just down_m20230618_favorite_chats) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index f46ff35b3d..0d49915899 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -208,20 +208,20 @@ deleteUnusedIncognitoProfileById_ db User {userId} profile_id = |] [":user_id" := userId, ":profile_id" := profile_id] -type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) +type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, Maybe Bool, Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) toContact :: User -> ContactRow :. ConnectionRow -> Contact -toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = +toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_, favorite) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} activeConn = toConnection connRow - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, favorite} mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact -toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = +toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_, favorite) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, favorite} in case toMaybeConnection connRow of Just activeConn -> let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index e46dcfa647..1d69722691 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -333,17 +333,21 @@ contactAndGroupIds = \case -- TODO when more settings are added we should create another type to allow partial setting updates (with all Maybe properties) data ChatSettings = ChatSettings - { enableNtfs :: Bool + { enableNtfs :: Bool, + favorite :: Bool } deriving (Eq, Show, Generic, FromJSON) instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions defaultChatSettings :: ChatSettings -defaultChatSettings = ChatSettings {enableNtfs = True} +defaultChatSettings = ChatSettings + { enableNtfs = True, + favorite = False + } pattern DisableNtfs :: ChatSettings -pattern DisableNtfs = ChatSettings {enableNtfs = False} +pattern DisableNtfs <- ChatSettings {enableNtfs = False} data ChatFeature = CFTimedMessages From ddf81d28f11d14284f5a443e54cb4521c5fa2561 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 19 Jun 2023 11:13:30 +0100 Subject: [PATCH 6/9] ios: UI to filter favorite and unread chats (#2592) * ios: UI to filter favorite and unread chats * update localizations * update colors * star size and position * filter button sizes and layout * change AND to OR when both filters are chosen * simplify filter UX * store filter state in defaults * remove comment, update localizations --- apps/ios/Shared/Model/ChatModel.swift | 8 ++++ apps/ios/Shared/Model/SimpleXAPI.swift | 8 +++- apps/ios/Shared/Views/Chat/ChatView.swift | 13 ++++++- .../Views/ChatList/ChatListNavLink.swift | 26 +++++++++++-- .../Shared/Views/ChatList/ChatListView.swift | 39 ++++++++++++------- .../Views/ChatList/ChatPreviewView.swift | 7 ++++ .../Views/UserSettings/SettingsView.swift | 2 + .../cs.xcloc/Localized Contents/cs.xliff | 13 ++++--- .../de.xcloc/Localized Contents/de.xliff | 13 ++++--- .../en.xcloc/Localized Contents/en.xliff | 15 ++++--- .../es.xcloc/Localized Contents/es.xliff | 13 ++++--- .../fr.xcloc/Localized Contents/fr.xliff | 13 ++++--- .../it.xcloc/Localized Contents/it.xliff | 13 ++++--- .../ja.xcloc/Localized Contents/ja.xliff | 13 ++++--- .../nl.xcloc/Localized Contents/nl.xliff | 13 ++++--- .../pl.xcloc/Localized Contents/pl.xliff | 13 ++++--- .../ru.xcloc/Localized Contents/ru.xliff | 13 ++++--- .../Localized Contents/zh-Hans.xliff | 13 ++++--- apps/ios/SimpleXChat/APITypes.swift | 6 ++- apps/ios/SimpleXChat/ChatTypes.swift | 10 +++-- apps/ios/cs.lproj/Localizable.strings | 3 -- apps/ios/de.lproj/Localizable.strings | 3 -- apps/ios/es.lproj/Localizable.strings | 3 -- apps/ios/fr.lproj/Localizable.strings | 3 -- apps/ios/it.lproj/Localizable.strings | 3 -- apps/ios/ja.lproj/Localizable.strings | 3 -- apps/ios/nl.lproj/Localizable.strings | 3 -- apps/ios/pl.lproj/Localizable.strings | 3 -- apps/ios/ru.lproj/Localizable.strings | 3 -- apps/ios/zh-Hans.lproj/Localizable.strings | 3 -- 30 files changed, 185 insertions(+), 109 deletions(-) diff --git a/apps/ios/Shared/Model/ChatModel.swift b/apps/ios/Shared/Model/ChatModel.swift index 8c3d0368e1..7ce430ca5e 100644 --- a/apps/ios/Shared/Model/ChatModel.swift +++ b/apps/ios/Shared/Model/ChatModel.swift @@ -583,6 +583,14 @@ final class Chat: ObservableObject, Identifiable { self.chatStats = chatStats } + func copy(chatInfo: ChatInfo? = nil, chatItems: [ChatItem]? = nil, chatStats: ChatStats? = nil) -> Chat { + Chat( + chatInfo: chatInfo ?? self.chatInfo, + chatItems: chatItems ?? self.chatItems, + chatStats: chatStats ?? self.chatStats + ) + } + var userCanSend: Bool { switch chatInfo { case .direct: return true diff --git a/apps/ios/Shared/Model/SimpleXAPI.swift b/apps/ios/Shared/Model/SimpleXAPI.swift index 16eddca9ac..263b02e37a 100644 --- a/apps/ios/Shared/Model/SimpleXAPI.swift +++ b/apps/ios/Shared/Model/SimpleXAPI.swift @@ -884,7 +884,9 @@ func markChatRead(_ chat: Chat, aboveItem: ChatItem? = nil) async { let itemRange = (minItemId, aboveItem?.id ?? chat.chatItems.last?.id ?? minItemId) let cInfo = chat.chatInfo try await apiChatRead(type: cInfo.chatType, id: cInfo.apiId, itemRange: itemRange) - await MainActor.run { ChatModel.shared.markChatItemsRead(cInfo, aboveItem: aboveItem) } + await MainActor.run { + withAnimation { ChatModel.shared.markChatItemsRead(cInfo, aboveItem: aboveItem) } + } } if chat.chatStats.unreadChat { await markChatUnread(chat, unreadChat: false) @@ -898,7 +900,9 @@ func markChatUnread(_ chat: Chat, unreadChat: Bool = true) async { do { let cInfo = chat.chatInfo try await apiChatUnread(type: cInfo.chatType, id: cInfo.apiId, unreadChat: unreadChat) - await MainActor.run { ChatModel.shared.markChatUnread(cInfo, unreadChat: unreadChat) } + await MainActor.run { + withAnimation { ChatModel.shared.markChatUnread(cInfo, unreadChat: unreadChat) } + } } catch { logger.error("markChatUnread apiChatUnread error: \(responseError(error))") } diff --git a/apps/ios/Shared/Views/Chat/ChatView.swift b/apps/ios/Shared/Views/Chat/ChatView.swift index 5d464e1774..8a43434289 100644 --- a/apps/ios/Shared/Views/Chat/ChatView.swift +++ b/apps/ios/Shared/Views/Chat/ChatView.swift @@ -897,9 +897,20 @@ struct ChatView: View { } func toggleNotifications(_ chat: Chat, enableNtfs: Bool) { + var chatSettings = chat.chatInfo.chatSettings ?? ChatSettings.defaults + chatSettings.enableNtfs = enableNtfs + updateChatSettings(chat, chatSettings: chatSettings) +} + +func toggleChatFavorite(_ chat: Chat, favorite: Bool) { + var chatSettings = chat.chatInfo.chatSettings ?? ChatSettings.defaults + chatSettings.favorite = favorite + updateChatSettings(chat, chatSettings: chatSettings) +} + +func updateChatSettings(_ chat: Chat, chatSettings: ChatSettings) { Task { do { - let chatSettings = ChatSettings(enableNtfs: enableNtfs) try await apiSetChatSettings(type: chat.chatInfo.chatType, id: chat.chatInfo.apiId, chatSettings: chatSettings) await MainActor.run { switch chat.chatInfo { diff --git a/apps/ios/Shared/Views/ChatList/ChatListNavLink.swift b/apps/ios/Shared/Views/ChatList/ChatListNavLink.swift index 5733568c07..b41c632866 100644 --- a/apps/ios/Shared/Views/ChatList/ChatListNavLink.swift +++ b/apps/ios/Shared/Views/ChatList/ChatListNavLink.swift @@ -27,7 +27,7 @@ private let rowHeights: [DynamicTypeSize: CGFloat] = [ struct ChatListNavLink: View { @EnvironmentObject var chatModel: ChatModel @Environment(\.dynamicTypeSize) private var dynamicTypeSize - @State var chat: Chat + @ObservedObject var chat: Chat @State private var showContactRequestDialog = false @State private var showJoinGroupDialog = false @State private var showContactConnectionInfo = false @@ -57,6 +57,8 @@ struct ChatListNavLink: View { ) .swipeActions(edge: .leading, allowsFullSwipe: true) { markReadButton() + toggleFavoriteButton() + toggleNtfsButton(chat) } .swipeActions(edge: .trailing, allowsFullSwipe: true) { if !chat.chatItems.isEmpty { @@ -126,6 +128,8 @@ struct ChatListNavLink: View { .frame(height: rowHeights[dynamicTypeSize]) .swipeActions(edge: .leading, allowsFullSwipe: true) { markReadButton() + toggleFavoriteButton() + toggleNtfsButton(chat) } .swipeActions(edge: .trailing, allowsFullSwipe: true) { if !chat.chatItems.isEmpty { @@ -134,8 +138,6 @@ struct ChatListNavLink: View { if (groupInfo.membership.memberCurrent) { leaveGroupChatButton(groupInfo) } - } - .swipeActions(edge: .trailing) { if groupInfo.canDelete { deleteGroupChatButton(groupInfo) } @@ -171,6 +173,24 @@ struct ChatListNavLink: View { } + @ViewBuilder private func toggleFavoriteButton() -> some View { + if chat.chatInfo.chatSettings?.favorite == true { + Button { + toggleChatFavorite(chat, favorite: false) + } label: { + Label("Unfav.", systemImage: "star.slash") + } + .tint(.green) + } else { + Button { + toggleChatFavorite(chat, favorite: true) + } label: { + Label("Favorite", systemImage: "star.fill") + } + .tint(.green) + } + } + private func clearChatButton() -> some View { Button { AlertManager.shared.showAlert(clearChatAlert()) diff --git a/apps/ios/Shared/Views/ChatList/ChatListView.swift b/apps/ios/Shared/Views/ChatList/ChatListView.swift index c372acdd24..90ff8433ea 100644 --- a/apps/ios/Shared/Views/ChatList/ChatListView.swift +++ b/apps/ios/Shared/Views/ChatList/ChatListView.swift @@ -14,7 +14,8 @@ struct ChatListView: View { @Binding var showSettings: Bool @State private var searchText = "" @State private var showAddChat = false - @State var userPickerVisible = false + @State private var userPickerVisible = false + @AppStorage(DEFAULT_SHOW_UNREAD_AND_FAVORITES) private var showUnreadAndFavorites = false var body: some View { ZStack(alignment: .topLeading) { @@ -56,7 +57,6 @@ struct ChatListView: View { .onDisappear() { withAnimation { userPickerVisible = false } } .offset(x: -8) .listStyle(.plain) - .navigationTitle("Your chats") .navigationBarTitleDisplayMode(.inline) .toolbar { ToolbarItem(placement: .navigationBarLeading) { @@ -84,17 +84,19 @@ struct ChatListView: View { } } ToolbarItem(placement: .principal) { - if (chatModel.incognito) { - HStack { - if (chatModel.chats.count > 8) { - Text("Your chats").font(.headline) - Spacer().frame(width: 16) - } - Image(systemName: "theatermasks").frame(maxWidth: 24, maxHeight: 24, alignment: .center).foregroundColor(.indigo) + HStack(spacing: 4) { + if (chatModel.incognito) { + Image(systemName: "theatermasks") + .foregroundColor(.indigo) + .padding(.trailing, 8) + } + Text("Chats") + .font(.headline) + if chatModel.chats.count > 0 { + toggleFilterButton() } - } else { - Text("Your chats").font(.headline) } + .frame(maxWidth: .infinity, alignment: .center) } ToolbarItem(placement: .navigationBarTrailing) { switch chatModel.chatRunning { @@ -106,6 +108,15 @@ struct ChatListView: View { } } + private func toggleFilterButton() -> some View { + Button { + showUnreadAndFavorites = !showUnreadAndFavorites + } label: { + Image(systemName: "line.3.horizontal.decrease.circle" + (showUnreadAndFavorites ? ".fill" : "")) + .foregroundColor(.accentColor) + } + } + private var chatList: some View { List { ForEach(filteredChats(), id: \.viewId) { chat in @@ -181,10 +192,12 @@ struct ChatListView: View { private func filteredChats() -> [Chat] { let s = searchText.trimmingCharacters(in: .whitespaces).localizedLowercase - return s == "" + return s == "" && !showUnreadAndFavorites ? chatModel.chats : chatModel.chats.filter { chat in - let contains = chat.chatInfo.chatViewName.localizedLowercase.contains(s) + let contains = s == "" + ? ((chat.chatInfo.chatSettings?.favorite ?? false) || chat.chatStats.unreadCount > 0 || chat.chatStats.unreadChat) + : chat.chatInfo.chatViewName.localizedLowercase.contains(s) switch chat.chatInfo { case let .direct(contact): return contains diff --git a/apps/ios/Shared/Views/ChatList/ChatPreviewView.swift b/apps/ios/Shared/Views/ChatList/ChatPreviewView.swift index c4d28c3440..7f2493dc26 100644 --- a/apps/ios/Shared/Views/ChatList/ChatPreviewView.swift +++ b/apps/ios/Shared/Views/ChatList/ChatPreviewView.swift @@ -126,6 +126,13 @@ struct ChatPreviewView: View { } else if !chat.chatInfo.ntfsEnabled { Image(systemName: "speaker.slash.fill") .foregroundColor(.secondary) + } else if chat.chatInfo.chatSettings?.favorite ?? false { + Image(systemName: "star.fill") + .resizable() + .scaledToFill() + .frame(width: 18, height: 18) + .padding(.trailing, 1) + .foregroundColor(.secondary.opacity(0.65)) } } } diff --git a/apps/ios/Shared/Views/UserSettings/SettingsView.swift b/apps/ios/Shared/Views/UserSettings/SettingsView.swift index 8533060c84..35b584ff93 100644 --- a/apps/ios/Shared/Views/UserSettings/SettingsView.swift +++ b/apps/ios/Shared/Views/UserSettings/SettingsView.swift @@ -49,6 +49,7 @@ let DEFAULT_SHOW_MUTE_PROFILE_ALERT = "showMuteProfileAlert" let DEFAULT_WHATS_NEW_VERSION = "defaultWhatsNewVersion" let DEFAULT_ONBOARDING_STAGE = "onboardingStage" let DEFAULT_CUSTOM_DISAPPEARING_MESSAGE_TIME = "customDisappearingMessageTime" +let DEFAULT_SHOW_UNREAD_AND_FAVORITES = "showUnreadAndFavorites" let appDefaults: [String: Any] = [ DEFAULT_SHOW_LA_NOTICE: false, @@ -78,6 +79,7 @@ let appDefaults: [String: Any] = [ DEFAULT_SHOW_MUTE_PROFILE_ALERT: true, DEFAULT_ONBOARDING_STAGE: OnboardingStage.onboardingComplete.rawValue, DEFAULT_CUSTOM_DISAPPEARING_MESSAGE_TIME: 300, + DEFAULT_SHOW_UNREAD_AND_FAVORITES: false ] enum SimpleXLinkMode: String, Identifiable { diff --git a/apps/ios/SimpleX Localizations/cs.xcloc/Localized Contents/cs.xliff b/apps/ios/SimpleX Localizations/cs.xcloc/Localized Contents/cs.xliff index 03eb28ac25..9f76e25910 100644 --- a/apps/ios/SimpleX Localizations/cs.xcloc/Localized Contents/cs.xliff +++ b/apps/ios/SimpleX Localizations/cs.xcloc/Localized Contents/cs.xliff @@ -2040,6 +2040,10 @@ Rychle a bez čekání, než bude odesílatel online! No comment provided by engineer. + + Favorite + No comment provided by engineer. + File will be deleted from servers. Soubor bude smazán ze serverů. @@ -4415,6 +4419,10 @@ Před zapnutím této funkce budete vyzváni k dokončení ověření. Neočekávaný stav přenášení No comment provided by engineer. + + Unfav. + No comment provided by engineer. + Unhide Odkrýt @@ -4972,11 +4980,6 @@ Chcete-li se připojit, požádejte svůj kontakt o vytvoření dalšího odkazu Vaše chat profily No comment provided by engineer. - - Your chats - Vaše konverzace - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleX Localizations/de.xcloc/Localized Contents/de.xliff b/apps/ios/SimpleX Localizations/de.xcloc/Localized Contents/de.xliff index 1d863cc197..f6f9fec92f 100644 --- a/apps/ios/SimpleX Localizations/de.xcloc/Localized Contents/de.xliff +++ b/apps/ios/SimpleX Localizations/de.xcloc/Localized Contents/de.xliff @@ -2040,6 +2040,10 @@ Schnell und ohne warten auf den Absender, bis er online ist! No comment provided by engineer. + + Favorite + No comment provided by engineer. + File will be deleted from servers. Die Datei wird von den Servern gelöscht. @@ -4415,6 +4419,10 @@ Sie werden aufgefordert, die Authentifizierung abzuschließen, bevor diese Funkt Unerwarteter Migrationsstatus No comment provided by engineer. + + Unfav. + No comment provided by engineer. + Unhide Verbergen aufheben @@ -4972,11 +4980,6 @@ Bitten Sie Ihren Kontakt darum einen weiteren Verbindungs-Link zu erzeugen, um s Meine Chat-Profile No comment provided by engineer. - - Your chats - Meine Chats - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleX Localizations/en.xcloc/Localized Contents/en.xliff b/apps/ios/SimpleX Localizations/en.xcloc/Localized Contents/en.xliff index af65f8fb08..c565923c41 100644 --- a/apps/ios/SimpleX Localizations/en.xcloc/Localized Contents/en.xliff +++ b/apps/ios/SimpleX Localizations/en.xcloc/Localized Contents/en.xliff @@ -2040,6 +2040,11 @@ Fast and no wait until the sender is online! No comment provided by engineer. + + Favorite + Favorite + No comment provided by engineer. + File will be deleted from servers. File will be deleted from servers. @@ -4416,6 +4421,11 @@ You will be prompted to complete authentication before this feature is enabled.< Unexpected migration state No comment provided by engineer. + + Unfav. + Unfav. + No comment provided by engineer. + Unhide Unhide @@ -4973,11 +4983,6 @@ To connect, please ask your contact to create another connection link and check Your chat profiles No comment provided by engineer. - - Your chats - Your chats - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleX Localizations/es.xcloc/Localized Contents/es.xliff b/apps/ios/SimpleX Localizations/es.xcloc/Localized Contents/es.xliff index c0e6caf3ff..d0d5e1af28 100644 --- a/apps/ios/SimpleX Localizations/es.xcloc/Localized Contents/es.xliff +++ b/apps/ios/SimpleX Localizations/es.xcloc/Localized Contents/es.xliff @@ -2040,6 +2040,10 @@ ¡Rápido y sin necesidad de esperar a que el remitente esté en línea! No comment provided by engineer. + + Favorite + No comment provided by engineer. + File will be deleted from servers. El archivo será eliminado de los servidores. @@ -4415,6 +4419,10 @@ Se te pedirá que completes la autenticación antes de activar esta función.Estado de migración inesperado No comment provided by engineer. + + Unfav. + No comment provided by engineer. + Unhide Mostrar @@ -4973,11 +4981,6 @@ Para conectarte, pide a tu contacto que cree otro enlace de conexión y comprueb Mis perfiles No comment provided by engineer. - - Your chats - Mis chats - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleX Localizations/fr.xcloc/Localized Contents/fr.xliff b/apps/ios/SimpleX Localizations/fr.xcloc/Localized Contents/fr.xliff index ae457b029d..c7f123f6ed 100644 --- a/apps/ios/SimpleX Localizations/fr.xcloc/Localized Contents/fr.xliff +++ b/apps/ios/SimpleX Localizations/fr.xcloc/Localized Contents/fr.xliff @@ -2040,6 +2040,10 @@ Rapide et ne nécessitant pas d'attendre que l'expéditeur soit en ligne ! No comment provided by engineer. + + Favorite + No comment provided by engineer. + File will be deleted from servers. Le fichier sera supprimé des serveurs. @@ -4415,6 +4419,10 @@ Vous serez invité à confirmer l'authentification avant que cette fonction ne s État de la migration inattendu No comment provided by engineer. + + Unfav. + No comment provided by engineer. + Unhide Dévoiler @@ -4972,11 +4980,6 @@ Pour vous connecter, veuillez demander à votre contact de créer un autre lien Vos profils de chat No comment provided by engineer. - - Your chats - Vos chats - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleX Localizations/it.xcloc/Localized Contents/it.xliff b/apps/ios/SimpleX Localizations/it.xcloc/Localized Contents/it.xliff index e72bdd3626..2d42aa1f45 100644 --- a/apps/ios/SimpleX Localizations/it.xcloc/Localized Contents/it.xliff +++ b/apps/ios/SimpleX Localizations/it.xcloc/Localized Contents/it.xliff @@ -2040,6 +2040,10 @@ Veloce e senza aspettare che il mittente sia in linea! No comment provided by engineer. + + Favorite + No comment provided by engineer. + File will be deleted from servers. Il file verrà eliminato dai server. @@ -4415,6 +4419,10 @@ Ti verrà chiesto di completare l'autenticazione prima di attivare questa funzio Stato di migrazione imprevisto No comment provided by engineer. + + Unfav. + No comment provided by engineer. + Unhide Svela @@ -4972,11 +4980,6 @@ Per connetterti, chiedi al tuo contatto di creare un altro link di connessione e I tuoi profili di chat No comment provided by engineer. - - Your chats - Le tue chat - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleX Localizations/ja.xcloc/Localized Contents/ja.xliff b/apps/ios/SimpleX Localizations/ja.xcloc/Localized Contents/ja.xliff index 2e22257d01..ba69f538a4 100644 --- a/apps/ios/SimpleX Localizations/ja.xcloc/Localized Contents/ja.xliff +++ b/apps/ios/SimpleX Localizations/ja.xcloc/Localized Contents/ja.xliff @@ -2039,6 +2039,10 @@ 送信者がオンラインになるまでの待ち時間がなく、速い！ No comment provided by engineer. + + Favorite + No comment provided by engineer. + File will be deleted from servers. ファイルはサーバーから削除されます。 @@ -4413,6 +4417,10 @@ You will be prompted to complete authentication before this feature is enabled.< 予期しない移行状態 No comment provided by engineer. + + Unfav. + No comment provided by engineer. + Unhide 表示にする @@ -4970,11 +4978,6 @@ To connect, please ask your contact to create another connection link and check あなたのチャットプロフィール No comment provided by engineer. - - Your chats - あなたのチャット - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleX Localizations/nl.xcloc/Localized Contents/nl.xliff b/apps/ios/SimpleX Localizations/nl.xcloc/Localized Contents/nl.xliff index d6b98e7c79..b60943c264 100644 --- a/apps/ios/SimpleX Localizations/nl.xcloc/Localized Contents/nl.xliff +++ b/apps/ios/SimpleX Localizations/nl.xcloc/Localized Contents/nl.xliff @@ -2040,6 +2040,10 @@ Snel en niet wachten tot de afzender online is! No comment provided by engineer. + + Favorite + No comment provided by engineer. + File will be deleted from servers. Het bestand wordt van de servers verwijderd. @@ -4415,6 +4419,10 @@ U wordt gevraagd de authenticatie te voltooien voordat deze functie wordt ingesc Onverwachte migratiestatus No comment provided by engineer. + + Unfav. + No comment provided by engineer. + Unhide zichtbaar maken @@ -4972,11 +4980,6 @@ Om verbinding te maken, vraagt u uw contactpersoon om een andere verbinding link Uw chat profielen No comment provided by engineer. - - Your chats - Jouw gesprekken - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleX Localizations/pl.xcloc/Localized Contents/pl.xliff b/apps/ios/SimpleX Localizations/pl.xcloc/Localized Contents/pl.xliff index 8e41d51764..d1a3bb0058 100644 --- a/apps/ios/SimpleX Localizations/pl.xcloc/Localized Contents/pl.xliff +++ b/apps/ios/SimpleX Localizations/pl.xcloc/Localized Contents/pl.xliff @@ -2040,6 +2040,10 @@ Szybko i bez czekania aż nadawca będzie online! No comment provided by engineer. + + Favorite + No comment provided by engineer. + File will be deleted from servers. Plik zostanie usunięty z serwerów. @@ -4415,6 +4419,10 @@ Przed włączeniem tej funkcji zostanie wyświetlony monit uwierzytelniania.Nieoczekiwany stan migracji No comment provided by engineer. + + Unfav. + No comment provided by engineer. + Unhide Odkryj @@ -4972,11 +4980,6 @@ Aby się połączyć, poproś Twój kontakt o utworzenie kolejnego linku połąc Twoje profile czatu No comment provided by engineer. - - Your chats - Twoje czaty - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleX Localizations/ru.xcloc/Localized Contents/ru.xliff b/apps/ios/SimpleX Localizations/ru.xcloc/Localized Contents/ru.xliff index 34749b9e5f..42c7c2d566 100644 --- a/apps/ios/SimpleX Localizations/ru.xcloc/Localized Contents/ru.xliff +++ b/apps/ios/SimpleX Localizations/ru.xcloc/Localized Contents/ru.xliff @@ -2040,6 +2040,10 @@ Быстрые и не нужно ждать, когда отправитель онлайн! No comment provided by engineer. + + Favorite + No comment provided by engineer. + File will be deleted from servers. Файл будет удалён с серверов. @@ -4415,6 +4419,10 @@ You will be prompted to complete authentication before this feature is enabled.< Неожиданная ошибка при перемещении данных чата No comment provided by engineer. + + Unfav. + No comment provided by engineer. + Unhide Раскрыть @@ -4972,11 +4980,6 @@ To connect, please ask your contact to create another connection link and check Ваши профили чата No comment provided by engineer. - - Your chats - Ваши чаты - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleX Localizations/zh-Hans.xcloc/Localized Contents/zh-Hans.xliff b/apps/ios/SimpleX Localizations/zh-Hans.xcloc/Localized Contents/zh-Hans.xliff index 8c8c7aa2f0..b02ca176d9 100644 --- a/apps/ios/SimpleX Localizations/zh-Hans.xcloc/Localized Contents/zh-Hans.xliff +++ b/apps/ios/SimpleX Localizations/zh-Hans.xcloc/Localized Contents/zh-Hans.xliff @@ -2040,6 +2040,10 @@ 快速且无需等待发件人在线！ No comment provided by engineer. + + Favorite + No comment provided by engineer. + File will be deleted from servers. 文件将从服务器中删除。 @@ -4415,6 +4419,10 @@ You will be prompted to complete authentication before this feature is enabled.< 未预料的迁移状态 No comment provided by engineer. + + Unfav. + No comment provided by engineer. + Unhide 取消隐藏 @@ -4972,11 +4980,6 @@ To connect, please ask your contact to create another connection link and check 您的聊天资料 No comment provided by engineer. - - Your chats - 您的聊天 - No comment provided by engineer. - Your contact needs to be online for the connection to complete. You can cancel this connection and remove the contact (and try later with a new link). diff --git a/apps/ios/SimpleXChat/APITypes.swift b/apps/ios/SimpleXChat/APITypes.swift index 7e590a40fa..af23f7d676 100644 --- a/apps/ios/SimpleXChat/APITypes.swift +++ b/apps/ios/SimpleXChat/APITypes.swift @@ -1072,12 +1072,14 @@ public struct KeepAliveOpts: Codable, Equatable { public struct ChatSettings: Codable { public var enableNtfs: Bool + public var favorite: Bool? = false - public init(enableNtfs: Bool) { + public init(enableNtfs: Bool, favorite: Bool?) { self.enableNtfs = enableNtfs + self.favorite = favorite } - public static let defaults: ChatSettings = ChatSettings(enableNtfs: true) + public static let defaults: ChatSettings = ChatSettings(enableNtfs: true, favorite: false) } public struct ConnectionStats: Codable { diff --git a/apps/ios/SimpleXChat/ChatTypes.swift b/apps/ios/SimpleXChat/ChatTypes.swift index 1fe081d0d8..ca60f31c87 100644 --- a/apps/ios/SimpleXChat/ChatTypes.swift +++ b/apps/ios/SimpleXChat/ChatTypes.swift @@ -1240,10 +1240,14 @@ public enum ChatInfo: Identifiable, Decodable, NamedChat { } public var ntfsEnabled: Bool { + self.chatSettings?.enableNtfs ?? false + } + + public var chatSettings: ChatSettings? { switch self { - case let .direct(contact): return contact.chatSettings.enableNtfs - case let .group(groupInfo): return groupInfo.chatSettings.enableNtfs - default: return false + case let .direct(contact): return contact.chatSettings + case let .group(groupInfo): return groupInfo.chatSettings + default: return nil } } diff --git a/apps/ios/cs.lproj/Localizable.strings b/apps/ios/cs.lproj/Localizable.strings index 0939e9db5a..4c60fe872b 100644 --- a/apps/ios/cs.lproj/Localizable.strings +++ b/apps/ios/cs.lproj/Localizable.strings @@ -3343,9 +3343,6 @@ /* No comment provided by engineer. */ "Your chat profiles" = "Vaše chat profily"; -/* No comment provided by engineer. */ -"Your chats" = "Vaše konverzace"; - /* No comment provided by engineer. */ "Your contact needs to be online for the connection to complete.\nYou can cancel this connection and remove the contact (and try later with a new link)." = "K dokončení připojení, musí být váš kontakt online.\nToto připojení můžete zrušit a kontakt odebrat (a zkusit to později s novým odkazem)."; diff --git a/apps/ios/de.lproj/Localizable.strings b/apps/ios/de.lproj/Localizable.strings index cef8b62936..7315656937 100644 --- a/apps/ios/de.lproj/Localizable.strings +++ b/apps/ios/de.lproj/Localizable.strings @@ -3343,9 +3343,6 @@ /* No comment provided by engineer. */ "Your chat profiles" = "Meine Chat-Profile"; -/* No comment provided by engineer. */ -"Your chats" = "Meine Chats"; - /* No comment provided by engineer. */ "Your contact needs to be online for the connection to complete.\nYou can cancel this connection and remove the contact (and try later with a new link)." = "Damit die Verbindung hergestellt werden kann, muss Ihr Kontakt online sein.\nSie können diese Verbindung abbrechen und den Kontakt entfernen (und es später nochmals mit einem neuen Link versuchen)."; diff --git a/apps/ios/es.lproj/Localizable.strings b/apps/ios/es.lproj/Localizable.strings index 48288bc63c..f68347c3ce 100644 --- a/apps/ios/es.lproj/Localizable.strings +++ b/apps/ios/es.lproj/Localizable.strings @@ -3343,9 +3343,6 @@ /* No comment provided by engineer. */ "Your chat profiles" = "Mis perfiles"; -/* No comment provided by engineer. */ -"Your chats" = "Mis chats"; - /* No comment provided by engineer. */ "Your contact needs to be online for the connection to complete.\nYou can cancel this connection and remove the contact (and try later with a new link)." = "Tu contacto debe estar en línea para que se complete la conexión.\nPuedes cancelar esta conexión y eliminar el contacto (e intentarlo más tarde con un enlace nuevo)."; diff --git a/apps/ios/fr.lproj/Localizable.strings b/apps/ios/fr.lproj/Localizable.strings index b9cc5f8e10..d70e0a2846 100644 --- a/apps/ios/fr.lproj/Localizable.strings +++ b/apps/ios/fr.lproj/Localizable.strings @@ -3343,9 +3343,6 @@ /* No comment provided by engineer. */ "Your chat profiles" = "Vos profils de chat"; -/* No comment provided by engineer. */ -"Your chats" = "Vos chats"; - /* No comment provided by engineer. */ "Your contact needs to be online for the connection to complete.\nYou can cancel this connection and remove the contact (and try later with a new link)." = "Votre contact a besoin d'être en ligne pour completer la connexion.\nVous pouvez annuler la connexion et supprimer le contact (et réessayer plus tard avec un autre lien)."; diff --git a/apps/ios/it.lproj/Localizable.strings b/apps/ios/it.lproj/Localizable.strings index fcd888ebbf..b6f9c8dae1 100644 --- a/apps/ios/it.lproj/Localizable.strings +++ b/apps/ios/it.lproj/Localizable.strings @@ -3340,9 +3340,6 @@ /* No comment provided by engineer. */ "Your chat profiles" = "I tuoi profili di chat"; -/* No comment provided by engineer. */ -"Your chats" = "Le tue chat"; - /* No comment provided by engineer. */ "Your contact needs to be online for the connection to complete.\nYou can cancel this connection and remove the contact (and try later with a new link)." = "Il tuo contatto deve essere in linea per completare la connessione.\nPuoi annullare questa connessione e rimuovere il contatto (e riprovare più tardi con un link nuovo)."; diff --git a/apps/ios/ja.lproj/Localizable.strings b/apps/ios/ja.lproj/Localizable.strings index e1768da252..2377e5c8e8 100644 --- a/apps/ios/ja.lproj/Localizable.strings +++ b/apps/ios/ja.lproj/Localizable.strings @@ -3334,9 +3334,6 @@ /* No comment provided by engineer. */ "Your chat profiles" = "あなたのチャットプロフィール"; -/* No comment provided by engineer. */ -"Your chats" = "あなたのチャット"; - /* No comment provided by engineer. */ "Your contact needs to be online for the connection to complete.\nYou can cancel this connection and remove the contact (and try later with a new link)." = "接続を完了するには、連絡相手がオンラインになる必要があります。\nこの接続をキャンセルして、連絡先を削除をすることもできます (後でやり直すこともできます)。"; diff --git a/apps/ios/nl.lproj/Localizable.strings b/apps/ios/nl.lproj/Localizable.strings index 8c01806437..a75cda064c 100644 --- a/apps/ios/nl.lproj/Localizable.strings +++ b/apps/ios/nl.lproj/Localizable.strings @@ -3343,9 +3343,6 @@ /* No comment provided by engineer. */ "Your chat profiles" = "Uw chat profielen"; -/* No comment provided by engineer. */ -"Your chats" = "Jouw gesprekken"; - /* No comment provided by engineer. */ "Your contact needs to be online for the connection to complete.\nYou can cancel this connection and remove the contact (and try later with a new link)." = "Uw contactpersoon moet online zijn om de verbinding te voltooien.\nU kunt deze verbinding verbreken en het contact verwijderen (en later proberen met een nieuwe link)."; diff --git a/apps/ios/pl.lproj/Localizable.strings b/apps/ios/pl.lproj/Localizable.strings index 27540849e3..ebfe72ec92 100644 --- a/apps/ios/pl.lproj/Localizable.strings +++ b/apps/ios/pl.lproj/Localizable.strings @@ -3343,9 +3343,6 @@ /* No comment provided by engineer. */ "Your chat profiles" = "Twoje profile czatu"; -/* No comment provided by engineer. */ -"Your chats" = "Twoje czaty"; - /* No comment provided by engineer. */ "Your contact needs to be online for the connection to complete.\nYou can cancel this connection and remove the contact (and try later with a new link)." = "Twój kontakt musi być online, aby połączenie zostało zakończone.\nMożesz anulować to połączenie i usunąć kontakt (i spróbować później z nowym linkiem)."; diff --git a/apps/ios/ru.lproj/Localizable.strings b/apps/ios/ru.lproj/Localizable.strings index 360d363f0e..a49ede32cc 100644 --- a/apps/ios/ru.lproj/Localizable.strings +++ b/apps/ios/ru.lproj/Localizable.strings @@ -3340,9 +3340,6 @@ /* No comment provided by engineer. */ "Your chat profiles" = "Ваши профили чата"; -/* No comment provided by engineer. */ -"Your chats" = "Ваши чаты"; - /* No comment provided by engineer. */ "Your contact needs to be online for the connection to complete.\nYou can cancel this connection and remove the contact (and try later with a new link)." = "Ваш контакт должен быть в сети чтобы установить соединение.\nВы можете отменить соединение и удалить контакт (и попробовать позже с другой ссылкой)."; diff --git a/apps/ios/zh-Hans.lproj/Localizable.strings b/apps/ios/zh-Hans.lproj/Localizable.strings index 3276265636..33dd6ef34c 100644 --- a/apps/ios/zh-Hans.lproj/Localizable.strings +++ b/apps/ios/zh-Hans.lproj/Localizable.strings @@ -3343,9 +3343,6 @@ /* No comment provided by engineer. */ "Your chat profiles" = "您的聊天资料"; -/* No comment provided by engineer. */ -"Your chats" = "您的聊天"; - /* No comment provided by engineer. */ "Your contact needs to be online for the connection to complete.\nYou can cancel this connection and remove the contact (and try later with a new link)." = "您的联系人需要在线才能完成连接。\n您可以取消此连接并删除联系人（然后尝试使用新链接）。"; From 22f20a9c5f4c754a0eaaa88aa43741052b8a00be Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 19 Jun 2023 14:46:08 +0400 Subject: [PATCH 7/9] ios, android: abort switching connection (#2584) --- .../java/chat/simplex/app/model/ChatModel.kt | 1 + .../java/chat/simplex/app/model/SimpleXAPI.kt | 59 ++++++++++- .../simplex/app/views/chat/ChatInfoView.kt | 100 ++++++++++++------ .../views/chat/group/GroupMemberInfoView.kt | 58 ++++++---- .../app/src/main/res/values/strings.xml | 11 +- apps/ios/Shared/Model/SimpleXAPI.swift | 12 +++ apps/ios/Shared/Views/Chat/ChatInfoView.swift | 53 ++++++++-- .../Chat/Group/GroupMemberInfoView.swift | 29 ++++- apps/ios/SimpleXChat/APITypes.swift | 41 ++++++- apps/ios/SimpleXChat/ChatTypes.swift | 1 + 10 files changed, 292 insertions(+), 73 deletions(-) diff --git a/apps/android/app/src/main/java/chat/simplex/app/model/ChatModel.kt b/apps/android/app/src/main/java/chat/simplex/app/model/ChatModel.kt index cbd83d58a4..9fcc0b14f7 100644 --- a/apps/android/app/src/main/java/chat/simplex/app/model/ChatModel.kt +++ b/apps/android/app/src/main/java/chat/simplex/app/model/ChatModel.kt @@ -2352,6 +2352,7 @@ sealed class SndConnEvent { enum class SwitchPhase { @SerialName("started") Started, @SerialName("confirmed") Confirmed, + @SerialName("secured") Secured, @SerialName("completed") Completed } diff --git a/apps/android/app/src/main/java/chat/simplex/app/model/SimpleXAPI.kt b/apps/android/app/src/main/java/chat/simplex/app/model/SimpleXAPI.kt index f6fa70b4ee..9bd76e81bb 100644 --- a/apps/android/app/src/main/java/chat/simplex/app/model/SimpleXAPI.kt +++ b/apps/android/app/src/main/java/chat/simplex/app/model/SimpleXAPI.kt @@ -740,7 +740,7 @@ open class ChatController(var ctrl: ChatCtrl?, val ntfManager: NtfManager, val a return when (val r = sendCmd(CC.APISwitchContact(contactId))) { is CR.CmdOk -> {} else -> { - apiErrorAlert("apiSwitchContact", generalGetString(R.string.connection_error), r) + apiErrorAlert("apiSwitchContact", generalGetString(R.string.error_changing_address), r) } } } @@ -754,6 +754,20 @@ open class ChatController(var ctrl: ChatCtrl?, val ntfManager: NtfManager, val a } } + suspend fun apiAbortSwitchContact(contactId: Long): ConnectionStats? { + val r = sendCmd(CC.APIAbortSwitchContact(contactId)) + if (r is CR.ContactSwitchAborted) return r.connectionStats + apiErrorAlert("apiAbortSwitchContact", generalGetString(R.string.error_aborting_address_change), r) + return null + } + + suspend fun apiAbortSwitchGroupMember(groupId: Long, groupMemberId: Long): ConnectionStats? { + val r = sendCmd(CC.APIAbortSwitchGroupMember(groupId, groupMemberId)) + if (r is CR.GroupMemberSwitchAborted) return r.connectionStats + apiErrorAlert("apiAbortSwitchGroupMember", generalGetString(R.string.error_aborting_address_change), r) + return null + } + suspend fun apiGetContactCode(contactId: Long): Pair { val r = sendCmd(CC.APIGetContactCode(contactId)) if (r is CR.ContactCode) return r.contact to r.connectionCode @@ -1939,6 +1953,8 @@ sealed class CC { class APIGroupMemberInfo(val groupId: Long, val groupMemberId: Long): CC() class APISwitchContact(val contactId: Long): CC() class APISwitchGroupMember(val groupId: Long, val groupMemberId: Long): CC() + class APIAbortSwitchContact(val contactId: Long): CC() + class APIAbortSwitchGroupMember(val groupId: Long, val groupMemberId: Long): CC() class APIGetContactCode(val contactId: Long): CC() class APIGetGroupMemberCode(val groupId: Long, val groupMemberId: Long): CC() class APIVerifyContact(val contactId: Long, val connectionCode: String?): CC() @@ -2032,6 +2048,8 @@ sealed class CC { is APIGroupMemberInfo -> "/_info #$groupId $groupMemberId" is APISwitchContact -> "/_switch @$contactId" is APISwitchGroupMember -> "/_switch #$groupId $groupMemberId" + is APIAbortSwitchContact -> "/_abort switch @$contactId" + is APIAbortSwitchGroupMember -> "/_abort switch #$groupId $groupMemberId" is APIGetContactCode -> "/_get code @$contactId" is APIGetGroupMemberCode -> "/_get code #$groupId $groupMemberId" is APIVerifyContact -> "/_verify code @$contactId" + if (connectionCode != null) " $connectionCode" else "" @@ -2120,6 +2138,8 @@ sealed class CC { is APIGroupMemberInfo -> "apiGroupMemberInfo" is APISwitchContact -> "apiSwitchContact" is APISwitchGroupMember -> "apiSwitchGroupMember" + is APIAbortSwitchContact -> "apiAbortSwitchContact" + is APIAbortSwitchGroupMember -> "apiAbortSwitchGroupMember" is APIGetContactCode -> "apiGetContactCode" is APIGetGroupMemberCode -> "apiGetGroupMemberCode" is APIVerifyContact -> "apiVerifyContact" @@ -3277,7 +3297,9 @@ sealed class CR { @Serializable @SerialName("chatItemTTL") class ChatItemTTL(val user: User, val chatItemTTL: Long? = null): CR() @Serializable @SerialName("networkConfig") class NetworkConfig(val networkConfig: NetCfg): CR() @Serializable @SerialName("contactInfo") class ContactInfo(val user: User, val contact: Contact, val connectionStats: ConnectionStats, val customUserProfile: Profile? = null): CR() - @Serializable @SerialName("groupMemberInfo") class GroupMemberInfo(val user: User, val groupInfo: GroupInfo, val member: GroupMember, val connectionStats_: ConnectionStats?): CR() + @Serializable @SerialName("groupMemberInfo") class GroupMemberInfo(val user: User, val groupInfo: GroupInfo, val member: GroupMember, val connectionStats_: ConnectionStats? = null): CR() + @Serializable @SerialName("contactSwitchAborted") class ContactSwitchAborted(val user: User, val contact: Contact, val connectionStats: ConnectionStats): CR() + @Serializable @SerialName("groupMemberSwitchAborted") class GroupMemberSwitchAborted(val user: User, val groupInfo: GroupInfo, val member: GroupMember, val connectionStats: ConnectionStats): CR() @Serializable @SerialName("contactCode") class ContactCode(val user: User, val contact: Contact, val connectionCode: String): CR() @Serializable @SerialName("groupMemberCode") class GroupMemberCode(val user: User, val groupInfo: GroupInfo, val member: GroupMember, val connectionCode: String): CR() @Serializable @SerialName("connectionVerified") class ConnectionVerified(val user: User, val verified: Boolean, val expectedCode: String): CR() @@ -3392,6 +3414,8 @@ sealed class CR { is NetworkConfig -> "networkConfig" is ContactInfo -> "contactInfo" is GroupMemberInfo -> "groupMemberInfo" + is ContactSwitchAborted -> "contactSwitchAborted" + is GroupMemberSwitchAborted -> "groupMemberSwitchAborted" is ContactCode -> "contactCode" is GroupMemberCode -> "groupMemberCode" is ConnectionVerified -> "connectionVerified" @@ -3503,6 +3527,8 @@ sealed class CR { is NetworkConfig -> json.encodeToString(networkConfig) is ContactInfo -> withUser(user, "contact: ${json.encodeToString(contact)}\nconnectionStats: ${json.encodeToString(connectionStats)}") is GroupMemberInfo -> withUser(user, "group: ${json.encodeToString(groupInfo)}\nmember: ${json.encodeToString(member)}\nconnectionStats: ${json.encodeToString(connectionStats_)}") + is ContactSwitchAborted -> withUser(user, "contact: ${json.encodeToString(contact)}\nconnectionStats: ${json.encodeToString(connectionStats)}") + is GroupMemberSwitchAborted -> withUser(user, "group: ${json.encodeToString(groupInfo)}\nmember: ${json.encodeToString(member)}\nconnectionStats: ${json.encodeToString(connectionStats)}") is ContactCode -> withUser(user, "contact: ${json.encodeToString(contact)}\nconnectionCode: $connectionCode") is GroupMemberCode -> withUser(user, "groupInfo: ${json.encodeToString(groupInfo)}\nmember: ${json.encodeToString(member)}\nconnectionCode: $connectionCode") is ConnectionVerified -> withUser(user, "verified: $verified\nconnectionCode: $expectedCode") @@ -3634,7 +3660,34 @@ abstract class TerminalItem { } @Serializable -class ConnectionStats(val rcvServers: List?, val sndServers: List?) +class ConnectionStats(val rcvQueuesInfo: List, val sndQueuesInfo: List) + +@Serializable +class RcvQueueInfo( + val rcvServer: String, + val rcvSwitchStatus: RcvSwitchStatus?, + var canAbortSwitch: Boolean +) + +@Serializable +enum class RcvSwitchStatus { + @SerialName("switch_started") SwitchStarted, + @SerialName("sending_qadd") SendingQADD, + @SerialName("sending_quse") SendingQUSE, + @SerialName("received_message") ReceivedMessage +} + +@Serializable +class SndQueueInfo( + val sndServer: String, + val sndSwitchStatus: SndSwitchStatus? +) + +@Serializable +enum class SndSwitchStatus { + @SerialName("sending_qkey") SendingQKEY, + @SerialName("sending_qtest") SendingQTEST +} @Serializable class UserContactLinkRec(val connReqContact: String, val autoAccept: AutoAccept? = null) { diff --git a/apps/android/app/src/main/java/chat/simplex/app/views/chat/ChatInfoView.kt b/apps/android/app/src/main/java/chat/simplex/app/views/chat/ChatInfoView.kt index a97d591388..00bf8d5444 100644 --- a/apps/android/app/src/main/java/chat/simplex/app/views/chat/ChatInfoView.kt +++ b/apps/android/app/src/main/java/chat/simplex/app/views/chat/ChatInfoView.kt @@ -5,11 +5,9 @@ import InfoRowEllipsis import SectionBottomSpacer import SectionDividerSpaced import SectionItemView -import SectionItemViewWithIcon import SectionSpacer import SectionTextFooter import SectionView -import TextIconSpaced import android.widget.Toast import androidx.activity.compose.BackHandler import androidx.compose.foundation.* @@ -46,7 +44,7 @@ import kotlinx.datetime.Clock fun ChatInfoView( chatModel: ChatModel, contact: Contact, - connStats: ConnectionStats?, + connectionStats: ConnectionStats?, customUserProfile: Profile?, localAlias: String, connectionCode: String?, @@ -54,6 +52,7 @@ fun ChatInfoView( ) { BackHandler(onBack = close) val chat = chatModel.chats.firstOrNull { it.id == chatModel.chatId.value } + val connStats = remember { mutableStateOf(connectionStats) } val developerTools = chatModel.controller.appPrefs.developerTools.get() if (chat != null) { val contactNetworkStatus = remember(chatModel.networkStatuses.toMap()) { @@ -62,7 +61,7 @@ fun ChatInfoView( ChatInfoLayout( chat, contact, - connStats, + connStats = connStats, contactNetworkStatus.value, customUserProfile, localAlias, @@ -82,7 +81,18 @@ fun ChatInfoView( deleteContact = { deleteContactDialog(chat.chatInfo, chatModel, close) }, clearChat = { clearChatDialog(chat.chatInfo, chatModel, close) }, switchContactAddress = { - showSwitchContactAddressAlert(chatModel, contact.contactId) + showSwitchAddressAlert(switchAddress = { + withApi { + chatModel.controller.apiSwitchContact(contact.contactId) + } + }) + }, + abortSwitchContactAddress = { + showAbortSwitchAddressAlert(abortSwitchAddress = { + withApi { + connStats.value = chatModel.controller.apiAbortSwitchContact(contact.contactId) + } + }) }, verifyClicked = { ModalManager.shared.showModalCloseable { close -> @@ -156,7 +166,7 @@ fun clearChatDialog(chatInfo: ChatInfo, chatModel: ChatModel, close: (() -> Unit fun ChatInfoLayout( chat: Chat, contact: Contact, - connStats: ConnectionStats?, + connStats: MutableState, contactNetworkStatus: NetworkStatus, customUserProfile: Profile?, localAlias: String, @@ -167,8 +177,10 @@ fun ChatInfoLayout( deleteContact: () -> Unit, clearChat: () -> Unit, switchContactAddress: () -> Unit, + abortSwitchContactAddress: () -> Unit, verifyClicked: () -> Unit, ) { + val cStats = connStats.value Column( Modifier .fillMaxWidth() @@ -209,21 +221,30 @@ fun ChatInfoLayout( } SectionView(title = stringResource(R.string.conn_stats_section_title_servers)) { - SwitchAddressButton(switchContactAddress) - if (connStats != null) { - SectionItemView({ - AlertManager.shared.showAlertMsg( - generalGetString(R.string.network_status), - contactNetworkStatus.statusExplanation - )}) { - NetworkStatusRow(contactNetworkStatus) + SectionItemView({ + AlertManager.shared.showAlertMsg( + generalGetString(R.string.network_status), + contactNetworkStatus.statusExplanation + )}) { + NetworkStatusRow(contactNetworkStatus) + } + if (cStats != null) { + SwitchAddressButton( + disabled = cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null }, + switchAddress = switchContactAddress + ) + if (cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null }) { + AbortSwitchAddressButton( + disabled = cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null && !it.canAbortSwitch }, + abortSwitchAddress = abortSwitchContactAddress + ) } - val rcvServers = connStats.rcvServers - if (rcvServers != null && rcvServers.isNotEmpty()) { + val rcvServers = cStats.rcvQueuesInfo.map { it.rcvServer } + if (rcvServers.isNotEmpty()) { SimplexServers(stringResource(R.string.receiving_via), rcvServers) } - val sndServers = connStats.sndServers - if (sndServers != null && sndServers.isNotEmpty()) { + val sndServers = cStats.sndQueuesInfo.map { it.sndServer } + if (sndServers.isNotEmpty()) { SimplexServers(stringResource(R.string.sending_via), sndServers) } } @@ -360,7 +381,7 @@ private fun ServerImage(networkStatus: NetworkStatus) { Box(Modifier.size(18.dp)) { when (networkStatus) { is NetworkStatus.Connected -> - Icon(painterResource(R.drawable.ic_circle_filled), stringResource(R.string.icon_descr_server_status_connected), tint = MaterialTheme.colors.primaryVariant) + Icon(painterResource(R.drawable.ic_circle_filled), stringResource(R.string.icon_descr_server_status_connected), tint = Color.Green) is NetworkStatus.Disconnected -> Icon(painterResource(R.drawable.ic_pending_filled), stringResource(R.string.icon_descr_server_status_disconnected), tint = MaterialTheme.colors.secondary) is NetworkStatus.Error -> @@ -381,9 +402,22 @@ fun SimplexServers(text: String, servers: List) { } @Composable -fun SwitchAddressButton(onClick: () -> Unit) { - SectionItemView(onClick) { - Text(stringResource(R.string.switch_receiving_address), color = MaterialTheme.colors.primary) +fun SwitchAddressButton(disabled: Boolean, switchAddress: () -> Unit) { + SectionItemView(switchAddress) { + Text( + stringResource(R.string.switch_receiving_address), + color = if (disabled) MaterialTheme.colors.secondary else MaterialTheme.colors.primary + ) + } +} + +@Composable +fun AbortSwitchAddressButton(disabled: Boolean, abortSwitchAddress: () -> Unit) { + SectionItemView(abortSwitchAddress) { + Text( + stringResource(R.string.abort_switch_receiving_address), + color = if (disabled) MaterialTheme.colors.secondary else MaterialTheme.colors.primary + ) } } @@ -445,20 +479,23 @@ private fun setContactAlias(contactApiId: Long, localAlias: String, chatModel: C } } -private fun showSwitchContactAddressAlert(m: ChatModel, contactId: Long) { +fun showSwitchAddressAlert(switchAddress: () -> Unit) { AlertManager.shared.showAlertDialog( title = generalGetString(R.string.switch_receiving_address_question), text = generalGetString(R.string.switch_receiving_address_desc), - confirmText = generalGetString(R.string.switch_verb), - onConfirm = { - switchContactAddress(m, contactId) - }, - destructive = true, + confirmText = generalGetString(R.string.change_verb), + onConfirm = switchAddress ) } -private fun switchContactAddress(m: ChatModel, contactId: Long) = withApi { - m.controller.apiSwitchContact(contactId) +fun showAbortSwitchAddressAlert(abortSwitchAddress: () -> Unit) { + AlertManager.shared.showAlertDialog( + title = generalGetString(R.string.abort_switch_receiving_address_question), + text = generalGetString(R.string.abort_switch_receiving_address_desc), + confirmText = generalGetString(R.string.abort_switch_receiving_address_confirm), + onConfirm = abortSwitchAddress, + destructive = true, + ) } @Preview @@ -474,7 +511,7 @@ fun PreviewChatInfoLayout() { localAlias = "", connectionCode = "123", developerTools = false, - connStats = null, + connStats = remember { mutableStateOf(null) }, contactNetworkStatus = NetworkStatus.Connected(), onLocalAliasChanged = {}, customUserProfile = null, @@ -482,6 +519,7 @@ fun PreviewChatInfoLayout() { deleteContact = {}, clearChat = {}, switchContactAddress = {}, + abortSwitchContactAddress = {}, verifyClicked = {}, ) } diff --git a/apps/android/app/src/main/java/chat/simplex/app/views/chat/group/GroupMemberInfoView.kt b/apps/android/app/src/main/java/chat/simplex/app/views/chat/group/GroupMemberInfoView.kt index aa0fe05aba..cd0b1c460b 100644 --- a/apps/android/app/src/main/java/chat/simplex/app/views/chat/group/GroupMemberInfoView.kt +++ b/apps/android/app/src/main/java/chat/simplex/app/views/chat/group/GroupMemberInfoView.kt @@ -37,7 +37,7 @@ import kotlinx.datetime.Clock fun GroupMemberInfoView( groupInfo: GroupInfo, member: GroupMember, - connStats: ConnectionStats?, + connectionStats: ConnectionStats?, connectionCode: String?, chatModel: ChatModel, close: () -> Unit, @@ -45,6 +45,7 @@ fun GroupMemberInfoView( ) { BackHandler(onBack = close) val chat = chatModel.chats.firstOrNull { it.id == chatModel.chatId.value } + val connStats = remember { mutableStateOf(connectionStats) } val developerTools = chatModel.controller.appPrefs.developerTools.get() if (chat != null) { val newRole = remember { mutableStateOf(member.memberRole) } @@ -98,7 +99,18 @@ fun GroupMemberInfoView( } }, switchMemberAddress = { - switchMemberAddress(chatModel, groupInfo, member) + showSwitchAddressAlert(switchAddress = { + withApi { + chatModel.controller.apiSwitchGroupMember(groupInfo.apiId, member.groupMemberId) + } + }) + }, + abortSwitchMemberAddress = { + showAbortSwitchAddressAlert(abortSwitchAddress = { + withApi { + connStats.value = chatModel.controller.apiAbortSwitchGroupMember(groupInfo.apiId, member.groupMemberId) + } + }) }, verifyClicked = { ModalManager.shared.showModalCloseable { close -> @@ -152,7 +164,7 @@ fun removeMemberDialog(groupInfo: GroupInfo, member: GroupMember, chatModel: Cha fun GroupMemberInfoLayout( groupInfo: GroupInfo, member: GroupMember, - connStats: ConnectionStats?, + connStats: MutableState, newRole: MutableState, developerTools: Boolean, connectionCode: String?, @@ -162,8 +174,10 @@ fun GroupMemberInfoLayout( removeMember: () -> Unit, onRoleSelected: (GroupMemberRole) -> Unit, switchMemberAddress: () -> Unit, + abortSwitchMemberAddress: () -> Unit, verifyClicked: () -> Unit, ) { + val cStats = connStats.value fun knownDirectChat(contactId: Long): Chat? { val chat = getContactChat(contactId) return if (chat != null && chat.chatInfo is ChatInfo.Direct && chat.chatInfo.contact.directOrUsed) { @@ -235,21 +249,26 @@ fun GroupMemberInfoLayout( InfoRow(stringResource(R.string.info_row_connection), connLevelDesc) } } - if (connStats != null) { + if (cStats != null) { SectionDividerSpaced() SectionView(title = stringResource(R.string.conn_stats_section_title_servers)) { - SwitchAddressButton(switchMemberAddress) - val rcvServers = connStats.rcvServers - val sndServers = connStats.sndServers - if ((rcvServers != null && rcvServers.isNotEmpty()) || (sndServers != null && sndServers.isNotEmpty())) { - if (rcvServers != null && rcvServers.isNotEmpty()) { - SimplexServers(stringResource(R.string.receiving_via), rcvServers) - if (sndServers != null && sndServers.isNotEmpty()) { - SimplexServers(stringResource(R.string.sending_via), sndServers) - } - } else if (sndServers != null && sndServers.isNotEmpty()) { - SimplexServers(stringResource(R.string.sending_via), sndServers) - } + SwitchAddressButton( + disabled = cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null }, + switchAddress = switchMemberAddress + ) + if (cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null }) { + AbortSwitchAddressButton( + disabled = cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null && !it.canAbortSwitch }, + abortSwitchAddress = abortSwitchMemberAddress + ) + } + val rcvServers = cStats.rcvQueuesInfo.map { it.rcvServer } + if (rcvServers.isNotEmpty()) { + SimplexServers(stringResource(R.string.receiving_via), rcvServers) + } + val sndServers = cStats.sndQueuesInfo.map { it.sndServer } + if (sndServers.isNotEmpty()) { + SimplexServers(stringResource(R.string.sending_via), sndServers) } } } @@ -376,10 +395,6 @@ private fun updateMemberRoleDialog( ) } -private fun switchMemberAddress(m: ChatModel, groupInfo: GroupInfo, member: GroupMember) = withApi { - m.controller.apiSwitchGroupMember(groupInfo.apiId, member.groupMemberId) -} - @Preview @Composable fun PreviewGroupMemberInfoLayout() { @@ -387,7 +402,7 @@ fun PreviewGroupMemberInfoLayout() { GroupMemberInfoLayout( groupInfo = GroupInfo.sampleData, member = GroupMember.sampleData, - connStats = null, + connStats = remember { mutableStateOf(null) }, newRole = remember { mutableStateOf(GroupMemberRole.Member) }, developerTools = false, connectionCode = "123", @@ -397,6 +412,7 @@ fun PreviewGroupMemberInfoLayout() { removeMember = {}, onRoleSelected = {}, switchMemberAddress = {}, + abortSwitchMemberAddress = {}, verifyClicked = {}, ) } diff --git a/apps/android/app/src/main/res/values/strings.xml b/apps/android/app/src/main/res/values/strings.xml index 13108eb090..4130f55ac4 100644 --- a/apps/android/app/src/main/res/values/strings.xml +++ b/apps/android/app/src/main/res/values/strings.xml @@ -103,6 +103,7 @@ Error deleting contact request Error deleting pending contact connection Error changing address + Error aborting address change Test failed at step %s. Server requires authorization to create queues, check password Server requires authorization to upload, check password @@ -329,8 +330,11 @@ Disconnected Error Pending - Switch receiving address? - This feature is experimental! It will only work if the other client has version 4.2 installed. You should see the message in the conversation once the address change is completed – please check that you can still receive messages from this contact (or group member). + Change receiving address? + Receiving address will be changed to a different server. Address change will complete after sender comes online. + Abort changing address? + Address change will be aborted. Old receiving address will be used. + Abort View security code Verify security code @@ -1170,7 +1174,8 @@ Receiving via Sending via Network status - Switch receiving address + Change receiving address + Abort changing address Create secret group diff --git a/apps/ios/Shared/Model/SimpleXAPI.swift b/apps/ios/Shared/Model/SimpleXAPI.swift index 263b02e37a..3881835fb8 100644 --- a/apps/ios/Shared/Model/SimpleXAPI.swift +++ b/apps/ios/Shared/Model/SimpleXAPI.swift @@ -488,6 +488,18 @@ func apiSwitchGroupMember(_ groupId: Int64, _ groupMemberId: Int64) async throws try await sendCommandOkResp(.apiSwitchGroupMember(groupId: groupId, groupMemberId: groupMemberId)) } +func apiAbortSwitchContact(_ contactId: Int64) throws -> ConnectionStats { + let r = chatSendCmdSync(.apiAbortSwitchContact(contactId: contactId)) + if case let .contactSwitchAborted(_, _, connectionStats) = r { return connectionStats } + throw r +} + +func apiAbortSwitchGroupMember(_ groupId: Int64, _ groupMemberId: Int64) throws -> ConnectionStats { + let r = chatSendCmdSync(.apiAbortSwitchGroupMember(groupId: groupId, groupMemberId: groupMemberId)) + if case let .groupMemberSwitchAborted(_, _, _, connectionStats) = r { return connectionStats } + throw r +} + func apiGetContactCode(_ contactId: Int64) async throws -> (Contact, String) { let r = await chatSendCmd(.apiGetContactCode(contactId: contactId)) if case let .contactCode(_, contact, connectionCode) = r { return (contact, connectionCode) } diff --git a/apps/ios/Shared/Views/Chat/ChatInfoView.swift b/apps/ios/Shared/Views/Chat/ChatInfoView.swift index b72006b3fe..847efa9e25 100644 --- a/apps/ios/Shared/Views/Chat/ChatInfoView.swift +++ b/apps/ios/Shared/Views/Chat/ChatInfoView.swift @@ -36,9 +36,8 @@ func localizedInfoRow(_ title: LocalizedStringKey, _ value: LocalizedStringKey) } } -@ViewBuilder func smpServers(_ title: LocalizedStringKey, _ servers: [String]?) -> some View { - if let servers = servers, - servers.count > 0 { +@ViewBuilder func smpServers(_ title: LocalizedStringKey, _ servers: [String]) -> some View { + if servers.count > 0 { HStack { Text(title).frame(width: 120, alignment: .leading) Button(serverHost(servers[0])) { @@ -76,6 +75,7 @@ struct ChatInfoView: View { case clearChatAlert case networkStatusAlert case switchAddressAlert + case abortSwitchAddressAlert case error(title: LocalizedStringKey, error: LocalizedStringKey = "") var id: String { @@ -84,6 +84,7 @@ struct ChatInfoView: View { case .clearChatAlert: return "clearChatAlert" case .networkStatusAlert: return "networkStatusAlert" case .switchAddressAlert: return "switchAddressAlert" + case .abortSwitchAddressAlert: return "abortSwitchAddressAlert" case let .error(title, _): return "error \(title)" } } @@ -136,12 +137,19 @@ struct ChatInfoView: View { .onTapGesture { alert = .networkStatusAlert } - Button("Change receiving address") { - alert = .switchAddressAlert - } if let connStats = connectionStats { - smpServers("Receiving via", connStats.rcvServers) - smpServers("Sending via", connStats.sndServers) + Button("Change receiving address") { + alert = .switchAddressAlert + } + .disabled(connStats.rcvQueuesInfo.contains { $0.rcvSwitchStatus != nil }) + if connStats.rcvQueuesInfo.contains { $0.rcvSwitchStatus != nil } { + Button("Abort changing address") { + alert = .abortSwitchAddressAlert + } + .disabled(connStats.rcvQueuesInfo.contains { $0.rcvSwitchStatus != nil && !$0.canAbortSwitch }) + } + smpServers("Receiving via", connStats.rcvQueuesInfo.map { $0.rcvServer }) + smpServers("Sending via", connStats.sndQueuesInfo.map { $0.sndServer }) } } @@ -166,6 +174,7 @@ struct ChatInfoView: View { case .clearChatAlert: return clearChatAlert() case .networkStatusAlert: return networkStatusAlert() case .switchAddressAlert: return switchAddressAlert(switchContactAddress) + case .abortSwitchAddressAlert: return abortSwitchAddressAlert(abortSwitchContactAddress) case let .error(title, error): return mkAlert(title: title, message: error) } } @@ -369,13 +378,37 @@ struct ChatInfoView: View { } } } + + private func abortSwitchContactAddress() { + Task { + do { + let stats = try apiAbortSwitchContact(contact.apiId) + connectionStats = stats + } catch let error { + logger.error("abortSwitchContactAddress apiAbortSwitchContact error: \(responseError(error))") + let a = getErrorAlert(error, "Error aborting address change") + await MainActor.run { + alert = .error(title: a.title, error: a.message) + } + } + } + } } func switchAddressAlert(_ switchAddress: @escaping () -> Void) -> Alert { Alert( title: Text("Change receiving address?"), - message: Text("This feature is experimental! It will only work if the other client has version 4.2 installed. You should see the message in the conversation once the address change is completed – please check that you can still receive messages from this contact (or group member)."), - primaryButton: .destructive(Text("Change"), action: switchAddress), + message: Text("Receiving address will be changed to a different server. Address change will complete after sender comes online."), + primaryButton: .default(Text("Change"), action: switchAddress), + secondaryButton: .cancel() + ) +} + +func abortSwitchAddressAlert(_ abortSwitchAddress: @escaping () -> Void) -> Alert { + Alert( + title: Text("Abort changing address?"), + message: Text("Address change will be aborted. Old receiving address will be used."), + primaryButton: .destructive(Text("Abort"), action: abortSwitchAddress), secondaryButton: .cancel() ) } diff --git a/apps/ios/Shared/Views/Chat/Group/GroupMemberInfoView.swift b/apps/ios/Shared/Views/Chat/Group/GroupMemberInfoView.swift index 1f55f56071..71ef5a68d5 100644 --- a/apps/ios/Shared/Views/Chat/Group/GroupMemberInfoView.swift +++ b/apps/ios/Shared/Views/Chat/Group/GroupMemberInfoView.swift @@ -26,6 +26,7 @@ struct GroupMemberInfoView: View { case removeMemberAlert(mem: GroupMember) case changeMemberRoleAlert(mem: GroupMember, role: GroupMemberRole) case switchAddressAlert + case abortSwitchAddressAlert case connRequestSentAlert(type: ConnReqType) case error(title: LocalizedStringKey, error: LocalizedStringKey) case other(alert: Alert) @@ -35,6 +36,7 @@ struct GroupMemberInfoView: View { case .removeMemberAlert: return "removeMemberAlert" case let .changeMemberRoleAlert(_, role): return "changeMemberRoleAlert \(role.rawValue)" case .switchAddressAlert: return "switchAddressAlert" + case .abortSwitchAddressAlert: return "abortSwitchAddressAlert" case .connRequestSentAlert: return "connRequestSentAlert" case let .error(title, _): return "error \(title)" case let .other(alert): return "other \(alert)" @@ -127,8 +129,15 @@ struct GroupMemberInfoView: View { Button("Change receiving address") { alert = .switchAddressAlert } - smpServers("Receiving via", connStats.rcvServers) - smpServers("Sending via", connStats.sndServers) + .disabled(connStats.rcvQueuesInfo.contains { $0.rcvSwitchStatus != nil }) + if connStats.rcvQueuesInfo.contains { $0.rcvSwitchStatus != nil } { + Button("Abort changing address") { + alert = .abortSwitchAddressAlert + } + .disabled(connStats.rcvQueuesInfo.contains { $0.rcvSwitchStatus != nil && !$0.canAbortSwitch }) + } + smpServers("Receiving via", connStats.rcvQueuesInfo.map { $0.rcvServer }) + smpServers("Sending via", connStats.sndQueuesInfo.map { $0.sndServer }) } } @@ -175,6 +184,7 @@ struct GroupMemberInfoView: View { case let .removeMemberAlert(mem): return removeMemberAlert(mem) case let .changeMemberRoleAlert(mem, _): return changeMemberRoleAlert(mem) case .switchAddressAlert: return switchAddressAlert(switchMemberAddress) + case .abortSwitchAddressAlert: return abortSwitchAddressAlert(abortSwitchMemberAddress) case let .connRequestSentAlert(type): return connReqSentAlert(type) case let .error(title, error): return Alert(title: Text(title), message: Text(error)) case let .other(alert): return alert @@ -356,6 +366,21 @@ struct GroupMemberInfoView: View { } } } + + private func abortSwitchMemberAddress() { + Task { + do { + let stats = try apiAbortSwitchGroupMember(groupInfo.apiId, member.groupMemberId) + connectionStats = stats + } catch let error { + logger.error("abortSwitchMemberAddress apiAbortSwitchGroupMember error: \(responseError(error))") + let a = getErrorAlert(error, "Error aborting address change") + await MainActor.run { + alert = .error(title: a.title, error: a.message) + } + } + } + } } struct GroupMemberInfoView_Previews: PreviewProvider { diff --git a/apps/ios/SimpleXChat/APITypes.swift b/apps/ios/SimpleXChat/APITypes.swift index af23f7d676..212eab8ccd 100644 --- a/apps/ios/SimpleXChat/APITypes.swift +++ b/apps/ios/SimpleXChat/APITypes.swift @@ -71,6 +71,8 @@ public enum ChatCommand { case apiGroupMemberInfo(groupId: Int64, groupMemberId: Int64) case apiSwitchContact(contactId: Int64) case apiSwitchGroupMember(groupId: Int64, groupMemberId: Int64) + case apiAbortSwitchContact(contactId: Int64) + case apiAbortSwitchGroupMember(groupId: Int64, groupMemberId: Int64) case apiGetContactCode(contactId: Int64) case apiGetGroupMemberCode(groupId: Int64, groupMemberId: Int64) case apiVerifyContact(contactId: Int64, connectionCode: String?) @@ -179,6 +181,8 @@ public enum ChatCommand { case let .apiGroupMemberInfo(groupId, groupMemberId): return "/_info #\(groupId) \(groupMemberId)" case let .apiSwitchContact(contactId): return "/_switch @\(contactId)" case let .apiSwitchGroupMember(groupId, groupMemberId): return "/_switch #\(groupId) \(groupMemberId)" + case let .apiAbortSwitchContact(contactId): return "/_abort switch @\(contactId)" + case let .apiAbortSwitchGroupMember(groupId, groupMemberId): return "/_abort switch #\(groupId) \(groupMemberId)" case let .apiGetContactCode(contactId): return "/_get code @\(contactId)" case let .apiGetGroupMemberCode(groupId, groupMemberId): return "/_get code #\(groupId) \(groupMemberId)" case let .apiVerifyContact(contactId, .some(connectionCode)): return "/_verify code @\(contactId) \(connectionCode)" @@ -285,6 +289,8 @@ public enum ChatCommand { case .apiGroupMemberInfo: return "apiGroupMemberInfo" case .apiSwitchContact: return "apiSwitchContact" case .apiSwitchGroupMember: return "apiSwitchGroupMember" + case .apiAbortSwitchContact: return "apiAbortSwitchContact" + case .apiAbortSwitchGroupMember: return "apiAbortSwitchGroupMember" case .apiGetContactCode: return "apiGetContactCode" case .apiGetGroupMemberCode: return "apiGetGroupMemberCode" case .apiVerifyContact: return "apiVerifyContact" @@ -397,6 +403,8 @@ public enum ChatResponse: Decodable, Error { case networkConfig(networkConfig: NetCfg) case contactInfo(user: User, contact: Contact, connectionStats: ConnectionStats, customUserProfile: Profile?) case groupMemberInfo(user: User, groupInfo: GroupInfo, member: GroupMember, connectionStats_: ConnectionStats?) + case contactSwitchAborted(user: User, contact: Contact, connectionStats: ConnectionStats) + case groupMemberSwitchAborted(user: User, groupInfo: GroupInfo, member: GroupMember, connectionStats: ConnectionStats) case contactCode(user: User, contact: Contact, connectionCode: String) case groupMemberCode(user: User, groupInfo: GroupInfo, member: GroupMember, connectionCode: String) case connectionVerified(user: User, verified: Bool, expectedCode: String) @@ -516,6 +524,8 @@ public enum ChatResponse: Decodable, Error { case .networkConfig: return "networkConfig" case .contactInfo: return "contactInfo" case .groupMemberInfo: return "groupMemberInfo" + case .contactSwitchAborted: return "contactSwitchAborted" + case .groupMemberSwitchAborted: return "groupMemberSwitchAborted" case .contactCode: return "contactCode" case .groupMemberCode: return "groupMemberCode" case .connectionVerified: return "connectionVerified" @@ -633,7 +643,9 @@ public enum ChatResponse: Decodable, Error { case let .chatItemTTL(u, chatItemTTL): return withUser(u, String(describing: chatItemTTL)) case let .networkConfig(networkConfig): return String(describing: networkConfig) case let .contactInfo(u, contact, connectionStats, customUserProfile): return withUser(u, "contact: \(String(describing: contact))\nconnectionStats: \(String(describing: connectionStats))\ncustomUserProfile: \(String(describing: customUserProfile))") - case let .groupMemberInfo(u, groupInfo, member, connectionStats_): return withUser(u, "groupInfo: \(String(describing: groupInfo))\nmember: \(String(describing: member))\nconnectionStats_: \(String(describing: connectionStats_)))") + case let .groupMemberInfo(u, groupInfo, member, connectionStats_): return withUser(u, "groupInfo: \(String(describing: groupInfo))\nmember: \(String(describing: member))\nconnectionStats_: \(String(describing: connectionStats_))") + case let .contactSwitchAborted(u, contact, connectionStats): return withUser(u, "contact: \(String(describing: contact))\nconnectionStats: \(String(describing: connectionStats))") + case let .groupMemberSwitchAborted(u, groupInfo, member, connectionStats): return withUser(u, "groupInfo: \(String(describing: groupInfo))\nmember: \(String(describing: member))\nconnectionStats: \(String(describing: connectionStats))") case let .contactCode(u, contact, connectionCode): return withUser(u, "contact: \(String(describing: contact))\nconnectionCode: \(connectionCode)") case let .groupMemberCode(u, groupInfo, member, connectionCode): return withUser(u, "groupInfo: \(String(describing: groupInfo))\nmember: \(String(describing: member))\nconnectionCode: \(connectionCode)") case let .connectionVerified(u, verified, expectedCode): return withUser(u, "verified: \(verified)\nconnectionCode: \(expectedCode)") @@ -1083,8 +1095,31 @@ public struct ChatSettings: Codable { } public struct ConnectionStats: Codable { - public var rcvServers: [String]? - public var sndServers: [String]? + public var rcvQueuesInfo: [RcvQueueInfo] + public var sndQueuesInfo: [SndQueueInfo] +} + +public struct RcvQueueInfo: Codable { + public var rcvServer: String + public var rcvSwitchStatus: RcvSwitchStatus? + public var canAbortSwitch: Bool +} + +public enum RcvSwitchStatus: String, Codable { + case switchStarted = "switch_started" + case sendingQADD = "sending_qadd" + case sendingQUSE = "sending_quse" + case receivedMessage = "received_message" +} + +public struct SndQueueInfo: Codable { + public var sndServer: String + public var sndSwitchStatus: SndSwitchStatus? +} + +public enum SndSwitchStatus: String, Codable { + case sendingQKEY = "sending_qkey" + case sendingQTEST = "sending_qtest" } public struct UserContactLink: Decodable { diff --git a/apps/ios/SimpleXChat/ChatTypes.swift b/apps/ios/SimpleXChat/ChatTypes.swift index ca60f31c87..58d1642f5e 100644 --- a/apps/ios/SimpleXChat/ChatTypes.swift +++ b/apps/ios/SimpleXChat/ChatTypes.swift @@ -3067,6 +3067,7 @@ public enum SndConnEvent: Decodable { public enum SwitchPhase: String, Decodable { case started case confirmed + case secured case completed } From ec7bff9205faf919b359ad895334e8c3fffd46be Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 19 Jun 2023 11:49:45 +0100 Subject: [PATCH 8/9] ios: search members (#2593) --- apps/ios/Shared/Views/Chat/ChatView.swift | 4 +- .../Chat/Group/AddGroupMembersView.swift | 38 ++++++++++++++++++- .../Views/Chat/Group/GroupChatInfoView.swift | 11 +++++- 3 files changed, 48 insertions(+), 5 deletions(-) diff --git a/apps/ios/Shared/Views/Chat/ChatView.swift b/apps/ios/Shared/Views/Chat/ChatView.swift index 8a43434289..6e05e645ed 100644 --- a/apps/ios/Shared/Views/Chat/ChatView.swift +++ b/apps/ios/Shared/Views/Chat/ChatView.swift @@ -193,7 +193,7 @@ struct ChatView: View { .focused($searchFocussed) .foregroundColor(.primary) .frame(maxWidth: .infinity) - + Button { searchText = "" } label: { @@ -204,7 +204,7 @@ struct ChatView: View { .foregroundColor(.secondary) .background(Color(.secondarySystemBackground)) .cornerRadius(10.0) - + Button ("Cancel") { searchText = "" searchMode = false diff --git a/apps/ios/Shared/Views/Chat/Group/AddGroupMembersView.swift b/apps/ios/Shared/Views/Chat/Group/AddGroupMembersView.swift index f52b7c327c..123d93714d 100644 --- a/apps/ios/Shared/Views/Chat/Group/AddGroupMembersView.swift +++ b/apps/ios/Shared/Views/Chat/Group/AddGroupMembersView.swift @@ -29,6 +29,8 @@ struct AddGroupMembersViewCommon: View { @State private var selectedContacts = Set() @State private var selectedRole: GroupMemberRole = .member @State private var alert: AddGroupMembersAlert? + @State private var searchText: String = "" + @FocusState private var searchFocussed private enum AddGroupMembersAlert: Identifiable { case prohibitedToInviteIncognito @@ -85,7 +87,7 @@ struct AddGroupMembersViewCommon: View { if showFooterCounter { if (count >= 1) { HStack { - Button { selectedContacts.removeAll() } label: { Text("Clear") } + Button { selectedContacts.removeAll() } label: { Text("Clear").font(.caption) } Spacer() Text("\(count) contact(s) selected") } @@ -97,7 +99,11 @@ struct AddGroupMembersViewCommon: View { } Section { - ForEach(membersToAdd) { contact in + searchFieldView(text: $searchText, focussed: $searchFocussed) + .padding(.leading, 2) + let s = searchText.trimmingCharacters(in: .whitespaces).localizedLowercase + let members = s == "" ? membersToAdd : membersToAdd.filter { $0.chatViewName.localizedLowercase.contains(s) } + ForEach(members) { contact in contactCheckView(contact) } } @@ -116,6 +122,9 @@ struct AddGroupMembersViewCommon: View { return Alert(title: Text(title), message: Text(error)) } } + .onChange(of: selectedContacts) { _ in + searchFocussed = false + } } private func inviteMembersButton() -> some View { @@ -199,6 +208,31 @@ struct AddGroupMembersViewCommon: View { } } +func searchFieldView(text: Binding, focussed: FocusState.Binding) -> some View { + HStack { + Image(systemName: "magnifyingglass") + .resizable() + .scaledToFit() + .frame(height: 20) + .padding(.trailing, 10) + TextField("Search", text: text) + .focused(focussed) + .foregroundColor(.primary) + .frame(maxWidth: .infinity) + Image(systemName: "xmark.circle.fill") + .resizable() + .scaledToFit() + .opacity(text.wrappedValue == "" ? 0 : 1) + .frame(height: 20) + .onTapGesture { + text.wrappedValue = "" + focussed.wrappedValue = false + } + } + .foregroundColor(.secondary) + .frame(height: 36) +} + struct AddGroupMembersView_Previews: PreviewProvider { static var previews: some View { AddGroupMembersView(chat: Chat(chatInfo: ChatInfo.sampleData.group), groupInfo: GroupInfo.sampleData) diff --git a/apps/ios/Shared/Views/Chat/Group/GroupChatInfoView.swift b/apps/ios/Shared/Views/Chat/Group/GroupChatInfoView.swift index 9da75d3e2a..a9e7e8fed9 100644 --- a/apps/ios/Shared/Views/Chat/Group/GroupChatInfoView.swift +++ b/apps/ios/Shared/Views/Chat/Group/GroupChatInfoView.swift @@ -22,6 +22,8 @@ struct GroupChatInfoView: View { @State private var connectionStats: ConnectionStats? @State private var connectionCode: String? @AppStorage(DEFAULT_DEVELOPER_TOOLS) private var developerTools = false + @State private var searchText: String = "" + @FocusState private var searchFocussed enum GroupChatInfoViewAlert: Identifiable { case deleteGroupAlert @@ -67,8 +69,14 @@ struct GroupChatInfoView: View { addMembersButton() } } + if members.count > 8 { + searchFieldView(text: $searchText, focussed: $searchFocussed) + .padding(.leading, 8) + } + let s = searchText.trimmingCharacters(in: .whitespaces).localizedLowercase + let filteredMembers = s == "" ? members : members.filter { $0.chatViewName.localizedLowercase.contains(s) } memberView(groupInfo.membership, user: true) - ForEach(members) { member in + ForEach(filteredMembers) { member in ZStack { NavigationLink { memberInfoView(member.groupMemberId) @@ -144,6 +152,7 @@ struct GroupChatInfoView: View { NavigationLink { AddGroupMembersView(chat: chat, groupInfo: groupInfo) .onAppear { + searchFocussed = false Task { let groupMembers = await apiListMembers(groupInfo.groupId) await MainActor.run { From d929c34e71acf997c5d1a57a9c60aa0aa8bfc788 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 19 Jun 2023 16:07:17 +0400 Subject: [PATCH 9/9] core: include ConnectionStats into switch api response (#2594) --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat.hs | 10 ++++++---- src/Simplex/Chat/Controller.hs | 2 ++ src/Simplex/Chat/View.hs | 2 ++ stack.yaml | 2 +- tests/ChatTests/Direct.hs | 12 ++++++------ 7 files changed, 19 insertions(+), 13 deletions(-) diff --git a/cabal.project b/cabal.project index 9714126479..483586e581 100644 --- a/cabal.project +++ b/cabal.project @@ -7,7 +7,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 2efe1496d2622a56656a6a00a2cc19005e754468 + tag: c31668ce286380ed6cf6829f1fa0b246cd52d828 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 312d11c14e..c99b75dc41 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."2efe1496d2622a56656a6a00a2cc19005e754468" = "0syy10zn3ci1nbs00r0l5vhvqkwlqcgmmd5c196pch0xvrk5qbfi"; + "https://github.com/simplex-chat/simplexmq.git"."c31668ce286380ed6cf6829f1fa0b246cd52d828" = "16bka5rda82wz20n9ldb5wydkf4f9knj3n743832dc93mz60mibw"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb"; "https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 4582ef4767..b823a4bccb 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1110,12 +1110,14 @@ processChatCommand = \case pure $ CRGroupMemberInfo user g m connectionStats APISwitchContact contactId -> withUser $ \user -> do ct <- withStore $ \db -> getContact db user contactId - withAgent $ \a -> switchConnectionAsync a "" $ contactConnId ct - ok user + connectionStats <- withAgent $ \a -> switchConnectionAsync a "" $ contactConnId ct + pure $ CRContactSwitchStarted user ct connectionStats APISwitchGroupMember gId gMemberId -> withUser $ \user -> do - m <- withStore $ \db -> getGroupMember db user gId gMemberId + (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId case memberConnId m of - Just connId -> withAgent (\a -> switchConnectionAsync a "" connId) >> ok user + Just connId -> do + connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId) + pure $ CRGroupMemberSwitchStarted user g m connectionStats _ -> throwChatError CEGroupMemberNotActive APIAbortSwitchContact contactId -> withUser $ \user -> do ct <- withStore $ \db -> getContact db user contactId diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index e2680bee60..8e1bb3d143 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -408,6 +408,8 @@ data ChatResponse | CRNetworkConfig {networkConfig :: NetworkConfig} | CRContactInfo {user :: User, contact :: Contact, connectionStats :: ConnectionStats, customUserProfile :: Maybe Profile} | CRGroupMemberInfo {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats} + | CRContactSwitchStarted {user :: User, contact :: Contact, connectionStats :: ConnectionStats} + | CRGroupMemberSwitchStarted {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats :: ConnectionStats} | CRContactSwitchAborted {user :: User, contact :: Contact, connectionStats :: ConnectionStats} | CRGroupMemberSwitchAborted {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats :: ConnectionStats} | CRContactSwitch {user :: User, contact :: Contact, switchProgress :: SwitchProgress} diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index eb30fd14f3..33c0276cca 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -80,6 +80,8 @@ responseToView user_ ChatConfig {logLevel, showReactions, testView} liveItems ts CRNetworkConfig cfg -> viewNetworkConfig cfg CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile CRGroupMemberInfo u g m cStats -> ttyUser u $ viewGroupMemberInfo g m cStats + CRContactSwitchStarted {} -> ["switch started"] + CRGroupMemberSwitchStarted {} -> ["switch started"] CRContactSwitchAborted {} -> ["switch aborted"] CRGroupMemberSwitchAborted {} -> ["switch aborted"] CRContactSwitch u ct progress -> ttyUser u $ viewContactSwitch ct progress diff --git a/stack.yaml b/stack.yaml index 228a1c698f..b598669295 100644 --- a/stack.yaml +++ b/stack.yaml @@ -49,7 +49,7 @@ extra-deps: # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - ../simplexmq - github: simplex-chat/simplexmq - commit: 2efe1496d2622a56656a6a00a2cc19005e754468 + commit: c31668ce286380ed6cf6829f1fa0b246cd52d828 - github: kazu-yamamoto/http2 commit: b5a1b7200cf5bc7044af34ba325284271f6dff25 # - ../direct-sqlcipher diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 63882ee20d..0fee08f79a 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -1838,7 +1838,7 @@ testSwitchContact = testChat2 aliceProfile bobProfile $ \alice bob -> do connectUsers alice bob - alice #$> ("/switch bob", id, "ok") + alice #$> ("/switch bob", id, "switch started") bob <## "alice started changing address for you" alice <## "bob: you started changing address" bob <## "alice changed address for you" @@ -1852,7 +1852,7 @@ testAbortSwitchContact tmp = do withNewTestChat tmp "alice" aliceProfile $ \alice -> do withNewTestChat tmp "bob" bobProfile $ \bob -> do connectUsers alice bob - alice #$> ("/switch bob", id, "ok") + alice #$> ("/switch bob", id, "switch started") alice <## "bob: you started changing address" -- repeat switch is prohibited alice ##> "/switch bob" @@ -1865,7 +1865,7 @@ testAbortSwitchContact tmp = do withTestChatContactConnected tmp "bob" $ \bob -> do bob <## "alice started changing address for you" -- alice changes address again - alice #$> ("/switch bob", id, "ok") + alice #$> ("/switch bob", id, "switch started") alice <## "bob: you started changing address" bob <## "alice started changing address for you" bob <## "alice changed address for you" @@ -1879,7 +1879,7 @@ testSwitchGroupMember = testChat2 aliceProfile bobProfile $ \alice bob -> do createGroup2 "team" alice bob - alice #$> ("/switch #team bob", id, "ok") + alice #$> ("/switch #team bob", id, "switch started") bob <## "#team: alice started changing address for you" alice <## "#team: you started changing address for bob" bob <## "#team: alice changed address for you" @@ -1896,7 +1896,7 @@ testAbortSwitchGroupMember tmp = do withNewTestChat tmp "alice" aliceProfile $ \alice -> do withNewTestChat tmp "bob" bobProfile $ \bob -> do createGroup2 "team" alice bob - alice #$> ("/switch #team bob", id, "ok") + alice #$> ("/switch #team bob", id, "switch started") alice <## "#team: you started changing address for bob" -- repeat switch is prohibited alice ##> "/switch #team bob" @@ -1910,7 +1910,7 @@ testAbortSwitchGroupMember tmp = do bob <## "#team: connected to server(s)" bob <## "#team: alice started changing address for you" -- alice changes address again - alice #$> ("/switch #team bob", id, "ok") + alice #$> ("/switch #team bob", id, "switch started") alice <## "#team: you started changing address for bob" bob <## "#team: alice started changing address for you" bob <## "#team: alice changed address for you"