lovely-projects/simplex-chat
lovely-projects/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-03-14 09:45:42 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

Merge branch 'master' into remote-desktop

Browse source
This commit is contained in:
Evgeny Poberezkin 2023-10-12 10:43:59 +01:00
commit 73652e4bba
51 changed files with 1652 additions and 529 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
.github/workflows/build.yml vendored
View file

@ -293,4 +293,37 @@ jobs:
body: |
${{ steps.windows_build.outputs.bin_hash }}
- name: Windows build desktop
id: windows_desktop_build
if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'windows-latest'
env:
SIMPLEX_CI_REPO_URL: ${{ secrets.SIMPLEX_CI_REPO_URL }}
shell: bash
run: |
scripts/desktop/build-lib-windows.sh
cd apps/multiplatform
./gradlew packageMsi
path=$(echo $PWD/release/main/msi/*imple*.msi | sed 's#/\([a-z]\)#\1:#' | sed 's#/#\\#g')
echo "package_path=$path" >> $GITHUB_OUTPUT
echo "package_hash=$(echo SHA2-512\(${{ matrix.desktop_asset_name }}\)= $(openssl sha512 $path | cut -d' ' -f 2))" >> $GITHUB_OUTPUT
- name: Windows upload desktop package to release
if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'windows-latest'
uses: svenstaro/upload-release-action@v2
with:
repo_token: ${{ secrets.GITHUB_TOKEN }}
file: ${{ steps.windows_desktop_build.outputs.package_path }}
asset_name: ${{ matrix.desktop_asset_name }}
tag: ${{ github.ref }}
- name: Windows update desktop package hash
if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'windows-latest'
uses: softprops/action-gh-release@v1
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
with:
append_body: true
body: |
${{ steps.windows_desktop_build.outputs.package_hash }}
# Windows /

28
apps/ios/Shared/Model/SuspendChat.swift
View file

@ -19,7 +19,11 @@ let bgSuspendTimeout: Int = 5 // seconds
let terminationTimeout: Int = 3 // seconds
private func _suspendChat(timeout: Int) {
if ChatModel.ok {
// this is a redundant check to prevent logical errors, like the one fixed in this PR
let state = appStateGroupDefault.get()
if !state.canSuspend {
logger.error("_suspendChat called, current state: \(state.rawValue, privacy: .public)")
} else if ChatModel.ok {
appStateGroupDefault.set(.suspending)
apiSuspendChat(timeoutMicroseconds: timeout * 1000000)
let endTask = beginBGTask(chatSuspended)
@ -31,9 +35,7 @@ private func _suspendChat(timeout: Int) {
func suspendChat() {
suspendLockQueue.sync {
if appStateGroupDefault.get() != .stopped {
_suspendChat(timeout: appSuspendTimeout)
}
_suspendChat(timeout: appSuspendTimeout)
}
}
@ -45,15 +47,25 @@ func suspendBgRefresh() {
}
}
private var terminating = false
func terminateChat() {
logger.debug("terminateChat")
suspendLockQueue.sync {
switch appStateGroupDefault.get() {
case .suspending:
// suspend instantly if already suspending
_chatSuspended()
// when apiSuspendChat is called with timeout 0, it won't send any events on suspension
if ChatModel.ok { apiSuspendChat(timeoutMicroseconds: 0) }
case .stopped: ()
chatCloseStore()
case .suspended:
chatCloseStore()
case .stopped:
chatCloseStore()
default:
terminating = true
// the store will be closed in _chatSuspended when event is received
_suspendChat(timeout: terminationTimeout)
}
}
@ -73,10 +85,14 @@ private func _chatSuspended() {
if ChatModel.shared.chatRunning == true {
ChatReceiver.shared.stop()
}
if terminating {
chatCloseStore()
}
}
func activateChat(appState: AppState = .active) {
logger.debug("DEBUGGING: activateChat")
terminating = false
suspendLockQueue.sync {
appStateGroupDefault.set(appState)
if ChatModel.ok { apiActivateChat() }
@ -85,6 +101,7 @@ func activateChat(appState: AppState = .active) {
}
func initChatAndMigrate(refreshInvitations: Bool = true) {
terminating = false
let m = ChatModel.shared
if (!m.chatInitialized) {
do {
@ -97,6 +114,7 @@ func initChatAndMigrate(refreshInvitations: Bool = true) {
}
func startChatAndActivate() {
terminating = false
logger.debug("DEBUGGING: startChatAndActivate")
if ChatModel.shared.chatRunning == true {
ChatReceiver.shared.start()

2
apps/ios/Shared/Views/Chat/ChatView.swift
View file

@ -965,7 +965,7 @@ struct ChatView: View {
func toggleNotifications(_ chat: Chat, enableNtfs: Bool) {
var chatSettings = chat.chatInfo.chatSettings ?? ChatSettings.defaults
chatSettings.enableNtfs = enableNtfs
chatSettings.enableNtfs = enableNtfs ? .all : .none
updateChatSettings(chat, chatSettings: chatSettings)
}

40
apps/ios/SimpleX.xcodeproj/project.pbxproj
View file

@ -85,6 +85,11 @@
5CA059ED279559F40002BEB4 /* ContentView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059C4279559F40002BEB4 /* ContentView.swift */; };
5CA059EF279559F40002BEB4 /* Assets.xcassets in Resources */ = {isa = PBXBuildFile; fileRef = 5CA059C5279559F40002BEB4 /* Assets.xcassets */; };
5CA7DFC329302AF000F7FDDE /* AppSheet.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA7DFC229302AF000F7FDDE /* AppSheet.swift */; };
5CA8D0162AD746C8001FD661 /* libgmpxx.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5CA8D0112AD746C8001FD661 /* libgmpxx.a */; };
5CA8D0172AD746C8001FD661 /* libffi.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5CA8D0122AD746C8001FD661 /* libffi.a */; };
5CA8D0182AD746C8001FD661 /* libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5CA8D0132AD746C8001FD661 /* libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b.a */; };
5CA8D0192AD746C8001FD661 /* libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b-ghc8.10.7.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5CA8D0142AD746C8001FD661 /* libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b-ghc8.10.7.a */; };
5CA8D01A2AD746C8001FD661 /* libgmp.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5CA8D0152AD746C8001FD661 /* libgmp.a */; };
5CADE79A29211BB900072E13 /* PreferencesView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CADE79929211BB900072E13 /* PreferencesView.swift */; };
5CADE79C292131E900072E13 /* ContactPreferencesView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CADE79B292131E900072E13 /* ContactPreferencesView.swift */; };
5CB0BA882826CB3A00B3292C /* InfoPlist.strings in Resources */ = {isa = PBXBuildFile; fileRef = 5CB0BA862826CB3A00B3292C /* InfoPlist.strings */; };
@ -114,11 +119,6 @@
5CC1C99527A6CF7F000D9FF6 /* ShareSheet.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CC1C99427A6CF7F000D9FF6 /* ShareSheet.swift */; };
5CC2C0FC2809BF11000C35E3 /* Localizable.strings in Resources */ = {isa = PBXBuildFile; fileRef = 5CC2C0FA2809BF11000C35E3 /* Localizable.strings */; };
5CC2C0FF2809BF11000C35E3 /* SimpleX--iOS--InfoPlist.strings in Resources */ = {isa = PBXBuildFile; fileRef = 5CC2C0FD2809BF11000C35E3 /* SimpleX--iOS--InfoPlist.strings */; };
5CC739972AD44E2E009470A9 /* libgmp.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5CC739922AD44E2E009470A9 /* libgmp.a */; };
5CC739982AD44E2E009470A9 /* libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F-ghc8.10.7.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5CC739932AD44E2E009470A9 /* libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F-ghc8.10.7.a */; };
5CC739992AD44E2E009470A9 /* libffi.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5CC739942AD44E2E009470A9 /* libffi.a */; };
5CC7399A2AD44E2E009470A9 /* libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5CC739952AD44E2E009470A9 /* libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F.a */; };
5CC7399B2AD44E2E009470A9 /* libgmpxx.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5CC739962AD44E2E009470A9 /* libgmpxx.a */; };
5CC868F329EB540C0017BBFD /* CIRcvDecryptionError.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CC868F229EB540C0017BBFD /* CIRcvDecryptionError.swift */; };
5CCB939C297EFCB100399E78 /* NavStackCompat.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CCB939B297EFCB100399E78 /* NavStackCompat.swift */; };
5CCD403427A5F6DF00368C90 /* AddContactView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CCD403327A5F6DF00368C90 /* AddContactView.swift */; };
@ -358,6 +358,11 @@
5CA85D0A297218AA0095AF72 /* it */ = {isa = PBXFileReference; lastKnownFileType = text.plist.strings; name = it; path = it.lproj/Localizable.strings; sourceTree = "<group>"; };
5CA85D0C297219EF0095AF72 /* it */ = {isa = PBXFileReference; lastKnownFileType = text.plist.strings; name = it; path = "it.lproj/SimpleX--iOS--InfoPlist.strings"; sourceTree = "<group>"; };
5CA85D0D297219EF0095AF72 /* it */ = {isa = PBXFileReference; lastKnownFileType = text.plist.strings; name = it; path = it.lproj/InfoPlist.strings; sourceTree = "<group>"; };
5CA8D0112AD746C8001FD661 /* libgmpxx.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmpxx.a; sourceTree = "<group>"; };
5CA8D0122AD746C8001FD661 /* libffi.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libffi.a; sourceTree = "<group>"; };
5CA8D0132AD746C8001FD661 /* libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b.a"; sourceTree = "<group>"; };
5CA8D0142AD746C8001FD661 /* libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b-ghc8.10.7.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b-ghc8.10.7.a"; sourceTree = "<group>"; };
5CA8D0152AD746C8001FD661 /* libgmp.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmp.a; sourceTree = "<group>"; };
5CAB912529E93F9400F34A95 /* pl */ = {isa = PBXFileReference; lastKnownFileType = text.plist.strings; name = pl; path = pl.lproj/Localizable.strings; sourceTree = "<group>"; };
5CAC41182A192D8400C331A2 /* ja */ = {isa = PBXFileReference; lastKnownFileType = text.plist.strings; name = ja; path = ja.lproj/Localizable.strings; sourceTree = "<group>"; };
5CAC411A2A192DE800C331A2 /* ja */ = {isa = PBXFileReference; lastKnownFileType = text.plist.strings; name = ja; path = "ja.lproj/SimpleX--iOS--InfoPlist.strings"; sourceTree = "<group>"; };
@ -395,11 +400,6 @@
5CC1C99427A6CF7F000D9FF6 /* ShareSheet.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = ShareSheet.swift; sourceTree = "<group>"; };
5CC2C0FB2809BF11000C35E3 /* ru */ = {isa = PBXFileReference; lastKnownFileType = text.plist.strings; name = ru; path = ru.lproj/Localizable.strings; sourceTree = "<group>"; };
5CC2C0FE2809BF11000C35E3 /* ru */ = {isa = PBXFileReference; lastKnownFileType = text.plist.strings; name = ru; path = "ru.lproj/SimpleX--iOS--InfoPlist.strings"; sourceTree = "<group>"; };
5CC739922AD44E2E009470A9 /* libgmp.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmp.a; sourceTree = "<group>"; };
5CC739932AD44E2E009470A9 /* libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F-ghc8.10.7.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F-ghc8.10.7.a"; sourceTree = "<group>"; };
5CC739942AD44E2E009470A9 /* libffi.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libffi.a; sourceTree = "<group>"; };
5CC739952AD44E2E009470A9 /* libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F.a"; sourceTree = "<group>"; };
5CC739962AD44E2E009470A9 /* libgmpxx.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmpxx.a; sourceTree = "<group>"; };
5CC868F229EB540C0017BBFD /* CIRcvDecryptionError.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = CIRcvDecryptionError.swift; sourceTree = "<group>"; };
5CCB939B297EFCB100399E78 /* NavStackCompat.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = NavStackCompat.swift; sourceTree = "<group>"; };
5CCD403327A5F6DF00368C90 /* AddContactView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = AddContactView.swift; sourceTree = "<group>"; };
@ -507,13 +507,13 @@
isa = PBXFrameworksBuildPhase;
buildActionMask = 2147483647;
files = (
5CC739982AD44E2E009470A9 /* libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F-ghc8.10.7.a in Frameworks */,
5CA8D0162AD746C8001FD661 /* libgmpxx.a in Frameworks */,
5CA8D01A2AD746C8001FD661 /* libgmp.a in Frameworks */,
5CA8D0182AD746C8001FD661 /* libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b.a in Frameworks */,
5CA8D0192AD746C8001FD661 /* libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b-ghc8.10.7.a in Frameworks */,
5CE2BA93284534B000EC33A6 /* libiconv.tbd in Frameworks */,
5CC739972AD44E2E009470A9 /* libgmp.a in Frameworks */,
5CC7399A2AD44E2E009470A9 /* libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F.a in Frameworks */,
5CC739992AD44E2E009470A9 /* libffi.a in Frameworks */,
5CE2BA94284534BB00EC33A6 /* libz.tbd in Frameworks */,
5CC7399B2AD44E2E009470A9 /* libgmpxx.a in Frameworks */,
5CA8D0172AD746C8001FD661 /* libffi.a in Frameworks */,
);
runOnlyForDeploymentPostprocessing = 0;
};
@ -574,11 +574,11 @@
5C764E5C279C70B7000C6508 /* Libraries */ = {
isa = PBXGroup;
children = (
5CC739942AD44E2E009470A9 /* libffi.a */,
5CC739922AD44E2E009470A9 /* libgmp.a */,
5CC739962AD44E2E009470A9 /* libgmpxx.a */,
5CC739932AD44E2E009470A9 /* libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F-ghc8.10.7.a */,
5CC739952AD44E2E009470A9 /* libHSsimplex-chat-5.4.0.0-JjDpmMNHLrsHjXbdowMF4F.a */,
5CA8D0122AD746C8001FD661 /* libffi.a */,
5CA8D0152AD746C8001FD661 /* libgmp.a */,
5CA8D0112AD746C8001FD661 /* libgmpxx.a */,
5CA8D0142AD746C8001FD661 /* libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b-ghc8.10.7.a */,
5CA8D0132AD746C8001FD661 /* libHSsimplex-chat-5.4.0.1-7lTZkX9ojv2DbehL2eOY1b.a */,
);
path = Libraries;
sourceTree = "<group>";

7
apps/ios/SimpleXChat/API.swift
View file

@ -50,6 +50,13 @@ public func chatMigrateInit(_ useKey: String? = nil, confirmMigrations: Migratio
return result
}
public func chatCloseStore() {
let err = fromCString(chat_close_store(getChatCtrl()))
if err != "" {
logger.error("chatCloseStore error: \(err)")
}
}
public func resetChatCtrl() {
chatController = nil
migrationResult = nil

12
apps/ios/SimpleXChat/APITypes.swift
View file

@ -1182,17 +1182,23 @@ public struct KeepAliveOpts: Codable, Equatable {
}
public struct ChatSettings: Codable {
public var enableNtfs: Bool
public var enableNtfs: MsgFilter
public var sendRcpts: Bool?
public var favorite: Bool
public init(enableNtfs: Bool, sendRcpts: Bool?, favorite: Bool) {
public init(enableNtfs: MsgFilter, sendRcpts: Bool?, favorite: Bool) {
self.enableNtfs = enableNtfs
self.sendRcpts = sendRcpts
self.favorite = favorite
}
public static let defaults: ChatSettings = ChatSettings(enableNtfs: true, sendRcpts: nil, favorite: false)
public static let defaults: ChatSettings = ChatSettings(enableNtfs: .all, sendRcpts: nil, favorite: false)
}
public enum MsgFilter: String, Codable {
case none
case all
case mentions
}
public struct UserMsgReceiptSettings: Codable {

8
apps/ios/SimpleXChat/AppGroup.swift
View file

@ -80,6 +80,14 @@ public enum AppState: String {
default: return false
}
}
public var canSuspend: Bool {
switch self {
case .active: true
case .bgRefresh: true
default: false
}
}
}
public enum DBContainer: String {

12
apps/ios/SimpleXChat/ChatTypes.swift
View file

@ -1292,7 +1292,7 @@ public enum ChatInfo: Identifiable, Decodable, NamedChat {
}
public var ntfsEnabled: Bool {
self.chatSettings?.enableNtfs ?? false
self.chatSettings?.enableNtfs == .all
}
public var chatSettings: ChatSettings? {
@ -1758,6 +1758,7 @@ public struct GroupMember: Identifiable, Decodable {
public var memberRole: GroupMemberRole
public var memberCategory: GroupMemberCategory
public var memberStatus: GroupMemberStatus
public var memberSettings: GroupMemberSettings
public var invitedBy: InvitedBy
public var localDisplayName: ContactName
public var memberProfile: LocalProfile
@ -1851,6 +1852,7 @@ public struct GroupMember: Identifiable, Decodable {
memberRole: .admin,
memberCategory: .inviteeMember,
memberStatus: .memComplete,
memberSettings: GroupMemberSettings(showMessages: true),
invitedBy: .user,
localDisplayName: "alice",
memberProfile: LocalProfile.sampleData,
@ -1860,6 +1862,10 @@ public struct GroupMember: Identifiable, Decodable {
)
}
public struct GroupMemberSettings: Decodable {
var showMessages: Bool
}
public struct GroupMemberRef: Decodable {
var groupMemberId: Int64
var profile: Profile
@ -1983,8 +1989,8 @@ public enum ConnectionEntity: Decodable {
public var ntfsEnabled: Bool {
switch self {
case let .rcvDirectMsgConnection(contact): return contact?.chatSettings.enableNtfs ?? false
case let .rcvGroupMsgConnection(groupInfo, _): return groupInfo.chatSettings.enableNtfs
case let .rcvDirectMsgConnection(contact): return contact?.chatSettings.enableNtfs == .all
case let .rcvGroupMsgConnection(groupInfo, _): return groupInfo.chatSettings.enableNtfs == .all
case .sndFileConnection: return false
case .rcvFileConnection: return false
case let .userContactConnection(userContact): return userContact.groupId == nil

1
apps/ios/SimpleXChat/SimpleX.h
View file

@ -17,6 +17,7 @@ typedef void* chat_ctrl;
// the last parameter is used to return the pointer to chat controller
extern char *chat_migrate_init(char *path, char *key, char *confirm, chat_ctrl *ctrl);
extern char *chat_close_store(chat_ctrl ctl);
extern char *chat_send_cmd(chat_ctrl ctl, char *cmd);
extern char *chat_recv_msg(chat_ctrl ctl);
extern char *chat_recv_msg_wait(chat_ctrl ctl, int wait);

17
apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt
View file

@ -12,7 +12,6 @@ import chat.simplex.common.ui.theme.*
import chat.simplex.common.views.call.*
import chat.simplex.common.views.chat.ComposeState
import chat.simplex.common.views.helpers.*
import chat.simplex.common.views.onboarding.OnboardingStage
import chat.simplex.res.MR
import dev.icerock.moko.resources.ImageResource
import dev.icerock.moko.resources.StringResource
@ -726,7 +725,7 @@ sealed class ChatInfo: SomeChat, NamedChat {
override val apiId get() = contactConnection.apiId
override val ready get() = contactConnection.ready
override val sendMsgEnabled get() = contactConnection.sendMsgEnabled
override val ntfsEnabled get() = contactConnection.incognito
override val ntfsEnabled get() = false
override val incognito get() = contactConnection.incognito
override fun featureEnabled(feature: ChatFeature) = contactConnection.featureEnabled(feature)
override val timedMessagesTTL: Int? get() = contactConnection.timedMessagesTTL
@ -822,7 +821,7 @@ data class Contact(
(ready && active && !(activeConn.connectionStats?.ratchetSyncSendProhibited ?: false))
|| nextSendGrpInv
val nextSendGrpInv get() = contactGroupMemberId != null && !contactGrpInvSent
override val ntfsEnabled get() = chatSettings.enableNtfs
override val ntfsEnabled get() = chatSettings.enableNtfs == MsgFilter.All
override val incognito get() = contactConnIncognito
override fun featureEnabled(feature: ChatFeature) = when (feature) {
ChatFeature.TimedMessages -> mergedPreferences.timedMessages.enabled.forUser
@ -869,7 +868,7 @@ data class Contact(
activeConn = Connection.sampleData,
contactUsed = true,
contactStatus = ContactStatus.Active,
chatSettings = ChatSettings(enableNtfs = true, sendRcpts = null, favorite = false),
chatSettings = ChatSettings(enableNtfs = MsgFilter.All, sendRcpts = null, favorite = false),
userPreferences = ChatPreferences.sampleData,
mergedPreferences = ContactUserPreferences.sampleData,
createdAt = Clock.System.now(),
@ -1009,7 +1008,7 @@ data class GroupInfo (
override val apiId get() = groupId
override val ready get() = membership.memberActive
override val sendMsgEnabled get() = membership.memberActive
override val ntfsEnabled get() = chatSettings.enableNtfs
override val ntfsEnabled get() = chatSettings.enableNtfs == MsgFilter.All
override val incognito get() = membership.memberIncognito
override fun featureEnabled(feature: ChatFeature) = when (feature) {
ChatFeature.TimedMessages -> fullGroupPreferences.timedMessages.on
@ -1041,7 +1040,7 @@ data class GroupInfo (
fullGroupPreferences = FullGroupPreferences.sampleData,
membership = GroupMember.sampleData,
hostConnCustomUserProfileId = null,
chatSettings = ChatSettings(enableNtfs = true, sendRcpts = null, favorite = false),
chatSettings = ChatSettings(enableNtfs = MsgFilter.All, sendRcpts = null, favorite = false),
createdAt = Clock.System.now(),
updatedAt = Clock.System.now()
)
@ -1073,6 +1072,7 @@ data class GroupMember (
var memberRole: GroupMemberRole,
var memberCategory: GroupMemberCategory,
var memberStatus: GroupMemberStatus,
var memberSettings: GroupMemberSettings,
var invitedBy: InvitedBy,
val localDisplayName: String,
val memberProfile: LocalProfile,
@ -1140,6 +1140,7 @@ data class GroupMember (
memberRole = GroupMemberRole.Member,
memberCategory = GroupMemberCategory.InviteeMember,
memberStatus = GroupMemberStatus.MemComplete,
memberSettings = GroupMemberSettings(showMessages = true),
invitedBy = InvitedBy.IBUser(),
localDisplayName = "alice",
memberProfile = LocalProfile.sampleData,
@ -1150,6 +1151,9 @@ data class GroupMember (
}
}
@Serializable
data class GroupMemberSettings(val showMessages: Boolean) {}
@Serializable
class GroupMemberRef(
val groupMemberId: Long,
@ -1844,6 +1848,7 @@ enum class SndCIStatusProgress {
@Serializable
sealed class CIDeleted {
@Serializable @SerialName("deleted") class Deleted(val deletedTs: Instant?): CIDeleted()
@Serializable @SerialName("blocked") class Blocked(val deletedTs: Instant?): CIDeleted()
@Serializable @SerialName("moderated") class Moderated(val deletedTs: Instant?, val byGroupMember: GroupMember): CIDeleted()
}

11
apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt
View file

@ -2472,15 +2472,22 @@ data class KeepAliveOpts(
@Serializable
data class ChatSettings(
val enableNtfs: Boolean,
val enableNtfs: MsgFilter,
val sendRcpts: Boolean?,
val favorite: Boolean
) {
companion object {
val defaults: ChatSettings = ChatSettings(enableNtfs = true, sendRcpts = null, favorite = false)
val defaults: ChatSettings = ChatSettings(enableNtfs = MsgFilter.All, sendRcpts = null, favorite = false)
}
}
@Serializable
enum class MsgFilter {
@SerialName("all") All,
@SerialName("none") None,
@SerialName("mentions") Mentions,
}
@Serializable
data class UserMsgReceiptSettings(val enable: Boolean, val clearOverrides: Boolean)

6
apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chatlist/ChatListNavLinkView.kt
View file

@ -595,8 +595,8 @@ fun groupInvitationAcceptedAlert() {
)
}
fun toggleNotifications(chat: Chat, enableNtfs: Boolean, chatModel: ChatModel, currentState: MutableState<Boolean>? = null) {
val chatSettings = (chat.chatInfo.chatSettings ?: ChatSettings.defaults).copy(enableNtfs = enableNtfs)
fun toggleNotifications(chat: Chat, enableAllNtfs: Boolean, chatModel: ChatModel, currentState: MutableState<Boolean>? = null) {
val chatSettings = (chat.chatInfo.chatSettings ?: ChatSettings.defaults).copy(enableNtfs = if (enableAllNtfs) MsgFilter.All else MsgFilter.None)
updateChatSettings(chat, chatSettings, chatModel, currentState)
}
@ -627,7 +627,7 @@ fun updateChatSettings(chat: Chat, chatSettings: ChatSettings, chatModel: ChatMo
}
if (res && newChatInfo != null) {
chatModel.updateChatInfo(newChatInfo)
if (!chatSettings.enableNtfs) {
if (chatSettings.enableNtfs != MsgFilter.All) {
ntfManager.cancelNotificationsForChat(chat.id)
}
val current = currentState?.value

2
apps/simplex-bot-advanced/Main.hs
View file

@ -24,7 +24,7 @@ import Text.Read
main :: IO ()
main = do
opts <- welcomeGetOpts
simplexChatCore terminalChatConfig opts Nothing mySquaringBot
simplexChatCore terminalChatConfig opts mySquaringBot
welcomeGetOpts :: IO ChatOpts
welcomeGetOpts = do

2
apps/simplex-bot/Main.hs
View file

@ -13,7 +13,7 @@ import Text.Read
main :: IO ()
main = do
opts <- welcomeGetOpts
simplexChatCore terminalChatConfig opts Nothing $
simplexChatCore terminalChatConfig opts $
chatBotRepl welcomeMessage $ \_contact msg ->
pure $ case readMaybe msg :: Maybe Integer of
Just n -> msg <> " * " <> msg <> " = " <> show (n * n)

2
apps/simplex-broadcast-bot/Main.hs
View file

@ -8,4 +8,4 @@ import Simplex.Chat.Terminal (terminalChatConfig)
main :: IO ()
main = do
opts <- welcomeGetOpts
simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ broadcastBot opts
simplexChatCore terminalChatConfig (mkChatOpts opts) $ broadcastBot opts

2
apps/simplex-chat/Main.hs
View file

@ -28,7 +28,7 @@ main = do
welcome opts
t <- withTerminal pure
simplexChatTerminal terminalChatConfig opts t
else simplexChatCore terminalChatConfig opts Nothing $ \user cc -> do
else simplexChatCore terminalChatConfig opts $ \user cc -> do
rh <- readTVarIO $ currentRemoteHost cc
let cmdRH = rh -- response RemoteHost is the same as for the command itself
r <- sendChatCmdStr cc chatCmd

2
apps/simplex-chat/Server.hs
View file

@ -30,7 +30,7 @@ import UnliftIO.STM
simplexChatServer :: ChatServerConfig -> ChatConfig -> ChatOpts -> IO ()
simplexChatServer srvCfg cfg opts =
simplexChatCore cfg opts Nothing . const $ runChatServer srvCfg
simplexChatCore cfg opts . const $ runChatServer srvCfg
data ChatServerConfig = ChatServerConfig
{ chatPort :: ServiceName,

2
apps/simplex-directory-service/Main.hs
View file

@ -12,4 +12,4 @@ main :: IO ()
main = do
opts@DirectoryOpts {directoryLog} <- welcomeGetOpts
st <- restoreDirectoryStore directoryLog
simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ directoryService st opts
simplexChatCore terminalChatConfig (mkChatOpts opts) $ directoryService st opts

2
package.yaml
View file

@ -1,5 +1,5 @@
name: simplex-chat
version: 5.4.0.0
version: 5.4.0.1
#synopsis:
#description:
homepage: https://github.com/simplex-chat/simplex-chat#readme

6
simplex-chat.cabal
View file

@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplex-chat
version: 5.4.0.0
version: 5.4.0.1
category: Web, System, Services, Cryptography
homepage: https://github.com/simplex-chat/simplex-chat#readme
author: simplex.chat
@ -115,7 +115,9 @@ library
Simplex.Chat.Migrations.M20230914_member_probes
Simplex.Chat.Migrations.M20230926_contact_status
Simplex.Chat.Migrations.M20231002_conn_initiated
Simplex.Chat.Migrations.M20231005_remote_controller
Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash
Simplex.Chat.Migrations.M20231010_member_settings
Simplex.Chat.Migrations.M20231020_remote_controller
Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared

415
src/Simplex/Chat.hs
View file

@ -185,13 +185,11 @@ createChatDatabase filePrefix key confirmMigrations = runExceptT $ do
agentStore <- ExceptT $ createAgentStore (agentStoreFile filePrefix) key confirmMigrations
pure ChatDatabase {chatStore, agentStore}
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> IO ChatController
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} sendToast = do
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> IO ChatController
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} = do
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize}
sendNotification = fromMaybe (const $ pure ()) sendToast
firstTime = dbNew chatStore
activeTo <- newTVarIO ActiveNone
currentUser <- newTVarIO user
currentRemoteHost <- newTVarIO Nothing
servers <- agentServers config
@ -200,7 +198,6 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
idsDrg <- newTVarIO =<< liftIO drgNew
inputQ <- newTBQueueIO tbqSize
outputQ <- newTBQueueIO tbqSize
notifyQ <- newTBQueueIO tbqSize
subscriptionMode <- newTVarIO SMSubscribe
chatLock <- newEmptyTMVarIO
sndFiles <- newTVarIO M.empty
@ -218,7 +215,38 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg
tempDirectory <- newTVarIO tempDir
contactMergeEnabled <- newTVarIO True
pure ChatController {activeTo, firstTime, currentUser, currentRemoteHost, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, remoteHostSessions, remoteCtrlSession, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile, contactMergeEnabled}
pure
ChatController
{
firstTime,
currentUser,
currentRemoteHost,
smpAgent,
agentAsync,
chatStore,
chatStoreChanged,
idsDrg,
inputQ,
outputQ,
subscriptionMode,
chatLock,
sndFiles,
rcvFiles,
currentCalls,
remoteHostSessions,
remoteCtrlSession,
config,
filesFolder,
expireCIThreads,
expireCIFlags,
cleanupManagerAsync,
timedItemThreads,
showLiveItems,
userXFTPFileConfig,
tempDirectory,
logFilePath = logFile,
contactMergeEnabled
}
where
configServers :: DefaultAgentServers
configServers =
@ -265,7 +293,7 @@ startChatController subConns enableExpireCIs startXFTPWorkers = do
readTVarIO s >>= maybe (start s users) (pure . fst)
where
start s users = do
a1 <- async $ race_ notificationSubscriber agentSubscriber
a1 <- async agentSubscriber
a2 <-
if subConns
then Just <$> async (subscribeUsers False users)
@ -389,7 +417,6 @@ processChatCommand = \case
user <- withStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts
storeServers user smpServers
storeServers user xftpServers
setActive ActiveNone
atomically . writeTVar u $ Just user
pure $ CRActiveUser user
where
@ -415,7 +442,6 @@ processChatCommand = \case
user' <- privateGetUser userId'
validateUserPassword user user' viewPwd_
withStoreCtx' (Just "APISetActiveUser, setActiveUser") $ \db -> setActiveUser db userId'
setActive ActiveNone
let user'' = user' {activeUser = True}
asks currentUser >>= atomically . (`writeTVar` Just user'')
pure $ CRActiveUser user''
@ -473,11 +499,11 @@ processChatCommand = \case
DeleteUser uName delSMPQueues viewPwd_ -> withUserName uName $ \userId -> APIDeleteUser userId delSMPQueues viewPwd_
StartChat subConns enableExpireCIs startXFTPWorkers -> withUser' $ \_ ->
asks agentAsync >>= readTVarIO >>= \case
Just _ -> pure $ CRChatRunning Nothing
_ -> checkStoreNotChanged $ startChatController subConns enableExpireCIs startXFTPWorkers $> CRChatStarted Nothing
Just _ -> pure CRChatRunning
_ -> checkStoreNotChanged $ startChatController subConns enableExpireCIs startXFTPWorkers $> CRChatStarted
APIStopChat -> do
ask >>= stopChatController
pure $ CRChatStopped Nothing
pure CRChatStopped
APIActivateChat -> withUser $ \_ -> do
restoreCalls
withAgent foregroundAgent
@ -545,7 +571,7 @@ processChatCommand = \case
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIGetChatItems pagination search -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user pagination search
pure $ CRChatItems user chatItems
pure $ CRChatItems user Nothing chatItems
APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do
(aci@(AChatItem cType dir _ ci), versions) <- withStore $ \db ->
(,) <$> getAChatItem db user chatRef itemId <*> liftIO (getChatItemVersions db itemId)
@ -559,7 +585,7 @@ processChatCommand = \case
pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses}
APISendMessage (ChatRef cType chatId) live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of
CTDirect -> do
ct@Contact {contactId, localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
ct@Contact {contactId, contactUsed} <- withStore $ \db -> getContact db user chatId
assertDirectAllowed user MDSnd ct XMsgNew_
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
if isVoice mc && not (featureAllowed SCFVoice forUser ct)
@ -576,7 +602,6 @@ processChatCommand = \case
ci <- saveSndChatItem' user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
forM_ (timed_ >>= timedDeleteAt') $
startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci)
setActive $ ActiveC c
pure $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
where
setupSndFileTransfer :: Contact -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
@ -627,7 +652,7 @@ processChatCommand = \case
assertUserGroupRole gInfo GRAuthor
send g
where
send g@(Group gInfo@GroupInfo {groupId, membership, localDisplayName = gName} ms)
send g@(Group gInfo@GroupInfo {groupId, membership} ms)
| isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice
| not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles
| otherwise = do
@ -642,7 +667,6 @@ processChatCommand = \case
createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew
forM_ (timed_ >>= timedDeleteAt') $
startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci)
setActive $ ActiveG gName
pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f))
setupSndFileTransfer :: Group -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
@ -747,7 +771,7 @@ processChatCommand = \case
unzipMaybe3 _ = (Nothing, Nothing, Nothing)
APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> withChatLock "updateChatItem" $ case cType of
CTDirect -> do
(ct@Contact {contactId, localDisplayName = c}, cci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
(ct@Contact {contactId}, cci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
assertDirectAllowed user MDSnd ct XMsgUpdate_
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do
@ -763,13 +787,12 @@ processChatCommand = \case
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
updateDirectChatItem' db user contactId ci (CISndMsgContent mc) live $ Just msgId
startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci'
setActive $ ActiveC c
pure $ CRChatItemUpdated user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci')
else pure $ CRChatItemNotChanged user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
_ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
CTGroup -> do
Group gInfo@GroupInfo {groupId, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db user chatId
assertUserGroupRole gInfo GRAuthor
cci <- withStore $ \db -> getGroupChatItem db user chatId itemId
case cci of
@ -786,7 +809,6 @@ processChatCommand = \case
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
updateGroupChatItem db user groupId ci (CISndMsgContent mc) live $ Just msgId
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
setActive $ ActiveG gName
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci')
else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
_ -> throwChatError CEInvalidChatItemUpdate
@ -795,20 +817,19 @@ processChatCommand = \case
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> withChatLock "deleteChatItem" $ case cType of
CTDirect -> do
(ct@Contact {localDisplayName = c}, ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}})) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
(ct, CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}}) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
case (mode, msgDir, itemSharedMsgId, editable) of
(CIDMInternal, _, _, _) -> deleteDirectCI user ct ci True False
(CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do
assertDirectAllowed user MDSnd ct XMsgDel_
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId Nothing)
setActive $ ActiveC c
if featureAllowed SCFFullDelete forUser ct
then deleteDirectCI user ct ci True False
else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
CTGroup -> do
Group gInfo ms <- withStore $ \db -> getGroup db user chatId
ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}}) <- withStore $ \db -> getGroupChatItem db user chatId itemId
CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}} <- withStore $ \db -> getGroupChatItem db user chatId itemId
case (mode, msgDir, itemSharedMsgId, editable) of
(CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime
(CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do
@ -820,7 +841,7 @@ processChatCommand = \case
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do
Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db user gId
ci@(CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user gId itemId
CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withStore $ \db -> getGroupChatItem db user gId itemId
case (chatDir, itemSharedMsgId) of
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do
when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete
@ -911,11 +932,11 @@ processChatCommand = \case
_ -> pure $ chatCmdError (Just user) "not supported"
APIDeleteChat (ChatRef cType chatId) notify -> withUser $ \user@User {userId} -> case cType of
CTDirect -> do
ct@Contact {localDisplayName} <- withStore $ \db -> getContact db user chatId
ct <- withStore $ \db -> getContact db user chatId
filesInfo <- withStore' $ \db -> getContactFileInfo db user ct
withChatLock "deleteChat direct" . procCmd $ do
deleteFilesAndConns user filesInfo
when (isReady ct && contactActive ct && notify) $
when (contactReady ct && contactActive ct && notify) $
void (sendDirectContactMessage ct XDirectDel) `catchChatError` const (pure ())
contactConnIds <- map aConnId <$> withStore (\db -> getContactConnections db userId ct)
deleteAgentConnectionsAsync user contactConnIds
@ -923,7 +944,6 @@ processChatCommand = \case
-- (possibly, race condition on integrity check?)
withStore' $ \db -> deleteContactConnectionsAndFiles db userId ct
withStore' $ \db -> deleteContact db user ct
unsetActive $ ActiveC localDisplayName
pure $ CRContactDeleted user ct
CTContactConnection -> withChatLock "deleteChat contactConnection" . procCmd $ do
conn@PendingContactConnection {pccAgentConnId = AgentConnId acId} <- withStore $ \db -> getPendingContactConnection db userId chatId
@ -1175,7 +1195,7 @@ processChatCommand = \case
ct <- getContact db user chatId
liftIO $ updateContactSettings db user chatId chatSettings
pure ct
withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (enableNtfs chatSettings)
withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (chatHasNtfs chatSettings)
ok user
CTGroup -> do
ms <- withStore $ \db -> do
@ -1183,9 +1203,17 @@ processChatCommand = \case
liftIO $ updateGroupSettings db user chatId chatSettings
pure ms
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
withAgent (\a -> toggleConnectionNtfs a connId $ enableNtfs chatSettings) `catchChatError` (toView . CRChatError (Just user))
withAgent (\a -> toggleConnectionNtfs a connId $ chatHasNtfs chatSettings) `catchChatError` (toView . CRChatError (Just user))
ok user
_ -> pure $ chatCmdError (Just user) "not supported"
APISetMemberSettings gId gMemberId settings -> withUser $ \user -> do
m <- withStore $ \db -> do
liftIO $ updateGroupMemberSettings db user gId gMemberId settings
getGroupMember db user gId gMemberId
when (memberActive m) $ forM_ (memberConnId m) $ \connId -> do
let ntfOn = showMessages $ memberSettings m
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user))
ok user
APIContactInfo contactId -> withUser $ \user@User {userId} -> do
-- [incognito] print user's incognito profile for this contact
ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db user contactId
@ -1280,6 +1308,11 @@ processChatCommand = \case
_ -> throwChatError CEGroupMemberNotActive
SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn})
SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_})
SetShowMemberMessages gName mName showMessages -> withUser $ \user -> do
(gId, mId) <- getGroupAndMemberId user gName mName
m <- withStore $ \db -> getGroupMember db user gId mId
let settings = (memberSettings m) {showMessages}
processChatCommand $ APISetMemberSettings gId mId settings
ContactInfo cName -> withContactName cName APIContactInfo
ShowGroupInfo gName -> withUser $ \user -> do
groupId <- withStore $ \db -> getGroupIdByName db user gName
@ -1324,6 +1357,8 @@ processChatCommand = \case
case conn'_ of
Just conn' -> pure $ CRConnectionIncognitoUpdated user conn'
Nothing -> throwChatError CEConnectionIncognitoChangeProhibited
APIConnectPlan userId cReqUri -> withUserId userId $ \user -> withChatLock "connectPlan" . procCmd $
CRConnectionPlan user <$> connectPlan user cReqUri
APIConnect userId incognito (Just (ACR SCMInvitation cReq)) -> withUserId userId $ \user -> withChatLock "connect" . procCmd $ do
subMode <- chatReadVar subscriptionMode
-- [incognito] generate profile to send
@ -1336,11 +1371,16 @@ processChatCommand = \case
pure $ CRSentConfirmation user
APIConnect userId incognito (Just (ACR SCMContact cReq)) -> withUserId userId $ \user -> connectViaContact user incognito cReq
APIConnect _ _ Nothing -> throwChatError CEInvalidConnReq
Connect incognito cReqUri -> withUser $ \User {userId} ->
processChatCommand $ APIConnect userId incognito cReqUri
ConnectSimplex incognito -> withUser $ \user ->
-- [incognito] generate profile to send
connectViaContact user incognito adminContactReq
Connect incognito aCReqUri@(Just cReqUri) -> withUser $ \user@User {userId} -> do
plan <- connectPlan user cReqUri `catchChatError` const (pure $ CPInvitationLink ILPOk)
unless (connectionPlanOk plan) $ throwChatError (CEConnectionPlan plan)
processChatCommand $ APIConnect userId incognito aCReqUri
Connect _ Nothing -> throwChatError CEInvalidConnReq
ConnectSimplex incognito -> withUser $ \user@User {userId} -> do
let cReqUri = ACR SCMContact adminContactReq
plan <- connectPlan user cReqUri `catchChatError` const (pure $ CPInvitationLink ILPOk)
unless (connectionPlanOk plan) $ throwChatError (CEConnectionPlan plan)
processChatCommand $ APIConnect userId incognito (Just cReqUri)
DeleteContact cName -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId) True
ClearContact cName -> withContactName cName $ APIClearChat . ChatRef CTDirect
APIListContacts userId -> withUserId userId $ \user ->
@ -1436,7 +1476,7 @@ processChatCommand = \case
processChatCommand . APISendMessage chatRef True Nothing $ ComposedMessage Nothing Nothing mc
SendMessageBroadcast msg -> withUser $ \user -> do
contacts <- withStore' (`getUserContacts` user)
let cts = filter (\ct -> isReady ct && contactActive ct && directOrUsed ct) contacts
let cts = filter (\ct -> contactReady ct && contactActive ct && directOrUsed ct) contacts
ChatConfig {logLevel} <- asks config
withChatLock "sendMessageBroadcast" . procCmd $ do
(successes, failures) <- foldM (sendAndCount user logLevel) (0, 0) cts
@ -1704,11 +1744,10 @@ processChatCommand = \case
LastMessages (Just chatName) count search -> withUser $ \user -> do
chatRef <- getChatRef user chatName
chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search
setActive $ chatActiveTo chatName
pure $ CRChatItems user (aChatItems . chat $ chatResp)
pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp)
LastMessages Nothing count search -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast count) search
pure $ CRChatItems user chatItems
pure $ CRChatItems user Nothing chatItems
LastChatItemId (Just chatName) index -> withUser $ \user -> do
chatRef <- getChatRef user chatName
chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing)
@ -1720,10 +1759,10 @@ processChatCommand = \case
chatItem <- withStore $ \db -> do
chatRef <- getChatRefViaItemId db user itemId
getAChatItem db user chatRef itemId
pure $ CRChatItems user ((: []) chatItem)
pure $ CRChatItems user Nothing ((: []) chatItem)
ShowChatItem Nothing -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast 1) Nothing
pure $ CRChatItems user chatItems
pure $ CRChatItems user Nothing chatItems
ShowChatItemInfo chatName msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName
itemId <- getChatItemIdByText user chatRef msg
@ -1949,19 +1988,36 @@ processChatCommand = \case
_ -> throwChatError $ CECommandError "not supported"
connectViaContact :: User -> IncognitoEnabled -> ConnectionRequestUri 'CMContact -> m ChatResponse
connectViaContact user@User {userId} incognito cReq@(CRContactUri ConnReqUriData {crClientData}) = withChatLock "connectViaContact" $ do
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
withStore' (\db -> getConnReqContactXContactId db user cReqHash) >>= \case
(Just contact, _) -> pure $ CRContactAlreadyExists user contact
(_, xContactId_) -> procCmd $ do
let randomXContactId = XContactId <$> drgRandomBytes 16
xContactId <- maybe randomXContactId pure xContactId_
subMode <- chatReadVar subscriptionMode
let groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
case groupLinkId of
-- contact address
Nothing ->
withStore' (\db -> getConnReqContactXContactId db user cReqHash) >>= \case
(Just contact, _) -> pure $ CRContactAlreadyExists user contact
(_, xContactId_) -> procCmd $ do
let randomXContactId = XContactId <$> drgRandomBytes 16
xContactId <- maybe randomXContactId pure xContactId_
connect' Nothing cReqHash xContactId
-- group link
Just gLinkId ->
withStore' (\db -> getConnReqContactXContactId db user cReqHash) >>= \case
(Just _contact, _) -> procCmd $ do
-- allow repeat contact request
newXContactId <- XContactId <$> drgRandomBytes 16
connect' (Just gLinkId) cReqHash newXContactId
(_, xContactId_) -> procCmd $ do
let randomXContactId = XContactId <$> drgRandomBytes 16
xContactId <- maybe randomXContactId pure xContactId_
connect' (Just gLinkId) cReqHash xContactId
where
connect' groupLinkId cReqHash xContactId = do
-- [incognito] generate profile to send
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
let profileToSend = userProfileToSend user incognitoProfile Nothing
dm <- directMessage (XContact profileToSend $ Just xContactId)
subMode <- chatReadVar subscriptionMode
connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq dm subMode
let groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
conn <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile groupLinkId subMode
toView $ CRNewContactConnection user conn
pure $ CRSentInvitation user incognitoProfile
@ -2000,7 +2056,7 @@ processChatCommand = \case
-- read contacts before user update to correctly merge preferences
-- [incognito] filter out contacts with whom user has incognito connections
contacts <-
filter (\ct -> isReady ct && contactActive ct && not (contactConnIncognito ct))
filter (\ct -> contactReady ct && contactActive ct && not (contactConnIncognito ct))
<$> withStore' (`getUserContacts` user)
user' <- updateUser
asks currentUser >>= atomically . (`writeTVar` Just user')
@ -2059,9 +2115,8 @@ processChatCommand = \case
when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g)
when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved
unless (memberActive membership) $ throwChatError CEGroupMemberNotActive
delGroupChatItem :: User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> m ChatResponse
delGroupChatItem user gInfo@GroupInfo {localDisplayName = gName} ci msgId byGroupMember = do
setActive $ ActiveG gName
delGroupChatItem :: MsgDirectionI d => User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Maybe GroupMember -> m ChatResponse
delGroupChatItem user gInfo ci msgId byGroupMember = do
deletedTs <- liftIO getCurrentTime
if groupFeatureAllowed SGFFullDelete gInfo
then deleteGroupCI user gInfo ci True False byGroupMember deletedTs
@ -2071,10 +2126,6 @@ processChatCommand = \case
g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db ->
getGroupIdByName db user gName >>= getGroup db user
runUpdateGroupProfile user g $ update p
isReady :: Contact -> Bool
isReady ct =
let s = connStatus $ ct.activeConn
in s == ConnReady || s == ConnSndReady
withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
withCurrentCall ctId action = do
(user, ct) <- withStore $ \db -> do
@ -2122,7 +2173,6 @@ processChatCommand = \case
let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
ci <- saveSndChatItem user (CDDirectSnd ct) msg content
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
setActive $ ActiveG localDisplayName
sndContactCITimed :: Bool -> Contact -> Maybe Int -> m (Maybe CITimed)
sndContactCITimed live = sndCITimed_ live . contactTimedTTL
sndGroupCITimed :: Bool -> GroupInfo -> Maybe Int -> m (Maybe CITimed)
@ -2172,7 +2222,6 @@ processChatCommand = \case
users <- withStore' getUsers
unless (length users > 1 && (isJust (viewPwdHash user) || length (filter (isNothing . viewPwdHash) users) > 1)) $
throwChatError (CECantDeleteLastUser userId)
setActive ActiveNone
deleteChatUser :: User -> Bool -> m ChatResponse
deleteChatUser user delSMPQueues = do
filesInfo <- withStore' (`getUserFileInfo` user)
@ -2193,6 +2242,54 @@ processChatCommand = \case
pure (gId, chatSettings)
_ -> throwChatError $ CECommandError "not supported"
processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings
connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan
connectPlan user (ACR SCMInvitation cReq) = do
withStore' (\db -> getConnectionEntityByConnReq db user cReq) >>= \case
Nothing -> pure $ CPInvitationLink ILPOk
Just (RcvDirectMsgConnection conn ct_) -> do
let Connection {connStatus, contactConnInitiated} = conn
if
| connStatus == ConnNew && contactConnInitiated ->
pure $ CPInvitationLink ILPOwnLink
| not (connReady conn) ->
pure $ CPInvitationLink (ILPConnecting ct_)
| otherwise -> case ct_ of
Just ct -> pure $ CPInvitationLink (ILPKnown ct)
Nothing -> throwChatError $ CEInternalError "ready RcvDirectMsgConnection connection should have associated contact"
Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
connectPlan user (ACR SCMContact cReq) = do
let CRContactUri ConnReqUriData {crClientData} = cReq
groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
case groupLinkId of
-- contact address
Nothing ->
withStore' (`getUserContactLinkByConnReq` cReq) >>= \case
Just _ -> pure $ CPContactAddress CAPOwnLink
Nothing -> do
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
withStore' (\db -> getContactByConnReqHash db user cReqHash) >>= \case
Nothing -> pure $ CPContactAddress CAPOk
Just ct
| not (contactReady ct) && contactActive ct -> pure $ CPContactAddress (CAPConnecting ct)
| otherwise -> pure $ CPContactAddress (CAPKnown ct)
-- group link
Just _ ->
withStore' (\db -> getGroupInfoByUserContactLinkConnReq db user cReq) >>= \case
Just g -> pure $ CPGroupLink (GLPOwnLink g)
Nothing -> do
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
ct_ <- withStore' $ \db -> getContactByConnReqHash db user cReqHash
gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db user cReqHash
case (gInfo_, ct_) of
(Nothing, Nothing) -> pure $ CPGroupLink GLPOk
(Nothing, Just ct)
| not (contactReady ct) && contactActive ct -> pure $ CPGroupLink (GLPConnecting gInfo_)
| otherwise -> pure $ CPGroupLink GLPOk
(Just gInfo@GroupInfo {membership}, _)
| not (memberActive membership) && not (memberRemoved membership) ->
pure $ CPGroupLink (GLPConnecting gInfo_)
| memberActive membership -> pure $ CPGroupLink (GLPKnown gInfo)
| otherwise -> pure $ CPGroupLink GLPOk
assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m ()
assertDirectAllowed user dir ct event =
@ -2758,10 +2855,10 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do
waitChatStarted
case cType of
CTDirect -> do
(ct, ci) <- withStoreCtx (Just "deleteTimedItem, getContact ...") $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
(ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
deleteDirectCI user ct ci True True >>= toView
CTGroup -> do
(gInfo, ci) <- withStoreCtx (Just "deleteTimedItem, getGroupInfo ...") $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId
(gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId
deletedTs <- liftIO getCurrentTime
deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView
_ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType"
@ -2824,17 +2921,16 @@ processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone ->
processAgentMessageNoConn = \case
CONNECT p h -> hostEvent $ CRHostConnected p h
DISCONNECT p h -> hostEvent $ CRHostDisconnected p h
DOWN srv conns -> serverEvent srv conns CRContactsDisconnected "disconnected"
UP srv conns -> serverEvent srv conns CRContactsSubscribed "connected"
SUSPENDED -> toView $ CRChatSuspended Nothing
DOWN srv conns -> serverEvent srv conns CRContactsDisconnected
UP srv conns -> serverEvent srv conns CRContactsSubscribed
SUSPENDED -> toView CRChatSuspended
DEL_USER agentUserId -> toView $ CRAgentUserDeleted agentUserId
where
hostEvent :: ChatResponse -> m ()
hostEvent = whenM (asks $ hostEvents . config) . toView
serverEvent srv@(SMPServer host _ _) conns event str = do
cs <- withStore' $ \db -> getConnectionsContacts db conns
serverEvent srv conns event = do
cs <- withStore' (`getConnectionsContacts` conns)
toView $ event srv cs
showToast ("server " <> str) (safeDecodeUtf8 $ strEncode host)
processAgentMsgSndFile :: forall m. ChatMonad m => ACorrId -> SndFileId -> ACommand 'Agent 'AESndFile -> m ()
processAgentMsgSndFile _corrId aFileId msg =
@ -2971,10 +3067,7 @@ processAgentMsgRcvFile _corrId aFileId msg =
processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
processAgentMessageConn user _ agentConnId END =
withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= \case
RcvDirectMsgConnection _ (Just ct@Contact {localDisplayName = c}) -> do
toView $ CRContactAnotherClient user ct
whenUserNtfs user $ showToast (c <> "> ") "connected to another client"
unsetActive $ ActiveC c
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
entity -> toView $ CRSubscriptionEnd user entity
processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
entity <- withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= updateConnStatus
@ -3041,7 +3134,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
Just ct@Contact {localDisplayName = c, contactId} -> case agentMsg of
Just ct@Contact {contactId} -> case agentMsg of
INV (ACR _ cReq) ->
-- [async agent commands] XGrpMemIntro continuation on receiving INV
withCompletedCommand conn agentMsg $ \_ ->
@ -3126,9 +3219,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
toView $ CRContactConnected user ct (fmap fromLocalProfile incognitoProfile)
when (directOrUsed ct) $ createFeatureEnabledItems ct
whenUserNtfs user $ do
setActive $ ActiveC c
showToast (c <> "> ") "connected"
when (contactConnInitiated conn) $ do
let Connection {groupLinkId} = conn
doProbeContacts = isJust groupLinkId
@ -3205,7 +3295,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> pure ()
processGroupMessage :: ACommand 'Agent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> m ()
processGroupMessage agentMsg connEntity conn@Connection {connId, connectionCode} gInfo@GroupInfo {groupId, localDisplayName = gName, groupProfile, membership, chatSettings} m = case agentMsg of
processGroupMessage agentMsg connEntity conn@Connection {connId, connectionCode} gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} m = case agentMsg of
INV (ACR _ cReq) ->
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} ->
case cReq of
@ -3287,7 +3377,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
updateGroupMemberStatus db userId membership GSMemConnected
-- possible improvement: check for each pending message, requires keeping track of connection state
unless (connDisabled conn) $ sendPendingGroupMessages user m conn
withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ enableNtfs chatSettings
withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ chatHasNtfs chatSettings
case memberCategory m of
GCHostMember -> do
toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected}
@ -3295,15 +3385,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
let GroupInfo {groupProfile = GroupProfile {description}} = gInfo
memberConnectedChatItem gInfo m
forM_ description $ groupDescriptionChatItem gInfo m
whenUserNtfs user $ do
setActive $ ActiveG gName
showToast ("#" <> gName) "you are connected to group"
GCInviteeMember -> do
memberConnectedChatItem gInfo m
toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected}
whenGroupNtfs user gInfo $ do
setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> m.localDisplayName <> " is connected"
intros <- withStore' $ \db -> createIntroductions db members m
void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
forM_ intros $ \intro ->
@ -3599,7 +3683,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
profileContactRequest invId chatVRange p xContactId_ = do
withStore (\db -> createOrUpdateContactRequest db user userContactLinkId invId chatVRange p xContactId_) >>= \case
CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact
CORRequest cReq@UserContactRequest {localDisplayName} -> do
CORRequest cReq -> do
withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
Just (UserContactLink {autoAccept}, groupId_, _) ->
case autoAccept of
@ -3614,10 +3698,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
ct <- acceptContactRequestAsync user cReq profileMode
toView $ CRAcceptingGroupJoinRequest user gInfo ct
_ -> do
toView $ CRReceivedContactRequest user cReq
whenUserNtfs user $
showToast (localDisplayName <> "> ") "wants to connect to you"
_ -> toView $ CRReceivedContactRequest user cReq
_ -> pure ()
incAuthErrCounter :: ConnectionEntity -> Connection -> AgentErrorType -> m ()
@ -3708,13 +3789,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvMsgContent $ MCText descr) Nothing
notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> m ()
notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} ct_ = do
notifyMemberConnected gInfo m ct_ = do
memberConnectedChatItem gInfo m
toView $ CRConnectedToGroupMember user gInfo m ct_
let g = groupName' gInfo
whenGroupNtfs user gInfo $ do
setActive $ ActiveG g
showToast ("#" <> g) $ "member " <> c <> " is connected"
probeMatchingContactsAndMembers :: Contact -> IncognitoEnabled -> Bool -> m ()
probeMatchingContactsAndMembers ct connectedIncognito doProbeContacts = do
@ -3776,7 +3853,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
messageError = toView . CRMessageError user "error"
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
newContentMessage ct@Contact {localDisplayName = c, contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc
@ -3789,23 +3866,18 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
if isVoice content && not (featureAllowed SCFVoice forContact ct)
then do
void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
setActive $ ActiveC c
else do
let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc
timed_ = rcvContactCITimed ct itemTTL
live = fromMaybe False live_
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
autoAcceptFile file_
whenContactNtfs user ct $ do
showMsgToast (c <> "> ") content formattedText
setActive $ ActiveC c
where
newChatItem ciContent ciFile_ timed_ live = do
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions})
pure ci
autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> m ()
autoAcceptFile = mapM_ $ \(ft, CIFile {fileSize}) -> do
@ -3864,7 +3936,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
pure (ft, CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol})
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
messageUpdate ct@Contact {contactId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
updateRcvChatItem `catchCINotFound` \_ -> do
-- This patches initial sharedMsgId into chat item when locally deleted chat item
@ -3876,7 +3948,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
createChatItemVersion db (chatItemId' ci) brokerTs mc
updateDirectChatItem' db user contactId ci content live Nothing
toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci')
setActive $ ActiveC c
where
MsgMeta {broker = (_, brokerTs)} = msgMeta
content = CIRcvMsgContent mc
@ -3903,7 +3974,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
deleteRcvChatItem `catchCINotFound` (toView . CRChatItemDeletedNotFound user ct)
where
deleteRcvChatItem = do
ci@(CChatItem msgDir _) <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId
CChatItem msgDir ci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId
case msgDir of
SMDRcv ->
if featureAllowed SCFFullDelete forContact ct
@ -3963,7 +4034,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
e -> throwError e
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
newGroupContentMessage gInfo m@GroupMember {localDisplayName = c, memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta
| isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice
| not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
| otherwise = do
@ -3984,29 +4055,24 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
createItem timed_ live
| groupFeatureAllowed SGFFullDelete gInfo = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta CIRcvModerated Nothing timed_ False
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo (CChatItem SMDRcv ci) moderator moderatedAt
toView $ CRNewChatItem user ci'
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt
toView $ CRNewChatItem user $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci'
| otherwise = do
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent content) (snd <$> file_) timed_ False
cr <- markGroupCIDeleted user gInfo (CChatItem SMDRcv ci) createdByMsgId False (Just moderator) moderatedAt
toView cr
toView =<< markGroupCIDeleted user gInfo ci createdByMsgId False (Just moderator) moderatedAt
createItem timed_ live = do
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
autoAcceptFile file_
let g = groupName' gInfo
whenGroupNtfs user gInfo $ do
showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText
setActive $ ActiveG g
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
when (showMessages $ memberSettings m) $ autoAcceptFile file_
newChatItem ciContent ciFile_ timed_ live = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
groupMsgToView gInfo m ci {reactions} msgMeta
pure ci
groupMsgToView gInfo m ci' {reactions} msgMeta
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
groupMessageUpdate gInfo@GroupInfo {groupId, localDisplayName = g} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ =
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ =
updateRcvChatItem `catchCINotFound` \_ -> do
-- This patches initial sharedMsgId into chat item when locally deleted chat item
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
@ -4015,9 +4081,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta content Nothing timed_ live
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
updateGroupChatItem db user groupId ci content live Nothing
ci' <- updateGroupChatItem db user groupId ci content live Nothing
blockedMember m ci' $ markGroupChatItemBlocked db user gInfo ci'
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
setActive $ ActiveG g
where
MsgMeta {broker = (_, brokerTs)} = msgMeta
content = CIRcvMsgContent mc
@ -4036,7 +4102,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
updateGroupChatItem db user groupId ci content live $ Just msgId
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
setActive $ ActiveG g
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
else toView $ CRChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
else messageError "x.msg.update: group member attempted to update a message of another member"
@ -4046,7 +4111,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} MsgMeta {broker = (_, brokerTs)} = do
let msgMemberId = fromMaybe memberId sndMemberId_
withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case
Right ci@(CChatItem _ ChatItem {chatDir}) -> case chatDir of
Right (CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of
CIGroupRcv mem
| sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView
| otherwise -> deleteMsg mem ci
@ -4056,7 +4121,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
| senderRole < GRAdmin -> messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e
| otherwise -> withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs
where
deleteMsg :: GroupMember -> CChatItem 'CTGroup -> m ()
deleteMsg :: MsgDirectionI d => GroupMember -> ChatItem 'CTGroup d -> m ()
deleteMsg mem ci = case sndMemberId_ of
Just sndMemberId
| sameMemberId sndMemberId mem -> checkRole mem $ delete ci (Just m) >>= toView
@ -4066,13 +4131,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
| senderRole < GRAdmin || senderRole < memberRole =
messageError "x.msg.del: message of another member with insufficient member permissions"
| otherwise = a
delete :: MsgDirectionI d => ChatItem 'CTGroup d -> Maybe GroupMember -> m ChatResponse
delete ci byGroupMember
| groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCI user gInfo ci False False byGroupMember brokerTs
| otherwise = markGroupCIDeleted user gInfo ci msgId False byGroupMember brokerTs
-- TODO remove once XFile is discontinued
processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
processFileInvitation' ct@Contact {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
processFileInvitation' ct fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
ChatConfig {fileChunkSize} <- asks config
inline <- receiveInlineMode fInv Nothing fileChunkSize
@ -4081,24 +4147,23 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
whenContactNtfs user ct $ do
showToast (c <> "> ") "wants to send a file"
setActive $ ActiveC c
-- TODO remove once XFile is discontinued
processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
processGroupFileInvitation' gInfo m@GroupMember {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
processGroupFileInvitation' gInfo m fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
ChatConfig {fileChunkSize} <- asks config
inline <- receiveInlineMode fInv Nothing fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
groupMsgToView gInfo m ci msgMeta
let g = groupName' gInfo
whenGroupNtfs user gInfo $ do
showToast ("#" <> g <> " " <> c <> "> ") "wants to send a file"
setActive $ ActiveG g
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
groupMsgToView gInfo m ci' msgMeta
blockedMember :: Monad m' => GroupMember -> ChatItem c d -> m' (ChatItem c d) -> m' (ChatItem c d)
blockedMember m ci blockedCI
| showMessages (memberSettings m) = pure ci
| otherwise = blockedCI
receiveInlineMode :: FileInvitation -> Maybe MsgContent -> Integer -> m (Maybe InlineFileMode)
receiveInlineMode FileInvitation {fileSize, fileInline, fileDescr} mc_ chSize = case (fileInline, fileDescr) of
@ -4255,7 +4320,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m ()
processGroupInvitation ct inv msg msgMeta = do
let Contact {localDisplayName = c, activeConn = Connection {peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'}} = ct
let Contact {localDisplayName = c, activeConn = Connection {connId, peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'}} = ct
GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), invitedMember = (MemberIdRole memId memRole), connRequest, groupLinkId} = inv
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
@ -4268,6 +4333,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
dm <- directMessage $ XGrpAcpt memberId
connIds <- joinAgentConnectionAsync user True connRequest dm subMode
withStore' $ \db -> do
setViaGroupLinkHash db groupId connId
createMemberConnectionAsync db user hostId connIds (fromJVersionRange peerChatVRange) subMode
updateGroupMemberStatusById db userId hostId GSMemAccepted
updateGroupMemberStatus db userId membership GSMemAccepted
@ -4278,8 +4344,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
whenContactNtfs user ct $
showToast ("#" <> localDisplayName <> " " <> c <> "> ") "invited you to join the group"
where
sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
sameGroupLinkId (Just gli) (Just gli') = gli == gli'
@ -4618,7 +4682,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRJoinedGroupMemberConnecting user gInfo m newMember
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m ()
xGrpMemIntro gInfo@GroupInfo {chatSettings = ChatSettings {enableNtfs}} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do
case memberCategory m of
GCHostMember -> do
members <- withStore' $ \db -> getGroupMembers db user gInfo
@ -4638,7 +4702,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId subMode
_ -> messageError "x.grp.mem.intro can be only sent by host member"
where
createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation subMode
createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation subMode
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> m ()
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
@ -4661,7 +4725,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m memInfo@(MemberInfo memId memRole memberChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memberChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
checkHostRole m memRole
members <- withStore' $ \db -> getGroupMembers db user gInfo
toMember <- case find (sameMemberId memId) members of
@ -4676,8 +4740,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- [incognito] send membership incognito profile, create direct connection as incognito
dm <- directMessage $ XGrpMemInfo membership.memberId (fromLocalProfile $ memberProfile membership)
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm subMode
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm subMode
groupConnIds <- joinAgentConnectionAsync user (chatHasNtfs chatSettings) groupConnReq dm subMode
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user True dcr dm subMode
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
withStore' $ \db -> createIntroToMemberContact db user m toMember mcvr groupConnIds directConnIds customUserProfileId subMode
@ -5201,20 +5265,22 @@ mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs cur
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) currentTs itemTs currentTs currentTs
pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file}
deleteDirectCI :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> Bool -> Bool -> m ChatResponse
deleteDirectCI user ct ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed = do
deleteDirectCI :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> m ChatResponse
deleteDirectCI user ct ci@ChatItem {file} byUser timed = do
deleteCIFile user file
withStoreCtx' (Just "deleteDirectCI, deleteDirectChatItem") $ \db -> deleteDirectChatItem db user ct ci
pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) Nothing byUser timed
pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDirection (DirectChat ct) ci) Nothing byUser timed
deleteGroupCI :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed byGroupMember_ deletedTs = do
deleteGroupCI :: (ChatMonad m, MsgDirectionI d) => User -> GroupInfo -> ChatItem 'CTGroup d -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
deleteGroupCI user gInfo ci@ChatItem {file} byUser timed byGroupMember_ deletedTs = do
deleteCIFile user file
toCi <- withStoreCtx' (Just "deleteGroupCI, deleteGroupChatItem ...") $ \db ->
case byGroupMember_ of
Nothing -> deleteGroupChatItem db user gInfo ci $> Nothing
Just m -> Just <$> updateGroupChatItemModerated db user gInfo ci m deletedTs
pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi byUser timed
pure $ CRChatItemDeleted user (gItem ci) (gItem <$> toCi) byUser timed
where
gItem = AChatItem SCTGroup msgDirection (GroupChat gInfo)
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
deleteCIFile user file_ =
@ -5222,25 +5288,21 @@ deleteCIFile user file_ =
fileAgentConnIds <- deleteFile' user (mkCIFileInfo file) True
deleteAgentConnectionsAsync user fileAgentConnIds
markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> UTCTime -> m ChatResponse
markDirectCIDeleted user ct@Contact {contactId} ci@(CChatItem _ ChatItem {file}) msgId byUser deletedTs = do
markDirectCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> MessageId -> Bool -> UTCTime -> m ChatResponse
markDirectCIDeleted user ct ci@ChatItem {file} msgId byUser deletedTs = do
cancelCIFile user file
toCi <- withStore $ \db -> do
liftIO $ markDirectChatItemDeleted db user ct ci msgId deletedTs
getDirectChatItem db user contactId (cchatItemId ci)
pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem toCi) byUser False
ci' <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId deletedTs
pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem ci') byUser False
where
ctItem (CChatItem msgDir ci') = AChatItem SCTDirect msgDir (DirectChat ct) ci'
ctItem = AChatItem SCTDirect msgDirection (DirectChat ct)
markGroupCIDeleted :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
markGroupCIDeleted user gInfo@GroupInfo {groupId} ci@(CChatItem _ ChatItem {file}) msgId byUser byGroupMember_ deletedTs = do
markGroupCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
markGroupCIDeleted user gInfo ci@ChatItem {file} msgId byUser byGroupMember_ deletedTs = do
cancelCIFile user file
toCi <- withStore $ \db -> do
liftIO $ markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ deletedTs
getGroupChatItem db user groupId (cchatItemId ci)
pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem toCi) byUser False
ci' <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ deletedTs
pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem ci') byUser False
where
gItem (CChatItem msgDir ci') = AChatItem SCTGroup msgDir (GroupChat gInfo) ci'
gItem = AChatItem SCTGroup msgDirection (GroupChat gInfo)
cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
cancelCIFile user file_ =
@ -5426,30 +5488,6 @@ getCreateActiveUser st testView = do
getWithPrompt :: String -> IO String
getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine
whenUserNtfs :: ChatMonad' m => User -> m () -> m ()
whenUserNtfs User {showNtfs, activeUser} = when $ showNtfs || activeUser
whenContactNtfs :: ChatMonad' m => User -> Contact -> m () -> m ()
whenContactNtfs user Contact {chatSettings} = whenUserNtfs user . when (enableNtfs chatSettings)
whenGroupNtfs :: ChatMonad' m => User -> GroupInfo -> m () -> m ()
whenGroupNtfs user GroupInfo {chatSettings} = whenUserNtfs user . when (enableNtfs chatSettings)
showMsgToast :: ChatMonad' m => Text -> MsgContent -> Maybe MarkdownList -> m ()
showMsgToast from mc md_ = showToast from $ maybe (msgContentText mc) (mconcat . map hideSecret) md_
where
hideSecret :: FormattedText -> Text
hideSecret FormattedText {format = Just Secret} = "..."
hideSecret FormattedText {text} = text
showToast :: ChatMonad' m => Text -> Text -> m ()
showToast title text = atomically . (`writeTBQueue` Notification {title, text}) =<< asks notifyQ
notificationSubscriber :: ChatMonad' m => m ()
notificationSubscriber = do
ChatController {notifyQ, sendNotification} <- ask
forever $ atomically (readTBQueue notifyQ) >>= liftIO . sendNotification
withUser' :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse
withUser' action =
asks currentUser
@ -5487,9 +5525,12 @@ withAgent action =
chatCommandP :: Parser ChatCommand
chatCommandP =
choice
[ "/mute " *> ((`SetShowMessages` False) <$> chatNameP),
"/unmute " *> ((`SetShowMessages` True) <$> chatNameP),
[ "/mute " *> ((`SetShowMessages` MFNone) <$> chatNameP),
"/unmute " *> ((`SetShowMessages` MFAll) <$> chatNameP),
"/unmute mentions " *> ((`SetShowMessages` MFMentions) <$> chatNameP),
"/receipts " *> (SetSendReceipts <$> chatNameP <* " " <*> ((Just <$> onOffP) <|> ("default" $> Nothing))),
"/block #" *> (SetShowMemberMessages <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure False),
"/unblock #" *> (SetShowMemberMessages <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure True),
"/_create user " *> (CreateActiveUser <$> jsonP),
"/create user " *> (CreateActiveUser <$> newUserP),
"/users" $> ListUsers,
@ -5593,6 +5634,7 @@ chatCommandP =
("/network" <|> "/net") $> APIGetNetworkConfig,
"/reconnect" $> ReconnectAllServers,
"/_settings " *> (APISetChatSettings <$> chatRefP <* A.space <*> jsonP),
"/_member settings #" *> (APISetMemberSettings <$> A.decimal <* A.space <*> A.decimal <* A.space <*> jsonP),
"/_info #" *> (APIGroupMemberInfo <$> A.decimal <* A.space <*> A.decimal),
"/_info #" *> (APIGroupInfo <$> A.decimal),
"/_info @" *> (APIContactInfo <$> A.decimal),
@ -5667,6 +5709,7 @@ chatCommandP =
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* char_ '@' <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> msgTextP),
"/_contacts " *> (APIListContacts <$> A.decimal),
"/contacts" $> ListContacts,
"/_connect plan " *> (APIConnectPlan <$> A.decimal <* A.space <*> strP),
"/_connect " *> (APIConnect <$> A.decimal <*> incognitoOnOffP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
"/_connect " *> (APIAddContact <$> A.decimal <*> incognitoOnOffP),
"/_set incognito :" *> (APISetConnectionIncognito <$> A.decimal <* A.space <*> onOffP),

117
src/Simplex/Chat/Controller.hs
View file

@ -38,8 +38,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.String
import Data.Text (Text)
import Data.Time (NominalDiffTime)
import Data.Time.Clock (UTCTime)
import Data.Time (NominalDiffTime, UTCTime)
import Data.Version (showVersion)
import GHC.Generics (Generic)
import Language.Haskell.TH (Exp, Q, runIO)
@ -159,21 +158,11 @@ defaultInlineFilesConfig =
receiveInstant = True -- allow receiving instant files, within receiveChunks limit
}
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName
deriving (Eq)
chatActiveTo :: ChatName -> ActiveTo
chatActiveTo (ChatName cType name) = case cType of
CTDirect -> ActiveC name
CTGroup -> ActiveG name
_ -> ActiveNone
data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLiteStore}
data ChatController = ChatController
{ currentUser :: TVar (Maybe User),
currentRemoteHost :: TVar (Maybe RemoteHostId),
activeTo :: TVar ActiveTo,
firstTime :: Bool,
smpAgent :: AgentClient,
agentAsync :: TVar (Maybe (Async (), Maybe (Async ()))),
@ -182,8 +171,6 @@ data ChatController = ChatController
idsDrg :: TVar ChaChaDRG,
inputQ :: TBQueue String,
outputQ :: TBQueue (Maybe CorrId, Maybe RemoteHostId, ChatResponse),
notifyQ :: TBQueue Notification,
sendNotification :: Notification -> IO (),
subscriptionMode :: TVar SubscriptionMode,
chatLock :: Lock,
sndFiles :: TVar (Map Int64 Handle),
@ -313,6 +300,7 @@ data ChatCommand
| APIGetNetworkConfig
| ReconnectAllServers
| APISetChatSettings ChatRef ChatSettings
| APISetMemberSettings GroupId GroupMemberId GroupMemberSettings
| APIContactInfo ContactId
| APIGroupInfo GroupId
| APIGroupMemberInfo GroupId GroupMemberId
@ -328,8 +316,9 @@ data ChatCommand
| APIVerifyGroupMember GroupId GroupMemberId (Maybe Text)
| APIEnableContact ContactId
| APIEnableGroupMember GroupId GroupMemberId
| SetShowMessages ChatName Bool
| SetShowMessages ChatName MsgFilter
| SetSendReceipts ChatName (Maybe Bool)
| SetShowMemberMessages GroupName ContactName Bool
| ContactInfo ContactName
| ShowGroupInfo GroupName
| GroupMemberInfo GroupName ContactName
@ -350,6 +339,7 @@ data ChatCommand
| APIAddContact UserId IncognitoEnabled
| AddContact IncognitoEnabled
| APISetConnectionIncognito Int64 IncognitoEnabled
| APIConnectPlan UserId AConnectionRequestUri
| APIConnect UserId IncognitoEnabled (Maybe AConnectionRequestUri)
| Connect IncognitoEnabled (Maybe AConnectionRequestUri)
| ConnectSimplex IncognitoEnabled -- UserId (not used in UI)
@ -473,14 +463,14 @@ allowRemoteCommand = \case
data ChatResponse
= CRActiveUser {user :: User}
| CRUsersList {users :: [UserInfo]}
| CRChatStarted {_nullary :: Maybe Int}
| CRChatRunning {_nullary :: Maybe Int}
| CRChatStopped {_nullary :: Maybe Int}
| CRChatSuspended {_nullary :: Maybe Int}
| CRChatStarted
| CRChatRunning
| CRChatStopped
| CRChatSuspended
| CRApiChats {user :: User, chats :: [AChat]}
| CRChats {chats :: [AChat]}
| CRApiChat {user :: User, chat :: AChat}
| CRChatItems {user :: User, chatItems :: [AChatItem]}
| CRChatItems {user :: User, chatName_ :: Maybe ChatName, chatItems :: [AChatItem]}
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
| CRChatItemId User (Maybe ChatItemId)
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
@ -537,6 +527,7 @@ data ChatResponse
| CRVersionInfo {versionInfo :: CoreVersionInfo, chatMigrations :: [UpMigration], agentMigrations :: [UpMigration]}
| CRInvitation {user :: User, connReqInvitation :: ConnReqInvitation, connection :: PendingContactConnection}
| CRConnectionIncognitoUpdated {user :: User, toConnection :: PendingContactConnection}
| CRConnectionPlan {user :: User, connectionPlan :: ConnectionPlan}
| CRSentConfirmation {user :: User}
| CRSentInvitation {user :: User, customUserProfile :: Maybe Profile}
| CRContactUpdated {user :: User, fromContact :: Contact, toContact :: Contact}
@ -640,14 +631,14 @@ data ChatResponse
| CRRemoteHostDeleted {remoteHostId :: RemoteHostId}
| CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]}
| CRRemoteCtrlRegistered {remoteCtrlId :: RemoteCtrlId}
| CRRemoteCtrlStarted {_nullary :: Maybe Int}
| CRRemoteCtrlStarted
| CRRemoteCtrlAnnounce {fingerprint :: C.KeyHash} -- unregistered fingerprint, needs confirmation
| CRRemoteCtrlFound {remoteCtrl :: RemoteCtrl} -- registered fingerprint, may connect
| CRRemoteCtrlAccepted {remoteCtrlId :: RemoteCtrlId}
| CRRemoteCtrlRejected {remoteCtrlId :: RemoteCtrlId}
| CRRemoteCtrlConnecting {remoteCtrlId :: RemoteCtrlId, displayName :: Text}
| CRRemoteCtrlConnected {remoteCtrlId :: RemoteCtrlId, displayName :: Text}
| CRRemoteCtrlStopped {_nullary :: Maybe Int}
| CRRemoteCtrlStopped
| CRRemoteCtrlDeleted {remoteCtrlId :: RemoteCtrlId}
| CRSQLResult {rows :: [Text]}
| CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]}
@ -732,6 +723,76 @@ data RemoteCtrlInfo = RemoteCtrlInfo
instance ToJSON RemoteCtrlInfo where toEncoding = J.genericToEncoding J.defaultOptions
data ConnectionPlan
= CPInvitationLink {invitationLinkPlan :: InvitationLinkPlan}
| CPContactAddress {contactAddressPlan :: ContactAddressPlan}
| CPGroupLink {groupLinkPlan :: GroupLinkPlan}
deriving (Show, Generic)
instance FromJSON ConnectionPlan where
parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "CP"
instance ToJSON ConnectionPlan where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CP"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CP"
data InvitationLinkPlan
= ILPOk
| ILPOwnLink
| ILPConnecting {contact_ :: Maybe Contact}
| ILPKnown {contact :: Contact}
deriving (Show, Generic)
instance FromJSON InvitationLinkPlan where
parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "ILP"
instance ToJSON InvitationLinkPlan where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "ILP"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "ILP"
data ContactAddressPlan
= CAPOk
| CAPOwnLink
| CAPConnecting {contact :: Contact}
| CAPKnown {contact :: Contact}
deriving (Show, Generic)
instance FromJSON ContactAddressPlan where
parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "CAP"
instance ToJSON ContactAddressPlan where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CAP"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CAP"
data GroupLinkPlan
= GLPOk
| GLPOwnLink {groupInfo :: GroupInfo}
| GLPConnecting {groupInfo_ :: Maybe GroupInfo}
| GLPKnown {groupInfo :: GroupInfo}
deriving (Show, Generic)
instance FromJSON GroupLinkPlan where
parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "GLP"
instance ToJSON GroupLinkPlan where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "GLP"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "GLP"
connectionPlanOk :: ConnectionPlan -> Bool
connectionPlanOk = \case
CPInvitationLink ilp -> case ilp of
ILPOk -> True
ILPOwnLink -> True
_ -> False
CPContactAddress cap -> case cap of
CAPOk -> True
CAPOwnLink -> True
_ -> False
CPGroupLink glp -> case glp of
GLPOk -> True
GLPOwnLink _ -> True
_ -> False
newtype UserPwd = UserPwd {unUserPwd :: Text}
deriving (Eq, Show)
@ -1013,6 +1074,7 @@ data ChatErrorType
| CEChatNotStarted
| CEChatNotStopped
| CEChatStoreChanged
| CEConnectionPlan {connectionPlan :: ConnectionPlan}
| CEInvalidConnReq
| CEInvalidChatMessage {connection :: Connection, msgMeta :: Maybe MsgMetaJSON, messageData :: Text, message :: String}
| CEContactNotFound {contactName :: ContactName, suspectedMember :: Maybe (GroupInfo, GroupMember)}
@ -1173,8 +1235,7 @@ data RemoteCtrlSession = RemoteCtrlSession
hostServer :: Maybe (Async ()),
discovered :: TMap C.KeyHash TransportHost,
accepted :: TMVar RemoteCtrlId,
remoteOutputQ :: TBQueue ChatResponse,
remoteNotifyQ :: TBQueue Notification
remoteOutputQ :: TBQueue ChatResponse
}
type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m)
@ -1212,14 +1273,6 @@ mkChatError = ChatError . CEException . show
chatCmdError :: Maybe User -> String -> ChatResponse
chatCmdError user = CRChatCmdError user . ChatError . CECommandError
setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
setActive to = asks activeTo >>= atomically . (`writeTVar` to)
unsetActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
unsetActive a = asks activeTo >>= atomically . (`modifyTVar` unset)
where
unset a' = if a == a' then ActiveNone else a'
-- | Emit local events.
toView :: ChatMonad' m => ChatResponse -> m ()
toView event = do

6
src/Simplex/Chat/Core.hs
View file

@ -14,8 +14,8 @@ import Simplex.Chat.Types
import System.Exit (exitFailure)
import UnliftIO.Async
simplexChatCore :: ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> (User -> ChatController -> IO ()) -> IO ()
simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} sendToast chat =
simplexChatCore :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO ()
simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} chat =
case logAgent of
Just level -> do
setLogLevel level
@ -28,7 +28,7 @@ simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {core
exitFailure
run db@ChatDatabase {chatStore} = do
u <- getCreateActiveUser chatStore testView
cc <- newChatController db (Just u) cfg opts sendToast
cc <- newChatController db (Just u) cfg opts
runSimplexChat opts u cc chat
runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO ()

46
src/Simplex/Chat/Messages.hs
View file

@ -50,8 +50,10 @@ import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection
deriving (Eq, Show, Ord, Generic)
data ChatName = ChatName ChatType Text
deriving (Show)
data ChatName = ChatName {chatType :: ChatType, chatName :: Text}
deriving (Show, Generic, FromJSON)
instance ToJSON ChatName where toEncoding = J.genericToEncoding J.defaultOptions
chatTypeStr :: ChatType -> String
chatTypeStr = \case
@ -170,6 +172,19 @@ instance (ChatTypeI c, MsgDirectionI d) => ToJSON (ChatItem c d) where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
isMention :: ChatItem c d -> Bool
isMention ChatItem {chatDir, quotedItem} = case chatDir of
CIDirectRcv -> userItem quotedItem
CIGroupRcv _ -> userItem quotedItem
_ -> False
where
userItem = \case
Nothing -> False
Just CIQuote {chatDir = cd} -> case cd of
CIQDirectSnd -> True
CIQGroupSnd -> True
_ -> False
data CIDirection (c :: ChatType) (d :: MsgDirection) where
CIDirectSnd :: CIDirection 'CTDirect 'MDSnd
CIDirectRcv :: CIDirection 'CTDirect 'MDRcv
@ -271,26 +286,6 @@ ciReactionAllowed :: ChatItem c d -> Bool
ciReactionAllowed ChatItem {meta = CIMeta {itemDeleted = Just _}} = False
ciReactionAllowed ChatItem {content} = isJust $ ciMsgContent content
data CIDeletedState = CIDeletedState
{ markedDeleted :: Bool,
deletedByMember :: Maybe GroupMember
}
deriving (Show, Eq)
chatItemDeletedState :: ChatItem c d -> Maybe CIDeletedState
chatItemDeletedState ChatItem {meta = CIMeta {itemDeleted}, content} =
ciDeletedToDeletedState <$> itemDeleted
where
ciDeletedToDeletedState cid =
case content of
CISndModerated -> CIDeletedState {markedDeleted = False, deletedByMember = byMember cid}
CIRcvModerated -> CIDeletedState {markedDeleted = False, deletedByMember = byMember cid}
_ -> CIDeletedState {markedDeleted = True, deletedByMember = byMember cid}
byMember :: CIDeleted c -> Maybe GroupMember
byMember = \case
CIModerated _ m -> Just m
CIDeleted _ -> Nothing
data ChatDirection (c :: ChatType) (d :: MsgDirection) where
CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv
@ -1012,7 +1007,7 @@ data MsgMetaJSON = MsgMetaJSON
serverTs :: UTCTime,
sndId :: Int64
}
deriving (Eq, Show, FromJSON, Generic)
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
@ -1079,6 +1074,7 @@ msgDeliveryStatusT' s =
data CIDeleted (c :: ChatType) where
CIDeleted :: Maybe UTCTime -> CIDeleted c
CIBlocked :: Maybe UTCTime -> CIDeleted 'CTGroup
CIModerated :: Maybe UTCTime -> GroupMember -> CIDeleted 'CTGroup
deriving instance Show (CIDeleted c)
@ -1094,6 +1090,7 @@ instance ChatTypeI c => ToJSON (CIDeleted c) where
data JSONCIDeleted
= JCIDDeleted {deletedTs :: Maybe UTCTime, chatType :: ChatType}
| JCIBlocked {deletedTs :: Maybe UTCTime}
| JCIDModerated {deletedTs :: Maybe UTCTime, byGroupMember :: GroupMember}
deriving (Show, Generic)
@ -1107,16 +1104,19 @@ instance ToJSON JSONCIDeleted where
jsonCIDeleted :: forall d. ChatTypeI d => CIDeleted d -> JSONCIDeleted
jsonCIDeleted = \case
CIDeleted ts -> JCIDDeleted ts (toChatType $ chatTypeI @d)
CIBlocked ts -> JCIBlocked ts
CIModerated ts m -> JCIDModerated ts m
jsonACIDeleted :: JSONCIDeleted -> ACIDeleted
jsonACIDeleted = \case
JCIDDeleted ts cType -> case aChatType cType of ACT c -> ACIDeleted c $ CIDeleted ts
JCIBlocked ts -> ACIDeleted SCTGroup $ CIBlocked ts
JCIDModerated ts m -> ACIDeleted SCTGroup (CIModerated ts m)
itemDeletedTs :: CIDeleted d -> Maybe UTCTime
itemDeletedTs = \case
CIDeleted ts -> ts
CIBlocked ts -> ts
CIModerated ts _ -> ts
data ChatItemInfo = ChatItemInfo

38
src/Simplex/Chat/Messages/CIContent.hs
View file

@ -21,12 +21,8 @@ import Data.Int (Int64)
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (Field, FromField (..), returnError)
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic)
import Simplex.Chat.Protocol
@ -52,14 +48,6 @@ instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgD
instance ToField MsgDirection where toField = toField . msgDirectionInt
fromIntField_ :: Typeable a => (Int64 -> Maybe a) -> Field -> Ok a
fromIntField_ fromInt = \case
f@(Field (SQLInteger i) _) ->
case fromInt i of
Just x -> Ok x
_ -> returnError ConversionFailed f ("invalid integer: " <> show i)
f -> returnError ConversionFailed f "expecting SQLInteger column type"
data SMsgDirection (d :: MsgDirection) where
SMDRcv :: SMsgDirection 'MDRcv
SMDSnd :: SMsgDirection 'MDSnd
@ -524,8 +512,8 @@ data JSONCIContent
| JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
| JCIRcvChatFeatureRejected {feature :: ChatFeature}
| JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
| JCISndModerated {_nullary :: Maybe Int}
| JCIRcvModerated {_nullary :: Maybe Int}
| JCISndModerated
| JCIRcvModerated
| JCIInvalidJSON {direction :: MsgDirection, json :: Text}
jsonCIContent :: forall d. MsgDirectionI d => CIContent d -> JSONCIContent
@ -553,8 +541,8 @@ jsonCIContent = \case
CISndGroupFeature groupFeature preference param -> JCISndGroupFeature {groupFeature, preference, param}
CIRcvChatFeatureRejected feature -> JCIRcvChatFeatureRejected {feature}
CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature}
CISndModerated -> JCISndModerated Nothing
CIRcvModerated -> JCISndModerated Nothing
CISndModerated -> JCISndModerated
CIRcvModerated -> JCISndModerated
CIInvalidJSON json -> JCIInvalidJSON (toMsgDirection $ msgDirection @d) json
aciContentJSON :: JSONCIContent -> ACIContent
@ -582,8 +570,8 @@ aciContentJSON = \case
JCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
JCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
JCISndModerated _ -> ACIContent SMDSnd CISndModerated
JCIRcvModerated _ -> ACIContent SMDRcv CIRcvModerated
JCISndModerated -> ACIContent SMDSnd CISndModerated
JCIRcvModerated -> ACIContent SMDRcv CIRcvModerated
JCIInvalidJSON dir json -> case fromMsgDirection dir of
AMsgDirection d -> ACIContent d $ CIInvalidJSON json
@ -612,8 +600,8 @@ data DBJSONCIContent
| DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
| DBJCIRcvChatFeatureRejected {feature :: ChatFeature}
| DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
| DBJCISndModerated {_nullary :: Maybe Int}
| DBJCIRcvModerated {_nullary :: Maybe Int}
| DBJCISndModerated
| DBJCIRcvModerated
| DBJCIInvalidJSON {direction :: MsgDirection, json :: Text}
dbJsonCIContent :: forall d. MsgDirectionI d => CIContent d -> DBJSONCIContent
@ -641,8 +629,8 @@ dbJsonCIContent = \case
CISndGroupFeature groupFeature preference param -> DBJCISndGroupFeature {groupFeature, preference, param}
CIRcvChatFeatureRejected feature -> DBJCIRcvChatFeatureRejected {feature}
CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature}
CISndModerated -> DBJCISndModerated Nothing
CIRcvModerated -> DBJCIRcvModerated Nothing
CISndModerated -> DBJCISndModerated
CIRcvModerated -> DBJCIRcvModerated
CIInvalidJSON json -> DBJCIInvalidJSON (toMsgDirection $ msgDirection @d) json
aciContentDBJSON :: DBJSONCIContent -> ACIContent
@ -670,8 +658,8 @@ aciContentDBJSON = \case
DBJCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
DBJCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
DBJCISndModerated _ -> ACIContent SMDSnd CISndModerated
DBJCIRcvModerated _ -> ACIContent SMDRcv CIRcvModerated
DBJCISndModerated -> ACIContent SMDSnd CISndModerated
DBJCIRcvModerated -> ACIContent SMDRcv CIRcvModerated
DBJCIInvalidJSON dir json -> case fromMsgDirection dir of
AMsgDirection d -> ACIContent d $ CIInvalidJSON json

24
src/Simplex/Chat/Migrations/M20231009_via_group_link_uri_hash.hs Normal file
View file

@ -0,0 +1,24 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20231009_via_group_link_uri_hash :: Query
m20231009_via_group_link_uri_hash =
[sql|
CREATE INDEX idx_connections_conn_req_inv ON connections(conn_req_inv);
ALTER TABLE groups ADD COLUMN via_group_link_uri_hash BLOB;
CREATE INDEX idx_groups_via_group_link_uri_hash ON groups(via_group_link_uri_hash);
|]
down_m20231009_via_group_link_uri_hash :: Query
down_m20231009_via_group_link_uri_hash =
[sql|
DROP INDEX idx_groups_via_group_link_uri_hash;
ALTER TABLE groups DROP COLUMN via_group_link_uri_hash;
DROP INDEX idx_connections_conn_req_inv;
|]

18
src/Simplex/Chat/Migrations/M20231010_member_settings.hs Normal file
View file

@ -0,0 +1,18 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20231010_member_settings where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20231010_member_settings :: Query
m20231010_member_settings =
[sql|
ALTER TABLE group_members ADD COLUMN show_messages INTEGER NOT NULL DEFAULT 1;
|]
down_m20231010_member_settings :: Query
down_m20231010_member_settings =
[sql|
ALTER TABLE group_members DROP COLUMN show_messages;
|]

10
src/Simplex/Chat/Migrations/M20231005_remote_controller.hs → src/Simplex/Chat/Migrations/M20231020_remote_controller.hs
View file

@ -1,12 +1,12 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20231005_remote_controller where
module Simplex.Chat.Migrations.M20231020_remote_controller where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20231005_remote_controller :: Query
m20231005_remote_controller =
m20231020_remote_controller :: Query
m20231020_remote_controller =
[sql|
CREATE TABLE remote_hosts ( -- hosts known to a controlling app
remote_host_id INTEGER PRIMARY KEY AUTOINCREMENT,
@ -25,8 +25,8 @@ CREATE TABLE remote_controllers ( -- controllers known to a hosting app
);
|]
down_m20231005_remote_controller :: Query
down_m20231005_remote_controller =
down_m20231020_remote_controller :: Query
down_m20231020_remote_controller =
[sql|
DROP TABLE remote_hosts;
DROP TABLE remote_controllers;

8
src/Simplex/Chat/Migrations/chat_schema.sql
View file

@ -117,7 +117,8 @@ CREATE TABLE groups(
unread_chat INTEGER DEFAULT 0 CHECK(unread_chat NOT NULL),
chat_ts TEXT,
favorite INTEGER NOT NULL DEFAULT 0,
send_rcpts INTEGER, -- received
send_rcpts INTEGER,
via_group_link_uri_hash BLOB, -- received
FOREIGN KEY(user_id, local_display_name)
REFERENCES display_names(user_id, local_display_name)
ON DELETE CASCADE
@ -144,6 +145,7 @@ CREATE TABLE group_members(
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
member_profile_id INTEGER REFERENCES contact_profiles ON DELETE SET NULL,
show_messages INTEGER NOT NULL DEFAULT 1,
FOREIGN KEY(user_id, local_display_name)
REFERENCES display_names(user_id, local_display_name)
ON DELETE CASCADE
@ -752,3 +754,7 @@ CREATE INDEX idx_received_probes_probe_hash ON received_probes(probe_hash);
CREATE INDEX idx_sent_probes_created_at ON sent_probes(created_at);
CREATE INDEX idx_sent_probe_hashes_created_at ON sent_probe_hashes(created_at);
CREATE INDEX idx_received_probes_created_at ON received_probes(created_at);
CREATE INDEX idx_connections_conn_req_inv ON connections(conn_req_inv);
CREATE INDEX idx_groups_via_group_link_uri_hash ON groups(
via_group_link_uri_hash
);

2
src/Simplex/Chat/Mobile.hs
View file

@ -209,7 +209,7 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
where
initialize st db = do
user_ <- getActiveUser_ st
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix dbKey) Nothing
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix dbKey)
migrate createStore dbFile confirmMigrations =
ExceptT $
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey confirmMigrations)

5
src/Simplex/Chat/Protocol.hs
View file

@ -381,6 +381,11 @@ mcExtMsgContent = \case
MCQuote _ c -> c
MCForward c -> c
isQuote :: MsgContainer -> Bool
isQuote = \case
MCQuote {} -> True
_ -> False
data LinkPreview = LinkPreview {uri :: Text, title :: Text, description :: Text, image :: ImageData, content :: Maybe LinkContent}
deriving (Eq, Show, Generic)

13
src/Simplex/Chat/Remote.hs
View file

@ -280,9 +280,9 @@ storeRemoteFile http localFile = do
notOk -> Nothing <$ logError ("Bad response status: " <> tshow notOk)
where
uri = "/store?" <> HTTP.renderSimpleQuery False [("file_name", utf8String $ takeFileName localFile)]
putFile timeout c path hs file = liftIO $ do
putFile timeout' c path hs file = liftIO $ do
fileSize <- fromIntegral <$> getFileSize file
HTTP2.sendRequestDirect c (req fileSize) timeout
HTTP2.sendRequestDirect c (req fileSize) timeout'
where
req size = HTTP2Client.requestFile "PUT" path hs (HTTP2Client.FileSpec file 0 size)
@ -388,7 +388,6 @@ startRemoteCtrl execChatCommand =
Nothing -> do
size <- asks $ tbqSize . config
remoteOutputQ <- newTBQueueIO size
remoteNotifyQ <- newTBQueueIO size
discovered <- newTVarIO mempty
discoverer <- async $ discoverRemoteCtrls discovered
accepted <- newEmptyTMVarIO
@ -403,9 +402,9 @@ startRemoteCtrl execChatCommand =
toView $ CRRemoteCtrlConnected {remoteCtrlId, displayName}
_ <- waitCatch server
chatWriteVar remoteCtrlSession Nothing
toView $ CRRemoteCtrlStopped Nothing
chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ, remoteNotifyQ}
pure $ CRRemoteCtrlStarted Nothing
toView CRRemoteCtrlStopped
chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ}
pure CRRemoteCtrlStarted
discoverRemoteCtrls :: (ChatMonad m) => TM.TMap C.KeyHash TransportHost -> m ()
discoverRemoteCtrls discovered = Discovery.withListener go
@ -477,7 +476,7 @@ stopRemoteCtrl =
Just rcs -> do
cancelRemoteCtrlSession rcs $ do
chatWriteVar remoteCtrlSession Nothing
toView $ CRRemoteCtrlStopped Nothing
toView CRRemoteCtrlStopped
pure $ CRCmdOk Nothing
cancelRemoteCtrlSession_ :: (MonadUnliftIO m) => RemoteCtrlSession -> m ()

17
src/Simplex/Chat/Store/Connections.hs
View file

@ -9,6 +9,7 @@
module Simplex.Chat.Store.Connections
( getConnectionEntity,
getConnectionEntityByConnReq,
getConnectionsToSubscribe,
unsetConnectionToSubscribe,
)
@ -31,7 +32,7 @@ import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (ConnId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow')
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Util (eitherToMaybe)
@ -78,10 +79,10 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
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, ContactStatus) :. (Maybe Bool, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool)] -> Either StoreError Contact
toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool)] -> Either StoreError Contact
toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)] =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, sendRcpts, favorite}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent}
toContact' _ _ _ = Left $ SEInternalError "referenced contact not found"
@ -96,11 +97,11 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
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.send_rcpts, 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,
mu.member_status, mu.show_messages, 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.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
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)
@ -152,6 +153,12 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
userContact_ _ = Left SEUserContactLinkNotFound
getConnectionEntityByConnReq :: DB.Connection -> User -> ConnReqInvitation -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db user cReq = do
connId_ <- maybeFirstRow fromOnly $
DB.query db "SELECT agent_conn_id FROM connections WHERE conn_req_inv = ? LIMIT 1" (Only cReq)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])
getConnectionsToSubscribe db = do
aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1"

48
src/Simplex/Chat/Store/Direct.hs
View file

@ -25,6 +25,7 @@ module Simplex.Chat.Store.Direct
createConnReqConnection,
getProfileById,
getConnReqContactXContactId,
getContactByConnReqHash,
createDirectContact,
deleteContactConnectionsAndFiles,
deleteContact,
@ -137,32 +138,10 @@ createConnReqConnection db userId acId cReqHash xContactId incognitoProfile grou
getConnReqContactXContactId :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId)
getConnReqContactXContactId db user@User {userId} cReqHash = do
getContact' >>= \case
getContactByConnReqHash db user cReqHash >>= \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.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.contact_group_member_id, ct.contact_grp_inv_sent,
-- 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.contact_conn_initiated, 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,
c.peer_chat_min_version, c.peer_chat_max_version
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.created_at DESC
LIMIT 1
|]
(userId, cReqHash)
getXContactId :: IO (Maybe XContactId)
getXContactId =
maybeFirstRow fromOnly $
@ -171,6 +150,29 @@ getConnReqContactXContactId db user@User {userId} cReqHash = do
"SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1"
(userId, cReqHash)
getContactByConnReqHash :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact)
getContactByConnReqHash db user@User {userId} cReqHash =
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.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.contact_group_member_id, ct.contact_grp_inv_sent,
-- 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.contact_conn_initiated, 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,
c.peer_chat_min_version, c.peer_chat_max_version
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.contact_status = ? AND ct.deleted = 0
ORDER BY c.created_at DESC
LIMIT 1
|]
(userId, cReqHash, CSActive)
createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> SubscriptionMode -> IO PendingContactConnection
createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile subMode = do
createdAt <- getCurrentTime

94
src/Simplex/Chat/Store/Groups.hs
View file

@ -31,9 +31,12 @@ module Simplex.Chat.Store.Groups
getGroupAndMember,
createNewGroup,
createGroupInvitation,
setViaGroupLinkHash,
setGroupInvitationChatItemId,
getGroup,
getGroupInfo,
getGroupInfoByUserContactLinkConnReq,
getGroupInfoByGroupLinkHash,
updateGroupProfile,
getGroupIdByName,
getGroupMemberIdByName,
@ -89,6 +92,7 @@ module Simplex.Chat.Store.Groups
associateContactWithMemberRecord,
deleteOldProbes,
updateGroupSettings,
updateGroupMemberSettings,
getXGrpMemIntroContDirect,
getXGrpMemIntroContGroup,
getHostConnId,
@ -128,30 +132,31 @@ import Simplex.Messaging.Util (eitherToMaybe, ($>>=), (<$$>))
import Simplex.Messaging.Version
import UnliftIO.STM
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe MsgFilter, 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 GroupMemberRow = ((Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Bool) :. (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))
type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool) :. (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_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
let membership = toGroupMember userContactId userMemberRow
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, sendRcpts, favorite}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
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)) =
toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, showMessages) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) =
let memberProfile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
memberSettings = GroupMemberSettings {showMessages}
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 userContactId ((Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus, Just showMessages) :. (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, showMessages) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences))
toMaybeGroupMember _ _ = Nothing
createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> SubscriptionMode -> ExceptT StoreError IO ()
@ -247,11 +252,11 @@ getGroupAndMember db User {userId, userContactId} groupMemberId =
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.send_rcpts, 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,
mu.member_status, mu.show_messages, 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.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
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.contact_conn_initiated, 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,
@ -297,7 +302,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, sendRcpts = Nothing, favorite = False}
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}
-- | creates a new group record for the group the current user was invited to, or returns an existing one
@ -342,7 +347,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, sendRcpts = Nothing, favorite = False}
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId)
getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId
@ -366,6 +371,7 @@ createContactMemberInv_ db User {userId, userContactId} groupId userOrContact Me
memberRole,
memberCategory,
memberStatus,
memberSettings = defaultMemberSettings,
invitedBy,
localDisplayName,
memberProfile,
@ -405,6 +411,17 @@ createContactMemberInv_ db User {userId, userContactId} groupId userOrContact Me
)
pure $ Right incognitoLdn
setViaGroupLinkHash :: DB.Connection -> GroupId -> Int64 -> IO ()
setViaGroupLinkHash db groupId connId =
DB.execute
db
[sql|
UPDATE groups
SET via_group_link_uri_hash = (SELECT via_contact_uri_hash FROM connections WHERE connection_id = ?)
WHERE group_id = ?
|]
(connId, groupId)
setGroupInvitationChatItemId :: DB.Connection -> User -> GroupId -> ChatItemId -> IO ()
setGroupInvitationChatItemId db User {userId} groupId chatItemId = do
currentTs <- getCurrentTime
@ -479,7 +496,7 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
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, g.send_rcpts, 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.group_member_id, g.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.show_messages,
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)
@ -544,7 +561,7 @@ 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.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
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.contact_conn_initiated, 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,
@ -651,6 +668,7 @@ createNewContactMember db gVar User {userId, userContactId} groupId Contact {con
memberRole,
memberCategory = GCInviteeMember,
memberStatus = GSMemInvited,
memberSettings = defaultMemberSettings,
invitedBy = IBUser,
localDisplayName,
memberProfile = profile,
@ -801,7 +819,8 @@ createNewMember_
|]
(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}
let memberSettings = defaultMemberSettings
pure GroupMember {groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, memberSettings, invitedBy, localDisplayName, memberProfile = toLocalProfile memberContactProfileId memberProfile "", memberContactId, memberContactProfileId, activeConn}
checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId)
checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} =
@ -999,11 +1018,11 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
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.send_rcpts, 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,
mu.member_status, mu.show_messages, 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.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
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.contact_conn_initiated, 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,
@ -1092,7 +1111,7 @@ getGroupInfo db User {userId, userContactId} groupId =
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.send_rcpts, 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,
mu.member_status, mu.show_messages, 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
@ -1102,6 +1121,35 @@ getGroupInfo db User {userId, userContactId} groupId =
|]
(groupId, userId, userContactId)
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> ConnReqContact -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db user cReq = do
groupId_ <- maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT group_id
FROM user_contact_links
WHERE conn_req_contact = ?
|]
(Only cReq)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} groupLinkHash = do
groupId_ <- maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT g.group_id
FROM groups g
JOIN group_members mu ON mu.group_id = g.group_id
WHERE g.user_id = ? AND g.via_group_link_uri_hash = ?
AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?)
LIMIT 1
|]
(userId, groupLinkHash, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
getGroupIdByName db User {userId} gName =
ExceptT . firstRow fromOnly (SEGroupNotFoundByName gName) $
@ -1459,6 +1507,18 @@ updateGroupSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs, sendRcpts, favorite} =
DB.execute db "UPDATE groups SET enable_ntfs = ?, send_rcpts = ?, favorite = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, sendRcpts, favorite, userId, groupId)
updateGroupMemberSettings :: DB.Connection -> User -> GroupId -> GroupMemberId -> GroupMemberSettings -> IO ()
updateGroupMemberSettings db User {userId} gId gMemberId GroupMemberSettings {showMessages} = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
UPDATE group_members
SET show_messages = ?, updated_at = ?
WHERE user_id = ? AND group_id = ? AND group_member_id = ?
|]
(showMessages, currentTs, userId, gId, gMemberId)
getXGrpMemIntroContDirect :: DB.Connection -> User -> Contact -> IO (Maybe (Int64, XGrpMemIntroCont))
getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do
fmap join . maybeFirstRow toCont $

96
src/Simplex/Chat/Store/Messages.hs
View file

@ -4,6 +4,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
@ -50,6 +51,7 @@ module Simplex.Chat.Store.Messages
deleteGroupChatItem,
updateGroupChatItemModerated,
markGroupChatItemDeleted,
markGroupChatItemBlocked,
updateDirectChatItemsRead,
getDirectUnreadTimedItems,
setDirectChatItemDeleteAt,
@ -438,7 +440,7 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
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,
m.member_status, m.show_messages, 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)
@ -548,7 +550,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
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.send_rcpts, 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,
mu.member_status, mu.show_messages, 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,
@ -558,17 +560,17 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, 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,
m.member_status, m.show_messages, 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,
rm.member_status, rm.show_messages, 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,
dbm.member_status, dbm.show_messages, 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
@ -962,9 +964,9 @@ type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath,
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 ChatItemRow = (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId) :. (Int, 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 MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe AMsgDirection, Maybe Text, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId) :. (Maybe Int, Maybe UTCTime, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow
type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool)
@ -1007,7 +1009,9 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
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
let itemDeleted' = case itemDeleted of
DBCINotDeleted -> Nothing
_ -> Just (CIDeleted @'CTDirect deletedTs)
itemEdited' = fromMaybe False itemEdited
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt
ciTimed :: Maybe CITimed
@ -1063,10 +1067,10 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
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
let itemDeleted' = case itemDeleted of
DBCINotDeleted -> Nothing
DBCIBlocked -> Just (CIBlocked deletedTs)
_ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
itemEdited' = fromMaybe False itemEdited
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt
ciTimed :: Maybe CITimed
@ -1225,8 +1229,8 @@ createChatItemVersion db itemId itemVersionTs msgContent =
|]
(itemId, toMCText msgContent, itemVersionTs)
deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO ()
deleteDirectChatItem db User {userId} Contact {contactId} (CChatItem _ ci) = do
deleteDirectChatItem :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect d -> IO ()
deleteDirectChatItem db User {userId} Contact {contactId} ci = do
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
@ -1257,8 +1261,8 @@ 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
markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect d -> MessageId -> UTCTime -> IO (ChatItem 'CTDirect d)
markDirectChatItemDeleted db User {userId} Contact {contactId} ci@ChatItem {meta} msgId deletedTs = do
currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci
insertChatItemMessage_ db itemId msgId currentTs
@ -1266,10 +1270,11 @@ markDirectChatItemDeleted db User {userId} Contact {contactId} (CChatItem _ ci)
db
[sql|
UPDATE chat_items
SET item_deleted = 1, item_deleted_ts = ?, updated_at = ?
SET item_deleted = ?, item_deleted_ts = ?, updated_at = ?
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|]
(deletedTs, currentTs, userId, contactId, itemId)
(DBCIDeleted, deletedTs, currentTs, userId, contactId, itemId)
pure ci {meta = meta {itemDeleted = Just $ CIDeleted $ Just deletedTs}}
getDirectChatItemBySharedMsgId :: DB.Connection -> User -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemBySharedMsgId db user@User {userId} contactId sharedMsgId = do
@ -1380,8 +1385,8 @@ updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ =
((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
deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci = do
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
@ -1394,10 +1399,10 @@ deleteGroupChatItem db User {userId} g@GroupInfo {groupId} (CChatItem _ ci) = do
|]
(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
updateGroupChatItemModerated :: forall d. MsgDirectionI d => DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d)
updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci m@GroupMember {groupMemberId} deletedTs = do
currentTs <- getCurrentTime
let toContent = msgDirToModeratedContent_ msgDir
let toContent = msgDirToModeratedContent_ $ msgDirection @d
toText = ciModeratedText
itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
@ -1411,24 +1416,47 @@ updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatIt
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), editable = False}, formattedText = Nothing})
pure $ ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just currentTs) m), editable = False}, 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
pattern DBCINotDeleted :: Int
pattern DBCINotDeleted = 0
pattern DBCIDeleted :: Int
pattern DBCIDeleted = 1
pattern DBCIBlocked :: Int
pattern DBCIBlocked = 2
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Maybe GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d)
markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} msgId byGroupMember_ deletedTs = do
currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci
deletedByGroupMemberId = case byGroupMember_ of
Just GroupMember {groupMemberId} -> Just groupMemberId
_ -> Nothing
(deletedByGroupMemberId, itemDeleted) = case byGroupMember_ of
Just m@GroupMember {groupMemberId} -> (Just groupMemberId, Just $ CIModerated (Just deletedTs) m)
_ -> (Nothing, Just $ CIDeleted @'CTGroup (Just deletedTs))
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 = ?
SET item_deleted = ?, 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)
(DBCIDeleted, deletedTs, deletedByGroupMemberId, currentTs, userId, groupId, itemId)
pure ci {meta = meta {itemDeleted}}
markGroupChatItemBlocked :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup 'MDRcv -> IO (ChatItem 'CTGroup 'MDRcv)
markGroupChatItemBlocked db User {userId} GroupInfo {groupId} ci@ChatItem {meta} = do
deletedTs <- getCurrentTime
DB.execute
db
[sql|
UPDATE chat_items
SET item_deleted = ?, item_deleted_ts = ?, updated_at = ?
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|]
(DBCIBlocked, deletedTs, deletedTs, userId, groupId, chatItemId' ci)
pure ci {meta = meta {itemDeleted = Just $ CIBlocked $ Just deletedTs}}
getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do
@ -1486,17 +1514,17 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, 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,
m.member_status, m.show_messages, 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,
rm.member_status, rm.show_messages, 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,
dbm.member_status, dbm.show_messages, 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

8
src/Simplex/Chat/Store/Migrations.hs
View file

@ -83,7 +83,9 @@ import Simplex.Chat.Migrations.M20230913_member_contacts
import Simplex.Chat.Migrations.M20230914_member_probes
import Simplex.Chat.Migrations.M20230926_contact_status
import Simplex.Chat.Migrations.M20231002_conn_initiated
import Simplex.Chat.Migrations.M20231005_remote_controller
import Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash
import Simplex.Chat.Migrations.M20231010_member_settings
import Simplex.Chat.Migrations.M20231020_remote_controller
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@ -167,7 +169,9 @@ schemaMigrations =
("20230914_member_probes", m20230914_member_probes, Just down_m20230914_member_probes),
("20230926_contact_status", m20230926_contact_status, Just down_m20230926_contact_status),
("20231002_conn_initiated", m20231002_conn_initiated, Just down_m20231002_conn_initiated),
("20231005_remote_controller", m20231005_remote_controller, Just down_m20231005_remote_controller)
("20231009_via_group_link_uri_hash", m20231009_via_group_link_uri_hash, Just down_m20231009_via_group_link_uri_hash),
("20231010_member_settings", m20231010_member_settings, Just down_m20231010_member_settings),
("20231020_remote_controller", m20231020_remote_controller, Just down_m20231020_remote_controller)
]
-- | The list of migrations in ascending order by date

13
src/Simplex/Chat/Store/Profiles.hs
View file

@ -43,6 +43,7 @@ module Simplex.Chat.Store.Profiles
deleteUserAddress,
getUserAddress,
getUserContactLinkById,
getUserContactLinkByConnReq,
updateUserAddressAutoAccept,
getProtocolServers,
overwriteProtocolServers,
@ -441,6 +442,18 @@ getUserContactLinkById db userId userContactLinkId =
|]
(userId, userContactLinkId)
getUserContactLinkByConnReq :: DB.Connection -> ConnReqContact -> IO (Maybe UserContactLink)
getUserContactLinkByConnReq db cReq =
maybeFirstRow toUserContactLink $
DB.query
db
[sql|
SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content
FROM user_contact_links
WHERE conn_req_contact = ?
|]
(Only cReq)
updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink
updateUserAddressAutoAccept db user@User {userId} autoAccept = do
link <- getUserAddress db user

6
src/Simplex/Chat/Store/Shared.hs
View file

@ -244,20 +244,20 @@ deleteUnusedIncognitoProfileById_ db User {userId} profileId =
|]
[":user_id" := userId, ":profile_id" := profileId]
type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, ContactStatus) :. (Maybe Bool, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool)
type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool)
toContact :: User -> ContactRow :. ConnectionRow -> Contact
toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
activeConn = toConnection connRow
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, sendRcpts, favorite}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent}
toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact
toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, sendRcpts, favorite}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
in case toMaybeConnection connRow of
Just activeConn ->
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn

8
src/Simplex/Chat/Terminal.hs
View file

@ -15,7 +15,6 @@ import Simplex.Chat.Core
import Simplex.Chat.Help (chatWelcome)
import Simplex.Chat.Options
import Simplex.Chat.Terminal.Input
import Simplex.Chat.Terminal.Notification
import Simplex.Chat.Terminal.Output
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
import Simplex.Messaging.Client (defaultNetworkConfig)
@ -40,10 +39,9 @@ terminalChatConfig =
}
simplexChatTerminal :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO ()
simplexChatTerminal cfg opts t = do
sendToast <- if muteNotifications opts then pure Nothing else Just <$> initializeNotifications
handle checkDBKeyError . simplexChatCore cfg opts sendToast $ \u cc -> do
ct <- newChatTerminal t
simplexChatTerminal cfg opts t =
handle checkDBKeyError . simplexChatCore cfg opts $ \u cc -> do
ct <- newChatTerminal t opts
when (firstTime cc) . printToTerminal ct $ chatWelcome u
runChatTerminal ct cc

38
src/Simplex/Chat/Terminal/Input.hs
View file

@ -58,14 +58,26 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
cmd = parseChatCommand bs
unless (isMessage cmd) $ echo s
r <- runReaderT (execChatCommand rh bs) cc
case r of
CRChatCmdError _ _ -> when (isMessage cmd) $ echo s
CRChatError _ _ -> when (isMessage cmd) $ echo s
_ -> pure ()
processResp s cmd r
printRespToTerminal ct cc False rh r
startLiveMessage cmd r
where
echo s = printToTerminal ct [plain s]
processResp s cmd = \case
CRActiveUser _ -> setActive ct ""
CRChatItems u chatName_ _ -> whenCurrUser cc u $ mapM_ (setActive ct . chatActiveTo) chatName_
CRNewChatItem u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
CRChatItemDeleted u (AChatItem _ _ cInfo _) _ _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c
CRGroupDeletedUser u g -> whenCurrUser cc u $ unsetActiveGroup ct g
CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g
CRChatCmdError _ _ -> when (isMessage cmd) $ echo s
CRChatError _ _ -> when (isMessage cmd) $ echo s
CRCmdOk _ -> case cmd of
Right APIDeleteUser {} -> setActive ct ""
_ -> pure ()
_ -> pure ()
isMessage = \case
Right SendMessage {} -> True
Right SendLiveMessage {} -> True
@ -135,7 +147,7 @@ runTerminalInput ct cc = withChatTerm ct $ do
receiveFromTTY cc ct
receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m ()
receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, currentRemoteHost, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState} =
receiveFromTTY cc@ChatController {inputQ, currentUser, currentRemoteHost, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState, activeTo} =
forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct)
where
processKey :: (Key, Modifiers) -> IO ()
@ -154,11 +166,11 @@ receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, currentRemoteHo
when (inputString ts /= "" || isLive) $
atomically (submitInput live ts) >>= mapM_ (uncurry endLiveMessage)
update key = do
ac <- readTVarIO activeTo
chatPrefix <- readTVarIO activeTo
live <- isJust <$> readTVarIO liveMessageState
ts <- readTVarIO termState
user_ <- readTVarIO currentUser
ts' <- updateTermState user_ chatStore ac live (width termSize) key ts
ts' <- updateTermState user_ chatStore chatPrefix live (width termSize) key ts
atomically $ writeTVar termState $! ts'
endLiveMessage :: String -> LiveMessage -> IO ()
@ -205,8 +217,8 @@ data AutoComplete
| ACCommand Text
| ACNone
updateTermState :: Maybe User -> SQLiteStore -> ActiveTo -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> IO TerminalState
updateTermState user_ st ac live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p, autoComplete = acp} = case key of
updateTermState :: Maybe User -> SQLiteStore -> String -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> IO TerminalState
updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p, autoComplete = acp} = case key of
CharKey c
| ms == mempty || ms == shiftKey -> pure $ insertChars $ charsWithContact [c]
| ms == altKey && c == 'b' -> pure $ setPosition prevWordPos
@ -328,17 +340,13 @@ updateTermState user_ st ac live tw (key, ms) ts@TerminalState {inputString = s,
charsWithContact cs
| live = cs
| null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" =
contactPrefix <> cs
chatPrefix <> cs
| (s == ">" || s == "\\" || s == "!") && cs == " " =
cs <> contactPrefix
cs <> chatPrefix
| otherwise = cs
insertChars = ts' . if p >= length s then append else insert
append cs = let s' = s <> cs in (s', length s')
insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs)
contactPrefix = case ac of
ActiveNone -> ""
ActiveC c -> "@" <> T.unpack c <> " "
ActiveG g -> "#" <> T.unpack g <> " "
backDeleteChar
| p == 0 || null s = ts
| p >= length s = ts' (init s, length s - 1)

3
src/Simplex/Chat/Terminal/Notification.hs
View file

@ -13,13 +13,14 @@ import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Chat.Types
import Simplex.Messaging.Util (catchAll_)
import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, getAppUserDataDirectory)
import System.FilePath (combine)
import System.Info (os)
import System.Process (readCreateProcess, shell)
data Notification = Notification {title :: Text, text :: Text}
initializeNotifications :: IO (Notification -> IO ())
initializeNotifications =
hideException <$> case os of

147
src/Simplex/Chat/Terminal/Output.hs
View file

@ -3,6 +3,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -14,14 +15,25 @@ import Control.Monad.Catch (MonadMask)
import Control.Monad.Except
import Control.Monad.Reader
import Data.List (intercalate)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Simplex.Chat (processChatCommand)
import Simplex.Chat.Controller
import Simplex.Chat.Messages hiding (NewChatItem (..))
import Simplex.Chat.Styled
import Simplex.Chat.View
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent (CIContent(..), SMsgDirection (..))
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
import Simplex.Chat.Remote.Types (RemoteHostId)
import Simplex.Chat.Styled
import Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications)
import Simplex.Chat.Types
import Simplex.Chat.View
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Util (safeDecodeUtf8)
import System.Console.ANSI.Types
import System.IO (IOMode (..), hPutStrLn, withFile)
import System.Mem.Weak (Weak)
@ -35,7 +47,9 @@ data ChatTerminal = ChatTerminal
termSize :: Size,
liveMessageState :: TVar (Maybe LiveMessage),
nextMessageRow :: TVar Int,
termLock :: TMVar ()
termLock :: TMVar (),
sendNotification :: Maybe (Notification -> IO ()),
activeTo :: TVar String
}
data TerminalState = TerminalState
@ -80,16 +94,28 @@ instance WithTerminal VirtualTerminal where
withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
withChatTerm ChatTerminal {termDevice = TerminalDevice t} action = withTerm t $ runTerminalT action
newChatTerminal :: WithTerminal t => t -> IO ChatTerminal
newChatTerminal t = do
newChatTerminal :: WithTerminal t => t -> ChatOpts -> IO ChatTerminal
newChatTerminal t opts = do
termSize <- withTerm t . runTerminalT $ getWindowSize
let lastRow = height termSize - 1
termState <- newTVarIO mkTermState
liveMessageState <- newTVarIO Nothing
termLock <- newTMVarIO ()
nextMessageRow <- newTVarIO lastRow
sendNotification <- if muteNotifications opts then pure Nothing else Just <$> initializeNotifications
activeTo <- newTVarIO ""
-- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
return ChatTerminal {termDevice = TerminalDevice t, termState, termSize, liveMessageState, nextMessageRow, termLock}
pure
ChatTerminal
{ termDevice = TerminalDevice t,
termState,
termSize,
liveMessageState,
nextMessageRow,
termLock,
sendNotification,
activeTo
}
mkTermState :: TerminalState
mkTermState =
@ -115,24 +141,119 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
forever $ do
(_, outputRH, r) <- atomically $ readTBQueue outputQ
case r of
CRNewChatItem _ ci -> markChatItemRead ci
CRChatItemUpdated _ ci -> markChatItemRead ci
CRNewChatItem u ci -> markChatItemRead u ci
CRChatItemUpdated u ci -> markChatItemRead u ci
_ -> pure ()
let printResp = case logFilePath of
Just path -> if logResponseToFile r then logResponse path else printToTerminal ct
_ -> printToTerminal ct
liveItems <- readTVarIO showLiveItems
responseString cc liveItems outputRH r >>= printResp
responseNotification ct cc r
where
markChatItemRead (AChatItem _ _ chat item@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
case (muted chat chatDir, itemStatus) of
(False, CISRcvNew) -> do
let itemId = chatItemId' item
markChatItemRead u (AChatItem _ _ chat ci@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
case (chatDirNtf u chat chatDir (isMention ci), itemStatus) of
(True, CISRcvNew) -> do
let itemId = chatItemId' ci
chatRef = chatInfoToRef chat
void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc
_ -> pure ()
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
responseNotification t@ChatTerminal {sendNotification} cc = \case
CRNewChatItem u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) ->
when (chatDirNtf u cInfo chatDir $ isMention ci) $ do
whenCurrUser cc u $ setActiveChat t cInfo
case (cInfo, chatDir) of
(DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text)
(GroupChat g, CIGroupRcv m) -> sendNtf (fromGroup_ g m, text)
_ -> pure ()
where
text = msgText mc formattedText
CRChatItemUpdated u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent _}) ->
whenCurrUser cc u $ when (chatDirNtf u cInfo chatDir $ isMention ci) $ setActiveChat t cInfo
CRContactConnected u ct _ -> when (contactNtf u ct False) $ do
whenCurrUser cc u $ setActiveContact t ct
sendNtf (viewContactName ct <> "> ", "connected")
CRContactAnotherClient u ct -> do
whenCurrUser cc u $ unsetActiveContact t ct
when (contactNtf u ct False) $ sendNtf (viewContactName ct <> "> ", "connected to another client")
CRContactsDisconnected srv _ -> serverNtf srv "disconnected"
CRContactsSubscribed srv _ -> serverNtf srv "connected"
CRReceivedGroupInvitation u g ct _ _ ->
when (contactNtf u ct False) $
sendNtf ("#" <> viewGroupName g <> " " <> viewContactName ct <> "> ", "invited you to join the group")
CRUserJoinedGroup u g _ -> when (groupNtf u g False) $ do
whenCurrUser cc u $ setActiveGroup t g
sendNtf ("#" <> viewGroupName g, "you are connected to group")
CRJoinedGroupMember u g m ->
when (groupNtf u g False) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected")
CRConnectedToGroupMember u g m _ ->
when (groupNtf u g False) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected")
CRReceivedContactRequest u UserContactRequest {localDisplayName = n} ->
when (userNtf u) $ sendNtf (viewName n <> ">", "wants to connect to you")
_ -> pure ()
where
sendNtf = maybe (\_ -> pure ()) (. uncurry Notification) sendNotification
serverNtf (SMPServer host _ _) str = sendNtf ("server " <> str, safeDecodeUtf8 $ strEncode host)
msgText :: MsgContent -> Maybe MarkdownList -> Text
msgText (MCFile _) _ = "wants to send a file"
msgText mc md_ = maybe (msgContentText mc) (mconcat . map hideSecret) md_
where
hideSecret :: FormattedText -> Text
hideSecret FormattedText {format = Just Secret} = "..."
hideSecret FormattedText {text} = text
chatActiveTo :: ChatName -> String
chatActiveTo (ChatName cType name) = case cType of
CTDirect -> T.unpack $ "@" <> viewName name <> " "
CTGroup -> T.unpack $ "#" <> viewName name <> " "
_ -> ""
chatInfoActiveTo :: ChatInfo c -> String
chatInfoActiveTo = \case
DirectChat c -> contactActiveTo c
GroupChat g -> groupActiveTo g
_ -> ""
contactActiveTo :: Contact -> String
contactActiveTo c = T.unpack $ "@" <> viewContactName c <> " "
groupActiveTo :: GroupInfo -> String
groupActiveTo g = T.unpack $ "#" <> viewGroupName g <> " "
setActiveChat :: ChatTerminal -> ChatInfo c -> IO ()
setActiveChat t = setActive t . chatInfoActiveTo
setActiveContact :: ChatTerminal -> Contact -> IO ()
setActiveContact t = setActive t . contactActiveTo
setActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
setActiveGroup t = setActive t . groupActiveTo
setActive :: ChatTerminal -> String -> IO ()
setActive ChatTerminal {activeTo} to = atomically $ writeTVar activeTo to
unsetActiveContact :: ChatTerminal -> Contact -> IO ()
unsetActiveContact t = unsetActive t . contactActiveTo
unsetActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
unsetActiveGroup t = unsetActive t . groupActiveTo
unsetActive :: ChatTerminal -> String -> IO ()
unsetActive ChatTerminal {activeTo} to' = atomically $ modifyTVar activeTo unset
where
unset to = if to == to' then "" else to
whenCurrUser :: ChatController -> User -> IO () -> IO ()
whenCurrUser cc u a = do
u_ <- readTVarIO $ currentUser cc
when (sameUser u u_) a
where
sameUser User {userId = uId} = maybe False $ \User {userId} -> userId == uId
printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> ChatResponse -> IO ()
printRespToTerminal ct cc liveItems outputRH r = responseString cc liveItems outputRH r >>= printToTerminal ct

71
src/Simplex/Chat/Types.hs
View file

@ -39,7 +39,11 @@ import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Database.SQLite.Simple.FromField (FromField (..))
import Data.Typeable (Typeable)
import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (returnError, FromField(..))
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic)
import Simplex.Chat.Types.Preferences
@ -48,7 +52,7 @@ import Simplex.FileTransfer.Description (FileDigest)
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON)
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
import Simplex.Messaging.Util ((<$?>))
import Simplex.Messaging.Version
@ -194,6 +198,9 @@ directOrUsed ct@Contact {contactUsed} =
anyDirectOrUsed :: Contact -> Bool
anyDirectOrUsed Contact {contactUsed, activeConn = Connection {connLevel}} = connLevel == 0 || contactUsed
contactReady :: Contact -> Bool
contactReady Contact {activeConn} = connReady activeConn
contactActive :: Contact -> Bool
contactActive Contact {contactStatus} = contactStatus == CSActive
@ -369,7 +376,7 @@ 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 :: MsgFilter,
sendRcpts :: Maybe Bool,
favorite :: Bool
}
@ -380,13 +387,48 @@ instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOpt
defaultChatSettings :: ChatSettings
defaultChatSettings =
ChatSettings
{ enableNtfs = True,
{ enableNtfs = MFAll,
sendRcpts = Nothing,
favorite = False
}
pattern DisableNtfs :: ChatSettings
pattern DisableNtfs <- ChatSettings {enableNtfs = False}
chatHasNtfs :: ChatSettings -> Bool
chatHasNtfs ChatSettings {enableNtfs} = enableNtfs /= MFNone
data MsgFilter = MFNone | MFAll | MFMentions
deriving (Eq, Show, Generic)
instance FromJSON MsgFilter where
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MF"
instance ToJSON MsgFilter where
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MF"
toJSON = J.genericToJSON . enumJSON $ dropPrefix "MF"
instance FromField MsgFilter where fromField = fromIntField_ msgFilterIntP
instance ToField MsgFilter where toField = toField . msgFilterInt
msgFilterInt :: MsgFilter -> Int
msgFilterInt = \case
MFNone -> 0
MFAll -> 1
MFMentions -> 2
msgFilterIntP :: Int64 -> Maybe MsgFilter
msgFilterIntP = \case
0 -> Just MFNone
1 -> Just MFAll
2 -> Just MFMentions
_ -> Just MFAll
fromIntField_ :: Typeable a => (Int64 -> Maybe a) -> Field -> Ok a
fromIntField_ fromInt = \case
f@(Field (SQLInteger i) _) ->
case fromInt i of
Just x -> Ok x
_ -> returnError ConversionFailed f ("invalid integer: " <> show i)
f -> returnError ConversionFailed f "expecting SQLInteger column type"
featureAllowed :: SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool
featureAllowed feature forWhom Contact {mergedPreferences} =
@ -614,6 +656,7 @@ data GroupMember = GroupMember
memberRole :: GroupMemberRole,
memberCategory :: GroupMemberCategory,
memberStatus :: GroupMemberStatus,
memberSettings :: GroupMemberSettings,
invitedBy :: InvitedBy,
localDisplayName :: ContactName,
-- for membership, memberProfile can be either user's profile or incognito profile, based on memberIncognito test.
@ -751,6 +794,16 @@ instance ToJSON GroupMemberRole where
toJSON = strToJSON
toEncoding = strToJEncoding
data GroupMemberSettings = GroupMemberSettings
{ showMessages :: Bool
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON GroupMemberSettings where toEncoding = J.genericToEncoding J.defaultOptions
defaultMemberSettings :: GroupMemberSettings
defaultMemberSettings = GroupMemberSettings {showMessages = True}
newtype Probe = Probe {unProbe :: ByteString}
deriving (Eq, Show)
@ -1261,6 +1314,9 @@ data Connection = Connection
}
deriving (Eq, Show, Generic)
connReady :: Connection -> Bool
connReady Connection {connStatus} = connStatus == ConnReady || connStatus == ConnSndReady
authErrDisableCount :: Int
authErrDisableCount = 10
@ -1442,9 +1498,6 @@ serializeIntroStatus = \case
GMIntroToConnected -> "to-con"
GMIntroConnected -> "con"
data Notification = Notification {title :: Text, text :: Text}
deriving (Show, Generic, FromJSON, ToJSON)
textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a
textParseJSON name = J.withText name $ maybe (fail $ "bad " <> name) pure . textDecode

172
src/Simplex/Chat/View.hs
View file

@ -73,10 +73,10 @@ responseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> Curr
responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz outputRH = \case
CRActiveUser User {profile} -> viewUserProfile $ fromLocalProfile profile
CRUsersList users -> viewUsersList users
CRChatStarted _ -> ["chat started"]
CRChatRunning _ -> ["chat is running"]
CRChatStopped _ -> ["chat stopped"]
CRChatSuspended _ -> ["chat suspended"]
CRChatStarted -> ["chat started"]
CRChatRunning -> ["chat is running"]
CRChatStopped -> ["chat stopped"]
CRChatSuspended -> ["chat suspended"]
CRApiChats u chats -> ttyUser u $ if testView then testViewChats chats else [plain . bshow $ J.encode chats]
CRChats chats -> viewChats ts tz chats
CRApiChat u chat -> ttyUser u $ if testView then testViewChat chat else [plain . bshow $ J.encode chat]
@ -103,15 +103,15 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei
CRConnectionVerified u verified code -> ttyUser u [plain $ if verified then "connection verified" else "connection not verified, current code is " <> code]
CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView
CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView
CRNewChatItem u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewChatItem chat item False ts tz <> viewItemReactions item
CRChatItems u chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems
CRNewChatItem u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewChatItem chat item False ts tz <> viewItemReactions item
CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems
CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz
CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId]
CRChatItemStatusUpdated u ci -> ttyUser u $ viewChatItemStatusUpdated ci ts tz testView showReceipts
CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewItemUpdate chat item liveItems ts tz
CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewItemUpdate chat item liveItems ts tz
CRChatItemNotChanged u ci -> ttyUser u $ viewItemNotChanged ci
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
CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted u chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView
CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction u 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 s f t -> ttyUser u $ viewSentBroadcast mc s f ts tz t
CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr
@ -149,6 +149,7 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei
CRVersionInfo info _ _ -> viewVersionInfo logLevel info
CRInvitation u cReq _ -> ttyUser u $ viewConnReqInvitation cReq
CRConnectionIncognitoUpdated u c -> ttyUser u $ viewConnectionIncognitoUpdated c
CRConnectionPlan u connectionPlan -> ttyUser u $ viewConnectionPlan connectionPlan
CRSentConfirmation u -> ttyUser u ["confirmation sent!"]
CRSentInvitation u customUserProfile -> ttyUser u $ viewSentInvitation customUserProfile testView
CRContactDeleted u c -> ttyUser u [ttyContact' c <> ": contact is deleted"]
@ -267,14 +268,14 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei
CRRemoteHostDeleted rhId -> ["remote host " <> sShow rhId <> " deleted"]
CRRemoteCtrlList cs -> viewRemoteCtrls cs
CRRemoteCtrlRegistered rcId -> ["remote controller " <> sShow rcId <> " registered"]
CRRemoteCtrlStarted _ -> ["remote controller started"]
CRRemoteCtrlStarted -> ["remote controller started"]
CRRemoteCtrlAnnounce fingerprint -> ["remote controller announced", "connection code:", plain $ strEncode fingerprint]
CRRemoteCtrlFound rc -> ["remote controller found:", viewRemoteCtrl rc]
CRRemoteCtrlAccepted rcId -> ["remote controller " <> sShow rcId <> " accepted"]
CRRemoteCtrlRejected rcId -> ["remote controller " <> sShow rcId <> " rejected"]
CRRemoteCtrlConnecting rcId rcName -> ["remote controller " <> sShow rcId <> " connecting to " <> plain rcName]
CRRemoteCtrlConnected rcId rcName -> ["remote controller " <> sShow rcId <> " connected, " <> plain rcName]
CRRemoteCtrlStopped _ -> ["remote controller stopped"]
CRRemoteCtrlStopped -> ["remote controller stopped"]
CRRemoteCtrlDeleted rcId -> ["remote controller " <> sShow rcId <> " deleted"]
CRSQLResult rows -> map plain rows
CRSlowSQLQueries {chatQueries, agentQueries} ->
@ -368,24 +369,56 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei
viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)]
contactList :: [ContactRef] -> String
contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs
unmuted :: ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
unmuted chat ChatItem {chatDir} = unmuted' chat chatDir
unmutedReaction :: ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString]
unmutedReaction chat CIReaction {chatDir} = unmuted' chat chatDir
unmuted' :: ChatInfo c -> CIDirection c d -> [StyledString] -> [StyledString]
unmuted' chat chatDir s
| muted chat chatDir = []
| otherwise = s
unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isMention ci
unmutedReaction :: User -> ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString]
unmutedReaction u chat CIReaction {chatDir} = unmuted' u chat chatDir False
unmuted' :: User -> ChatInfo c -> CIDirection c d -> Bool -> [StyledString] -> [StyledString]
unmuted' u chat chatDir mention s
| chatDirNtf u chat chatDir mention = s
| otherwise = []
userNtf :: User -> Bool
userNtf User {showNtfs, activeUser} = showNtfs || activeUser
chatNtf :: User -> ChatInfo c -> Bool -> Bool
chatNtf user cInfo mention = case cInfo of
DirectChat ct -> contactNtf user ct mention
GroupChat g -> groupNtf user g mention
_ -> False
chatDirNtf :: User -> ChatInfo c -> CIDirection c d -> Bool -> Bool
chatDirNtf user cInfo chatDir mention = case (cInfo, chatDir) of
(DirectChat ct, CIDirectRcv) -> contactNtf user ct mention
(GroupChat g, CIGroupRcv m) -> groupNtf user g mention && showMessages (memberSettings m)
_ -> True
contactNtf :: User -> Contact -> Bool -> Bool
contactNtf user Contact {chatSettings} mention =
userNtf user && showMessageNtf chatSettings mention
groupNtf :: User -> GroupInfo -> Bool -> Bool
groupNtf user GroupInfo {chatSettings} mention =
userNtf user && showMessageNtf chatSettings mention
showMessageNtf :: ChatSettings -> Bool -> Bool
showMessageNtf ChatSettings {enableNtfs} mention =
enableNtfs == MFAll || (mention && enableNtfs == MFMentions)
chatItemDeletedText :: ChatItem c d -> Maybe GroupMember -> Maybe Text
chatItemDeletedText ci membership_ = deletedStateToText <$> chatItemDeletedState ci
chatItemDeletedText ChatItem {meta = CIMeta {itemDeleted}, content} membership_ =
deletedText <$> itemDeleted
where
deletedStateToText = \CIDeletedState {markedDeleted, deletedByMember} ->
if markedDeleted
then "marked deleted" <> byMember deletedByMember
else "deleted" <> byMember deletedByMember
byMember m_ = case (m_, membership_) of
(Just GroupMember {groupMemberId = mId, localDisplayName = n}, Just GroupMember {groupMemberId = membershipId}) ->
deletedText = \case
CIModerated _ m -> markedDeleted content <> byMember m
CIDeleted _ -> markedDeleted content
CIBlocked _ -> "blocked"
markedDeleted = \case
CISndModerated -> "deleted"
CIRcvModerated -> "deleted"
_ -> "marked deleted"
byMember GroupMember {groupMemberId = mId, localDisplayName = n} = case membership_ of
Just GroupMember {groupMemberId = membershipId} ->
" by " <> if mId == membershipId then "you" else n
_ -> ""
@ -404,12 +437,6 @@ viewUsersList = mapMaybe userInfo . sortOn ldn
<> ["muted" | not showNtfs]
<> [plain ("unread: " <> show count) | count /= 0]
muted :: ChatInfo c -> CIDirection c d -> Bool
muted chat chatDir = case (chat, chatDir) of
(DirectChat Contact {chatSettings = DisableNtfs}, CIDirectRcv) -> True
(GroupChat GroupInfo {chatSettings = DisableNtfs}, CIGroupRcv _) -> True
_ -> False
viewGroupSubscribed :: GroupInfo -> [StyledString]
viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"]
@ -711,7 +738,7 @@ viewContactsList =
in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
where
muted' Contact {chatSettings, localDisplayName = ldn}
| enableNtfs chatSettings = ""
| chatHasNtfs chatSettings = ""
| otherwise = " (muted, you can " <> highlight ("/unmute @" <> ldn) <> ")"
alias Contact {profile = LocalProfile {localAlias}}
| localAlias == "" = ""
@ -844,22 +871,25 @@ viewGroupMembers :: Group -> [StyledString]
viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filter (not . removedOrLeft) $ membership : members
where
removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft
groupMember m = memIncognito m <> ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m
role :: GroupMember -> StyledString
role m = plain . strEncode $ m.memberRole
groupMember m = memIncognito m <> ttyFullMember m <> ": " <> plain (intercalate ", " $ [role m] <> category m <> status m <> muted m)
role :: GroupMember -> String
role m = B.unpack . strEncode $ m.memberRole
category m = case memberCategory m of
GCUserMember -> "you, "
GCInviteeMember -> "invited, "
GCHostMember -> "host, "
_ -> ""
GCUserMember -> ["you"]
GCInviteeMember -> ["invited"]
GCHostMember -> ["host"]
_ -> []
status m = case memberStatus m of
GSMemRemoved -> "removed"
GSMemLeft -> "left"
GSMemInvited -> "not yet joined"
GSMemConnected -> "connected"
GSMemComplete -> "connected"
GSMemCreator -> "created group"
_ -> ""
GSMemRemoved -> ["removed"]
GSMemLeft -> ["left"]
GSMemInvited -> ["not yet joined"]
GSMemConnected -> ["connected"]
GSMemComplete -> ["connected"]
GSMemCreator -> ["created group"]
_ -> []
muted m
| showMessages (memberSettings m) = []
| otherwise = ["blocked"]
viewContactConnected :: Contact -> Maybe Profile -> Bool -> [StyledString]
viewContactConnected ct userIncognitoProfile testView =
@ -882,7 +912,7 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
where
ldn_ :: GroupInfo -> Text
ldn_ g = T.toLower g.localDisplayName
groupSS (g@GroupInfo {membership, chatSettings}, GroupSummary {currentMembers}) =
groupSS (g@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}}, GroupSummary {currentMembers}) =
case memberStatus membership of
GSMemInvited -> groupInvitation' g
s -> membershipIncognito g <> ttyFullGroup g <> viewMemberStatus s
@ -891,9 +921,13 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
GSMemRemoved -> delete "you are removed"
GSMemLeft -> delete "you left"
GSMemGroupDeleted -> delete "group deleted"
_
| enableNtfs chatSettings -> " (" <> memberCount <> ")"
| otherwise -> " (" <> memberCount <> ", muted, you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")"
_ -> " (" <> memberCount <>
case enableNtfs of
MFAll -> ")"
MFNone -> ", muted, " <> unmute
MFMentions -> ", mentions only, " <> unmute
where
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")"
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")"
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"
@ -1243,6 +1277,41 @@ viewConnectionIncognitoUpdated PendingContactConnection {pccConnId, customUserPr
| isJust customUserProfileId = ["connection " <> sShow pccConnId <> " changed to incognito"]
| otherwise = ["connection " <> sShow pccConnId <> " changed to non incognito"]
viewConnectionPlan :: ConnectionPlan -> [StyledString]
viewConnectionPlan = \case
CPInvitationLink ilp -> case ilp of
ILPOk -> [invLink "ok to connect"]
ILPOwnLink -> [invLink "own link"]
ILPConnecting Nothing -> [invLink "connecting"]
ILPConnecting (Just ct) -> [invLink ("connecting to contact " <> ttyContact' ct)]
ILPKnown ct ->
[ invLink ("known contact " <> ttyContact' ct),
"use " <> ttyToContact' ct <> highlight' "<message>" <> " to send messages"
]
where
invLink = ("invitation link: " <>)
CPContactAddress cap -> case cap of
CAPOk -> [ctAddr "ok to connect"]
CAPOwnLink -> [ctAddr "own address"]
CAPConnecting ct -> [ctAddr ("connecting to contact " <> ttyContact' ct)]
CAPKnown ct ->
[ ctAddr ("known contact " <> ttyContact' ct),
"use " <> ttyToContact' ct <> highlight' "<message>" <> " to send messages"
]
where
ctAddr = ("contact address: " <>)
CPGroupLink glp -> case glp of
GLPOk -> [grpLink "ok to connect"]
GLPOwnLink g -> [grpLink "own link for group " <> ttyGroup' g]
GLPConnecting Nothing -> [grpLink "connecting"]
GLPConnecting (Just g) -> [grpLink ("connecting to group " <> ttyGroup' g)]
GLPKnown g ->
[ grpLink ("known group " <> ttyGroup' g),
"use " <> ttyToGroup g <> highlight' "<message>" <> " to send messages"
]
where
grpLink = ("group link: " <>)
viewContactUpdated :: Contact -> Contact -> [StyledString]
viewContactUpdated
Contact {localDisplayName = n, profile = LocalProfile {fullName, contactLink}}
@ -1610,6 +1679,7 @@ viewChatError logLevel = \case
CEChatNotStarted -> ["error: chat not started"]
CEChatNotStopped -> ["error: chat not stopped"]
CEChatStoreChanged -> ["error: chat store changed, please restart chat"]
CEConnectionPlan connectionPlan -> viewConnectionPlan connectionPlan
CEInvalidConnReq -> viewInvalidConnReq
CEInvalidChatMessage Connection {connId} msgMeta_ msg e ->
[ plain $

2
tests/Bots/BroadcastTests.hs
View file

@ -26,7 +26,7 @@ withBroadcastBot :: BroadcastBotOpts -> IO () -> IO ()
withBroadcastBot opts test =
bracket (forkIO bot) killThread (\_ -> threadDelay 500000 >> test)
where
bot = simplexChatCore testCfg (mkChatOpts opts) Nothing $ broadcastBot opts
bot = simplexChatCore testCfg (mkChatOpts opts) $ broadcastBot opts
broadcastBotProfile :: Profile
broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", image = Nothing, contactLink = Nothing, preferences = Nothing}

2
tests/Bots/DirectoryTests.hs
View file

@ -827,7 +827,7 @@ runDirectory cfg opts@DirectoryOpts {directoryLog} action = do
threadDelay 500000
action `finally` (mapM_ hClose (directoryLogFile st) >> killThread t)
where
bot st = simplexChatCore cfg (mkChatOpts opts) Nothing $ directoryService st opts
bot st = simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts
registerGroup :: TestCC -> TestCC -> String -> String -> IO ()
registerGroup su u n fn = registerGroupId su u n fn 1 1

6
tests/ChatClient.hs
View file

@ -161,8 +161,8 @@ startTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefi
startTestChat_ :: ChatDatabase -> ChatConfig -> ChatOpts -> User -> IO TestCC
startTestChat_ db cfg opts user = do
t <- withVirtualTerminal termSettings pure
ct <- newChatTerminal t
cc <- newChatController db (Just user) cfg opts Nothing -- no notifications
ct <- newChatTerminal t opts
cc <- newChatController db (Just user) cfg opts
chatAsync <- async . runSimplexChat opts user cc . const $ runChatTerminal ct
atomically . unless (maintenance opts) $ readTVar (agentAsync cc) >>= \a -> when (isNothing a) retry
termQ <- newTQueueIO
@ -210,6 +210,8 @@ withTestChatOpts tmp = withTestChatCfgOpts tmp testCfg
withTestChatCfgOpts :: HasCallStack => FilePath -> ChatConfig -> ChatOpts -> String -> (HasCallStack => TestCC -> IO a) -> IO a
withTestChatCfgOpts tmp cfg opts dbPrefix = bracket (startTestChat tmp cfg opts dbPrefix) (\cc -> cc <// 100000 >> stopTestChat cc)
-- enable output for specific chat controller, use like this:
-- withNewTestChat tmp "alice" aliceProfile $ \a -> withTestOutput a $ \alice -> do ...
withTestOutput :: HasCallStack => TestCC -> (HasCallStack => TestCC -> IO a) -> IO a
withTestOutput cc runTest = runTest cc {printOutput = True}

138
tests/ChatTests/Direct.hs
View file

@ -44,6 +44,10 @@ chatDirectTests = do
describe "duplicate contacts" $ do
it "duplicate contacts are separate (contacts don't merge)" testDuplicateContactsSeparate
it "new contact is separate with multiple duplicate contacts (contacts don't merge)" testDuplicateContactsMultipleSeparate
describe "invitation link connection plan" $ do
it "invitation link ok to connect" testPlanInvitationLinkOk
it "own invitation link" testPlanInvitationLinkOwn
it "connecting via invitation link" testPlanInvitationLinkConnecting
describe "SMP servers" $ do
it "get and set SMP servers" testGetSetSMPServers
it "test SMP server connection" testTestSMPServerConnection
@ -66,7 +70,7 @@ chatDirectTests = do
it "should not subscribe in NSE and subscribe in the app" testSubscribeAppNSE
describe "mute/unmute messages" $ do
it "mute/unmute contact" testMuteContact
it "mute/unmute group" testMuteGroup
it "mute/unmute group and member" testMuteGroup
describe "multiple users" $ do
it "create second user" testCreateSecondUser
it "multiple users subscribe and receive messages after restart" testUsersSubscribeAfterRestart
@ -236,6 +240,69 @@ testDuplicateContactsMultipleSeparate =
alice `hasContactProfiles` ["alice", "bob", "bob", "bob"]
bob `hasContactProfiles` ["bob", "alice", "alice", "alice"]
testPlanInvitationLinkOk :: HasCallStack => FilePath -> IO ()
testPlanInvitationLinkOk =
testChat2 aliceProfile bobProfile $
\alice bob -> do
alice ##> "/c"
inv <- getInvitation alice
bob ##> ("/_connect plan 1 " <> inv)
bob <## "invitation link: ok to connect"
bob ##> ("/c " <> inv)
bob <## "confirmation sent!"
concurrently_
(alice <## "bob (Bob): contact is connected")
(bob <## "alice (Alice): contact is connected")
bob ##> ("/_connect plan 1 " <> inv)
bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
alice <##> bob
testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO ()
testPlanInvitationLinkOwn tmp =
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
alice ##> "/c"
inv <- getInvitation alice
alice ##> ("/_connect plan 1 " <> inv)
alice <## "invitation link: own link"
alice ##> ("/c " <> inv)
alice <## "confirmation sent!"
alice
<### [ "alice_1 (Alice): contact is connected",
"alice_2 (Alice): contact is connected"
]
alice ##> ("/_connect plan 1 " <> inv)
alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)]
alice `send` "@alice_2 hi"
alice
<### [ WithTime "@alice_2 hi",
WithTime "alice_1> hi"
]
alice `send` "@alice_1 hey"
alice
<### [ WithTime "@alice_1 hey",
WithTime "alice_2> hey"
]
alice @@@ [("@alice_1", "hey"), ("@alice_2", "hey")]
testPlanInvitationLinkConnecting :: HasCallStack => FilePath -> IO ()
testPlanInvitationLinkConnecting tmp = do
inv <- withNewTestChat tmp "alice" aliceProfile $ \alice -> do
alice ##> "/c"
getInvitation alice
withNewTestChat tmp "bob" bobProfile $ \bob -> do
bob ##> ("/c " <> inv)
bob <## "confirmation sent!"
bob ##> ("/_connect plan 1 " <> inv)
bob <## "invitation link: connecting"
testContactClear :: HasCallStack => FilePath -> IO ()
testContactClear =
testChat2 aliceProfile bobProfile $
@ -1129,14 +1196,79 @@ testMuteGroup =
concurrently_
(bob </)
(cath <# "#team alice> hi")
bob #> "#team hello"
concurrently_
(alice <# "#team bob> hello")
(cath <# "#team bob> hello")
cath `send` "> #team (hello) hello too!"
cath <# "#team > bob hello"
cath <## " hello too!"
concurrently_
(bob </)
( do alice <# "#team cath> > bob hello"
alice <## " hello too!"
)
bob ##> "/unmute mentions #team"
bob <## "ok"
alice `send` "> #team @bob (hello) hey bob!"
alice <# "#team > bob hello"
alice <## " hey bob!"
concurrently_
( do bob <# "#team alice> > bob hello"
bob <## " hey bob!"
)
( do cath <# "#team alice> > bob hello"
cath <## " hey bob!"
)
alice `send` "> #team @cath (hello) hey cath!"
alice <# "#team > cath hello too!"
alice <## " hey cath!"
concurrently_
(bob </)
( do cath <# "#team alice> > cath hello too!"
cath <## " hey cath!"
)
bob ##> "/gs"
bob <## "#team (3 members, muted, you can /unmute #team)"
bob <## "#team (3 members, mentions only, you can /unmute #team)"
bob ##> "/unmute #team"
bob <## "ok"
alice #> "#team hi again"
concurrently_
(bob <# "#team alice> hi again")
(cath <# "#team alice> hi again")
bob ##> "/block #team alice"
bob <## "ok"
bob ##> "/ms team"
bob <## "bob (Bob): admin, you, connected"
bob <## "alice (Alice): owner, host, connected, blocked"
bob <## "cath (Catherine): admin, connected"
alice #> "#team test 1"
concurrently_
(bob </)
(cath <# "#team alice> test 1")
cath #> "#team test 2"
concurrently_
(bob <# "#team cath> test 2")
(alice <# "#team cath> test 2")
bob ##> "/tail #team 3"
bob <# "#team alice> hi again"
bob <# "#team alice> test 1 [blocked]"
bob <# "#team cath> test 2"
threadDelay 1000000
bob ##> "/unblock #team alice"
bob <## "ok"
bob ##> "/ms team"
bob <## "bob (Bob): admin, you, connected"
bob <## "alice (Alice): owner, host, connected"
bob <## "cath (Catherine): admin, connected"
alice #> "#team test 3"
concurrently_
(bob <# "#team alice> test 3")
(cath <# "#team alice> test 3")
cath #> "#team test 4"
concurrently_
(bob <# "#team cath> test 4")
(alice <# "#team cath> test 4")
bob ##> "/gs"
bob <## "#team (3 members)"
@ -1870,7 +2002,7 @@ testUserPrivacy =
-- shows hidden user when active
alice ##> "/users"
alice <## "alice (Alice)"
alice <## "alisa (active, hidden, muted)"
alice <## "alisa (active, hidden, muted, unread: 1)"
-- hidden message is saved
alice ##> "/tail"
alice <##? chatHistory

248
tests/ChatTests/Groups.hs
View file

@ -57,6 +57,12 @@ chatGroupTests = do
it "leaving groups with unused host contacts deletes incognito profiles" testGroupLinkIncognitoUnusedHostContactsDeleted
it "group link member role" testGroupLinkMemberRole
it "leaving and deleting the group joined via link should NOT delete previously existing direct contacts" testGroupLinkLeaveDelete
describe "group link connection plan" $ do
it "group link ok to connect; known group" testPlanGroupLinkOkKnown
it "group is known if host contact was deleted" testPlanHostContactDeletedGroupLinkKnown
it "own group link" testPlanGroupLinkOwn
it "connecting via group link" testPlanGroupLinkConnecting
it "re-join existing group after leaving" testPlanGroupLinkLeaveRejoin
describe "group message errors" $ do
it "show message decryption error" testGroupMsgDecryptError
it "should report ratchet de-synchronization, synchronize ratchets" testGroupSyncRatchet
@ -1532,7 +1538,6 @@ testGroupDelayedModerationFullDelete tmp = do
testGroupAsync :: HasCallStack => FilePath -> IO ()
testGroupAsync tmp = do
print (0 :: Integer)
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
connectUsers alice bob
@ -2251,6 +2256,237 @@ testGroupLinkLeaveDelete =
bob <## "alice (Alice)"
bob <## "cath (Catherine)"
testPlanGroupLinkOkKnown :: HasCallStack => FilePath -> IO ()
testPlanGroupLinkOkKnown =
testChat2 aliceProfile bobProfile $
\alice bob -> do
alice ##> "/g team"
alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team"
alice ##> "/create link #team"
gLink <- getGroupLink alice "team" GRMember True
bob ##> ("/_connect plan 1 " <> gLink)
bob <## "group link: ok to connect"
bob ##> ("/c " <> gLink)
bob <## "connection request sent!"
alice <## "bob (Bob): accepting request to join group #team..."
concurrentlyN_
[ do
alice <## "bob (Bob): contact is connected"
alice <## "bob invited to group #team via your group link"
alice <## "#team: bob joined the group",
do
bob <## "alice (Alice): contact is connected"
bob <## "#team: you joined the group"
]
alice #> "#team hi"
bob <# "#team alice> hi"
bob #> "#team hey"
alice <# "#team bob> hey"
bob ##> ("/_connect plan 1 " <> gLink)
bob <## "group link: known group #team"
bob <## "use #team <message> to send messages"
bob ##> ("/c " <> gLink)
bob <## "group link: known group #team"
bob <## "use #team <message> to send messages"
testPlanHostContactDeletedGroupLinkKnown :: HasCallStack => FilePath -> IO ()
testPlanHostContactDeletedGroupLinkKnown =
testChat2 aliceProfile bobProfile $
\alice bob -> do
alice ##> "/g team"
alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team"
alice ##> "/create link #team"
gLink <- getGroupLink alice "team" GRMember True
bob ##> ("/c " <> gLink)
bob <## "connection request sent!"
alice <## "bob (Bob): accepting request to join group #team..."
concurrentlyN_
[ do
alice <## "bob (Bob): contact is connected"
alice <## "bob invited to group #team via your group link"
alice <## "#team: bob joined the group",
do
bob <## "alice (Alice): contact is connected"
bob <## "#team: you joined the group"
]
alice #> "#team hi"
bob <# "#team alice> hi"
bob #> "#team hey"
alice <# "#team bob> hey"
alice <##> bob
threadDelay 500000
bob ##> "/d alice"
bob <## "alice: contact is deleted"
alice <## "bob (Bob) deleted contact with you"
bob ##> ("/_connect plan 1 " <> gLink)
bob <## "group link: known group #team"
bob <## "use #team <message> to send messages"
bob ##> ("/c " <> gLink)
bob <## "group link: known group #team"
bob <## "use #team <message> to send messages"
testPlanGroupLinkOwn :: HasCallStack => FilePath -> IO ()
testPlanGroupLinkOwn tmp =
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
alice ##> "/g team"
alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team"
alice ##> "/create link #team"
gLink <- getGroupLink alice "team" GRMember True
alice ##> ("/_connect plan 1 " <> gLink)
alice <## "group link: own link for group #team"
alice ##> ("/c " <> gLink)
alice <## "connection request sent!"
alice <## "alice_1 (Alice): accepting request to join group #team..."
alice
<### [ "alice_1 (Alice): contact is connected",
"alice_1 invited to group #team via your group link",
"#team: alice_1 joined the group",
"alice_2 (Alice): contact is connected",
"#team_1: you joined the group",
"contact alice_2 is merged into alice_1",
"use @alice_1 <message> to send messages"
]
alice `send` "#team 1"
alice
<### [ WithTime "#team 1",
WithTime "#team_1 alice_1> 1"
]
alice `send` "#team_1 2"
alice
<### [ WithTime "#team_1 2",
WithTime "#team alice_1> 2"
]
alice ##> ("/_connect plan 1 " <> gLink)
alice <## "group link: own link for group #team"
-- group works if merged contact is deleted
alice ##> "/d alice_1"
alice <## "alice_1: contact is deleted"
alice `send` "#team 3"
alice
<### [ WithTime "#team 3",
WithTime "#team_1 alice_1> 3"
]
alice `send` "#team_1 4"
alice
<### [ WithTime "#team_1 4",
WithTime "#team alice_1> 4"
]
testPlanGroupLinkConnecting :: HasCallStack => FilePath -> IO ()
testPlanGroupLinkConnecting tmp = do
gLink <- withNewTestChat tmp "alice" aliceProfile $ \alice -> do
alice ##> "/g team"
alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team"
alice ##> "/create link #team"
getGroupLink alice "team" GRMember True
withNewTestChat tmp "bob" bobProfile $ \bob -> do
bob ##> ("/c " <> gLink)
bob <## "connection request sent!"
withTestChat tmp "alice" $ \alice -> do
alice
<### [ "1 group links active",
"#team: group is empty",
"bob (Bob): accepting request to join group #team..."
]
withTestChat tmp "bob" $ \bob -> do
threadDelay 500000
bob ##> ("/_connect plan 1 " <> gLink)
bob <## "group link: connecting"
bob ##> ("/c " <> gLink)
bob <## "group link: connecting"
testPlanGroupLinkLeaveRejoin :: HasCallStack => FilePath -> IO ()
testPlanGroupLinkLeaveRejoin =
testChat2 aliceProfile bobProfile $
\alice bob -> do
alice ##> "/g team"
alice <## "group #team is created"
alice <## "to add members use /a team <name> or /create link #team"
alice ##> "/create link #team"
gLink <- getGroupLink alice "team" GRMember True
bob ##> ("/c " <> gLink)
bob <## "connection request sent!"
alice <## "bob (Bob): accepting request to join group #team..."
concurrentlyN_
[ do
alice <## "bob (Bob): contact is connected"
alice <## "bob invited to group #team via your group link"
alice <## "#team: bob joined the group",
do
bob <## "alice (Alice): contact is connected"
bob <## "#team: you joined the group"
]
bob ##> ("/_connect plan 1 " <> gLink)
bob <## "group link: known group #team"
bob <## "use #team <message> to send messages"
bob ##> ("/c " <> gLink)
bob <## "group link: known group #team"
bob <## "use #team <message> to send messages"
bob ##> "/leave #team"
concurrentlyN_
[ do
bob <## "#team: you left the group"
bob <## "use /d #team to delete the group",
alice <## "#team: bob left the group"
]
bob ##> ("/_connect plan 1 " <> gLink)
bob <## "group link: ok to connect"
bob ##> ("/c " <> gLink)
bob <## "connection request sent!"
alice <## "bob_1 (Bob): accepting request to join group #team..."
concurrentlyN_
[ alice
<### [ "bob_1 (Bob): contact is connected",
"bob_1 invited to group #team via your group link",
EndsWith "joined the group",
"contact bob_1 is merged into bob",
"use @bob <message> to send messages"
],
bob
<### [ "alice_1 (Alice): contact is connected",
"#team_1: you joined the group",
"contact alice_1 is merged into alice",
"use @alice <message> to send messages"
]
]
alice #> "#team hi"
bob <# "#team_1 alice> hi"
bob #> "#team_1 hey"
alice <# "#team bob> hey"
bob ##> ("/_connect plan 1 " <> gLink)
bob <## "group link: known group #team_1"
bob <## "use #team_1 <message> to send messages"
bob ##> ("/c " <> gLink)
bob <## "group link: known group #team_1"
bob <## "use #team_1 <message> to send messages"
testGroupMsgDecryptError :: HasCallStack => FilePath -> IO ()
testGroupMsgDecryptError tmp =
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
@ -3015,9 +3251,9 @@ testMemberContactProhibitedRepeatInv =
testMemberContactInvitedConnectionReplaced :: HasCallStack => FilePath -> IO ()
testMemberContactInvitedConnectionReplaced tmp = do
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withNewTestChat tmp "alice" aliceProfile $ \a -> withTestOutput a $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \b -> withTestOutput b $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \c -> withTestOutput c $ \cath -> do
createGroup3 "team" alice bob cath
alice ##> "/d bob"
@ -3040,7 +3276,9 @@ testMemberContactInvitedConnectionReplaced tmp = do
(alice <## "bob (Bob): contact is connected")
(bob <## "alice (Alice): contact is connected")
bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "received invitation to join group team as admin"), (0, "contact deleted"), (0, "hi"), (0, "security code changed")] <> chatFeatures)
bob ##> "/_get chat @2 count=100"
items <- chat <$> getTermLine bob
items `shouldContain` [(0, "received invitation to join group team as admin"), (0, "contact deleted"), (0, "hi"), (0, "security code changed")]
withTestChat tmp "bob" $ \bob -> do
subscriptions bob 1

165
tests/ChatTests/Profiles.hs
View file

@ -28,6 +28,11 @@ chatProfileTests = do
it "delete connection requests when contact link deleted" testDeleteConnectionRequests
it "auto-reply message" testAutoReplyMessage
it "auto-reply message in incognito" testAutoReplyMessageInIncognito
describe "contact address connection plan" $ do
it "contact address ok to connect; known contact" testPlanAddressOkKnown
it "own contact address" testPlanAddressOwn
it "connecting via contact address" testPlanAddressConnecting
it "re-connect with deleted contact" testPlanAddressContactDeletedReconnected
describe "incognito" $ do
it "connect incognito via invitation link" testConnectIncognitoInvitationLink
it "connect incognito via contact address" testConnectIncognitoContactAddress
@ -369,7 +374,8 @@ testDeduplicateContactRequests = testChat3 aliceProfile bobProfile cathProfile $
(alice <## "bob (Bob): contact is connected")
bob ##> ("/c " <> cLink)
bob <## "alice (Alice): contact already exists"
bob <## "contact address: known contact alice"
bob <## "use @alice <message> to send messages"
alice @@@ [("@bob", lastChatFeature)]
bob @@@ [("@alice", lastChatFeature), (":2", ""), (":1", "")]
bob ##> "/_delete :1"
@ -382,7 +388,8 @@ testDeduplicateContactRequests = testChat3 aliceProfile bobProfile cathProfile $
bob @@@ [("@alice", "hey")]
bob ##> ("/c " <> cLink)
bob <## "alice (Alice): contact already exists"
bob <## "contact address: known contact alice"
bob <## "use @alice <message> to send messages"
alice <##> bob
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "hi"), (0, "hey"), (1, "hi"), (0, "hey")])
@ -440,7 +447,8 @@ testDeduplicateContactRequestsProfileChange = testChat3 aliceProfile bobProfile
(alice <## "robert (Robert): contact is connected")
bob ##> ("/c " <> cLink)
bob <## "alice (Alice): contact already exists"
bob <## "contact address: known contact alice"
bob <## "use @alice <message> to send messages"
alice @@@ [("@robert", lastChatFeature)]
bob @@@ [("@alice", lastChatFeature), (":3", ""), (":2", ""), (":1", "")]
bob ##> "/_delete :1"
@ -455,7 +463,8 @@ testDeduplicateContactRequestsProfileChange = testChat3 aliceProfile bobProfile
bob @@@ [("@alice", "hey")]
bob ##> ("/c " <> cLink)
bob <## "alice (Alice): contact already exists"
bob <## "contact address: known contact alice"
bob <## "use @alice <message> to send messages"
alice <##> bob
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "hi"), (0, "hey"), (1, "hi"), (0, "hey")])
@ -566,6 +575,154 @@ testAutoReplyMessageInIncognito = testChat2 aliceProfile bobProfile $
]
]
testPlanAddressOkKnown :: HasCallStack => FilePath -> IO ()
testPlanAddressOkKnown =
testChat2 aliceProfile bobProfile $
\alice bob -> do
alice ##> "/ad"
cLink <- getContactLink alice True
bob ##> ("/_connect plan 1 " <> cLink)
bob <## "contact address: ok to connect"
bob ##> ("/c " <> cLink)
alice <#? bob
alice @@@ [("<@bob", "")]
alice ##> "/ac bob"
alice <## "bob (Bob): accepting contact request..."
concurrently_
(bob <## "alice (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected")
alice <##> bob
bob ##> ("/_connect plan 1 " <> cLink)
bob <## "contact address: known contact alice"
bob <## "use @alice <message> to send messages"
bob ##> ("/c " <> cLink)
bob <## "contact address: known contact alice"
bob <## "use @alice <message> to send messages"
testPlanAddressOwn :: HasCallStack => FilePath -> IO ()
testPlanAddressOwn tmp =
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
alice ##> "/ad"
cLink <- getContactLink alice True
alice ##> ("/_connect plan 1 " <> cLink)
alice <## "contact address: own address"
alice ##> ("/c " <> cLink)
alice <## "connection request sent!"
alice <## "alice_1 (Alice) wants to connect to you!"
alice <## "to accept: /ac alice_1"
alice <## ("to reject: /rc alice_1 (the sender will NOT be notified)")
alice @@@ [("<@alice_1", ""), (":2","")]
alice ##> "/ac alice_1"
alice <## "alice_1 (Alice): accepting contact request..."
alice
<### [ "alice_1 (Alice): contact is connected",
"alice_2 (Alice): contact is connected"
]
alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)]
alice `send` "@alice_2 hi"
alice
<### [ WithTime "@alice_2 hi",
WithTime "alice_1> hi"
]
alice `send` "@alice_1 hey"
alice
<### [ WithTime "@alice_1 hey",
WithTime "alice_2> hey"
]
alice @@@ [("@alice_1", "hey"), ("@alice_2", "hey")]
alice ##> ("/_connect plan 1 " <> cLink)
alice <## "contact address: own address"
alice ##> ("/c " <> cLink)
alice <## "alice_2 (Alice): contact already exists"
testPlanAddressConnecting :: HasCallStack => FilePath -> IO ()
testPlanAddressConnecting tmp = do
cLink <- withNewTestChat tmp "alice" aliceProfile $ \alice -> do
alice ##> "/ad"
getContactLink alice True
withNewTestChat tmp "bob" bobProfile $ \bob -> do
bob ##> ("/c " <> cLink)
bob <## "connection request sent!"
withTestChat tmp "alice" $ \alice -> do
alice <## "Your address is active! To show: /sa"
alice <## "bob (Bob) wants to connect to you!"
alice <## "to accept: /ac bob"
alice <## "to reject: /rc bob (the sender will NOT be notified)"
alice ##> "/ac bob"
alice <## "bob (Bob): accepting contact request..."
withTestChat tmp "bob" $ \bob -> do
threadDelay 500000
bob @@@ [("@alice", "")]
bob ##> ("/_connect plan 1 " <> cLink)
bob <## "contact address: connecting to contact alice"
bob ##> ("/c " <> cLink)
bob <## "contact address: connecting to contact alice"
testPlanAddressContactDeletedReconnected :: HasCallStack => FilePath -> IO ()
testPlanAddressContactDeletedReconnected =
testChat2 aliceProfile bobProfile $
\alice bob -> do
alice ##> "/ad"
cLink <- getContactLink alice True
bob ##> ("/c " <> cLink)
alice <#? bob
alice ##> "/ac bob"
alice <## "bob (Bob): accepting contact request..."
concurrently_
(bob <## "alice (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected")
alice <##> bob
bob ##> ("/_connect plan 1 " <> cLink)
bob <## "contact address: known contact alice"
bob <## "use @alice <message> to send messages"
bob ##> ("/c " <> cLink)
bob <## "contact address: known contact alice"
bob <## "use @alice <message> to send messages"
alice ##> "/d bob"
alice <## "bob: contact is deleted"
bob <## "alice (Alice) deleted contact with you"
bob ##> ("/_connect plan 1 " <> cLink)
bob <## "contact address: ok to connect"
bob ##> ("/c " <> cLink)
bob <## "connection request sent!"
alice <## "bob (Bob) wants to connect to you!"
alice <## "to accept: /ac bob"
alice <## "to reject: /rc bob (the sender will NOT be notified)"
alice ##> "/ac bob"
alice <## "bob (Bob): accepting contact request..."
concurrently_
(bob <## "alice_1 (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected")
alice #> "@bob hi"
bob <# "alice_1> hi"
bob #> "@alice_1 hey"
alice <# "bob> hey"
bob ##> ("/_connect plan 1 " <> cLink)
bob <## "contact address: known contact alice_1"
bob <## "use @alice_1 <message> to send messages"
bob ##> ("/c " <> cLink)
bob <## "contact address: known contact alice_1"
bob <## "use @alice_1 <message> to send messages"
testConnectIncognitoInvitationLink :: HasCallStack => FilePath -> IO ()
testConnectIncognitoInvitationLink = testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do