diff --git a/apps/ios/Shared/Model/ChatModel.swift b/apps/ios/Shared/Model/ChatModel.swift index 6b6b0ac03f..2784551361 100644 --- a/apps/ios/Shared/Model/ChatModel.swift +++ b/apps/ios/Shared/Model/ChatModel.swift @@ -100,6 +100,94 @@ class ItemsModel: ObservableObject { } } +class ChatTagsModel: ObservableObject { + static let shared = ChatTagsModel() + + @Published var userTags: [ChatTag] = [] + @Published var activeFilter: ActiveFilter? = nil + @Published var presetTags: [PresetTag:Int] = [:] + @Published var unreadTags: [Int64:Int] = [:] + + func updateChatTags(_ chats: [Chat]) { + let tm = ChatTagsModel.shared + var newPresetTags: [PresetTag:Int] = [:] + var newUnreadTags: [Int64:Int] = [:] + for chat in chats { + for tag in PresetTag.allCases { + if presetTagMatchesChat(tag, chat.chatInfo) { + newPresetTags[tag] = (newPresetTags[tag] ?? 0) + 1 + } + } + if chat.isUnread, let tags = chat.chatInfo.chatTags { + for tag in tags { + newUnreadTags[tag] = (newUnreadTags[tag] ?? 0) + 1 + } + } + } + if case let .presetTag(tag) = tm.activeFilter, (newPresetTags[tag] ?? 0) == 0 { + activeFilter = nil + } + presetTags = newPresetTags + unreadTags = newUnreadTags + } + + func updateChatFavorite(favorite: Bool, wasFavorite: Bool) { + let count = presetTags[.favorites] + if favorite && !wasFavorite { + presetTags[.favorites] = (count ?? 0) + 1 + } else if !favorite && wasFavorite, let count { + presetTags[.favorites] = max(0, count - 1) + if case .presetTag(.favorites) = activeFilter, (presetTags[.favorites] ?? 0) == 0 { + activeFilter = nil + } + } + } + + func addPresetChatTags(_ chatInfo: ChatInfo) { + for tag in PresetTag.allCases { + if presetTagMatchesChat(tag, chatInfo) { + presetTags[tag] = (presetTags[tag] ?? 0) + 1 + } + } + } + + func removePresetChatTags(_ chatInfo: ChatInfo) { + for tag in PresetTag.allCases { + if presetTagMatchesChat(tag, chatInfo) { + if let count = presetTags[tag] { + presetTags[tag] = max(0, count - 1) + } + } + } + } + + func markChatTagRead(_ chat: Chat) -> Void { + if chat.isUnread, let tags = chat.chatInfo.chatTags { + markChatTagRead_(chat, tags) + } + } + + func updateChatTagRead(_ chat: Chat, wasUnread: Bool) -> Void { + guard let tags = chat.chatInfo.chatTags else { return } + let nowUnread = chat.isUnread + if nowUnread && !wasUnread { + for tag in tags { + unreadTags[tag] = (unreadTags[tag] ?? 0) + 1 + } + } else if !nowUnread && wasUnread { + markChatTagRead_(chat, tags) + } + } + + private func markChatTagRead_(_ chat: Chat, _ tags: [Int64]) -> Void { + for tag in tags { + if let count = unreadTags[tag] { + unreadTags[tag] = max(0, count - 1) + } + } + } +} + class NetworkModel: ObservableObject { // map of connections network statuses, key is agent connection id @Published var networkStatuses: Dictionary = [:] @@ -344,6 +432,7 @@ final class ChatModel: ObservableObject { updateChatInfo(cInfo) } else if addMissing { addChat(Chat(chatInfo: cInfo, chatItems: [])) + ChatTagsModel.shared.addPresetChatTags(cInfo) } } @@ -566,6 +655,7 @@ final class ChatModel: ObservableObject { _updateChat(cInfo.id) { chat in self.decreaseUnreadCounter(user: self.currentUser!, by: chat.chatStats.unreadCount) self.updateFloatingButtons(unreadCount: 0) + ChatTagsModel.shared.markChatTagRead(chat) chat.chatStats = ChatStats() } // update current chat @@ -604,7 +694,9 @@ final class ChatModel: ObservableObject { // update preview let markedCount = chat.chatStats.unreadCount - unreadBelow if markedCount > 0 { + let wasUnread = chat.isUnread chat.chatStats.unreadCount -= markedCount + ChatTagsModel.shared.updateChatTagRead(chat, wasUnread: wasUnread) self.decreaseUnreadCounter(user: self.currentUser!, by: markedCount) self.updateFloatingButtons(unreadCount: chat.chatStats.unreadCount) } @@ -617,7 +709,9 @@ final class ChatModel: ObservableObject { func markChatUnread(_ cInfo: ChatInfo, unreadChat: Bool = true) { _updateChat(cInfo.id) { chat in + let wasUnread = chat.isUnread chat.chatStats.unreadChat = unreadChat + ChatTagsModel.shared.updateChatTagRead(chat, wasUnread: wasUnread) } } @@ -626,6 +720,7 @@ final class ChatModel: ObservableObject { if let chat = getChat(cInfo.id) { self.decreaseUnreadCounter(user: self.currentUser!, by: chat.chatStats.unreadCount) chat.chatItems = [] + ChatTagsModel.shared.markChatTagRead(chat) chat.chatStats = ChatStats() chat.chatInfo = cInfo } @@ -752,7 +847,9 @@ final class ChatModel: ObservableObject { } func changeUnreadCounter(_ chatIndex: Int, by count: Int) { + let wasUnread = chats[chatIndex].isUnread chats[chatIndex].chatStats.unreadCount = chats[chatIndex].chatStats.unreadCount + count + ChatTagsModel.shared.updateChatTagRead(chats[chatIndex], wasUnread: wasUnread) changeUnreadCounter(user: currentUser!, by: count) } @@ -857,7 +954,10 @@ final class ChatModel: ObservableObject { func removeChat(_ id: String) { withAnimation { - chats.removeAll(where: { $0.id == id }) + if let i = getChatIndex(id) { + let removed = chats.remove(at: i) + ChatTagsModel.shared.removePresetChatTags(removed.chatInfo) + } } } @@ -955,6 +1055,10 @@ final class Chat: ObservableObject, Identifiable, ChatLike { } } + var isUnread: Bool { + chatStats.unreadCount > 0 || chatStats.unreadChat + } + var id: ChatId { get { chatInfo.id } } var viewId: String { get { "\(chatInfo.id) \(created.timeIntervalSince1970)" } } diff --git a/apps/ios/Shared/Model/SimpleXAPI.swift b/apps/ios/Shared/Model/SimpleXAPI.swift index 51be3191ec..7eb78edf74 100644 --- a/apps/ios/Shared/Model/SimpleXAPI.swift +++ b/apps/ios/Shared/Model/SimpleXAPI.swift @@ -318,6 +318,20 @@ private func apiChatsResponse(_ r: ChatResponse) throws -> [ChatData] { throw r } +func apiGetChatTags() throws -> [ChatTag] { + let userId = try currentUserId("apiGetChatTags") + let r = chatSendCmdSync(.apiGetChatTags(userId: userId)) + if case let .chatTags(_, tags) = r { return tags } + throw r +} + +func apiGetChatTagsAsync() async throws -> [ChatTag] { + let userId = try currentUserId("apiGetChatTags") + let r = await chatSendCmd(.apiGetChatTags(userId: userId)) + if case let .chatTags(_, tags) = r { return tags } + throw r +} + let loadItemsPerPage = 50 func apiGetChat(type: ChatType, id: Int64, search: String = "") async throws -> Chat { @@ -368,6 +382,34 @@ func apiForwardChatItems(toChatType: ChatType, toChatId: Int64, fromChatType: Ch return await processSendMessageCmd(toChatType: toChatType, cmd: cmd) } +func apiCreateChatTag(tag: ChatTagData) async throws -> [ChatTag] { + let r = await chatSendCmd(.apiCreateChatTag(tag: tag)) + if case let .chatTags(_, userTags) = r { + return userTags + } + throw r +} + +func apiSetChatTags(type: ChatType, id: Int64, tagIds: [Int64]) async throws -> ([ChatTag], [Int64]) { + let r = await chatSendCmd(.apiSetChatTags(type: type, id: id, tagIds: tagIds)) + if case let .tagsUpdated(_, userTags, chatTags) = r { + return (userTags, chatTags) + } + throw r +} + +func apiDeleteChatTag(tagId: Int64) async throws { + try await sendCommandOkResp(.apiDeleteChatTag(tagId: tagId)) +} + +func apiUpdateChatTag(tagId: Int64, tag: ChatTagData) async throws { + try await sendCommandOkResp(.apiUpdateChatTag(tagId: tagId, tagData: tag)) +} + +func apiReorderChatTags(tagIds: [Int64]) async throws { + try await sendCommandOkResp(.apiReorderChatTags(tagIds: tagIds)) +} + func apiSendMessages(type: ChatType, id: Int64, live: Bool = false, ttl: Int? = nil, composedMessages: [ComposedMessage]) async -> [ChatItem]? { let cmd: ChatCommand = .apiSendMessages(type: type, id: id, live: live, ttl: ttl, composedMessages: composedMessages) return await processSendMessageCmd(toChatType: type, cmd: cmd) @@ -1746,24 +1788,37 @@ func getUserChatData() throws { m.userAddress = try apiGetUserAddress() m.chatItemTTL = try getChatItemTTL() let chats = try apiGetChats() + let tags = try apiGetChatTags() m.updateChats(chats) + let tm = ChatTagsModel.shared + tm.activeFilter = nil + tm.userTags = tags + tm.updateChatTags(m.chats) } private func getUserChatDataAsync() async throws { let m = ChatModel.shared + let tm = ChatTagsModel.shared if m.currentUser != nil { let userAddress = try await apiGetUserAddressAsync() let chatItemTTL = try await getChatItemTTLAsync() let chats = try await apiGetChatsAsync() + let tags = try await apiGetChatTagsAsync() await MainActor.run { m.userAddress = userAddress m.chatItemTTL = chatItemTTL m.updateChats(chats) + tm.activeFilter = nil + tm.userTags = tags + tm.updateChatTags(m.chats) } } else { await MainActor.run { m.userAddress = nil m.updateChats([]) + tm.activeFilter = nil + tm.userTags = [] + tm.presetTags = [:] } } } diff --git a/apps/ios/Shared/Views/Chat/ChatInfoView.swift b/apps/ios/Shared/Views/Chat/ChatInfoView.swift index 9b6b9b73e8..1c3203920a 100644 --- a/apps/ios/Shared/Views/Chat/ChatInfoView.swift +++ b/apps/ios/Shared/Views/Chat/ChatInfoView.swift @@ -332,7 +332,7 @@ struct ChatInfoView: View { .sheet(item: $sheet) { if #available(iOS 16.0, *) { $0.content - .presentationDetents([.fraction(0.4)]) + .presentationDetents([.fraction($0.fraction)]) } else { $0.content } diff --git a/apps/ios/Shared/Views/Chat/ChatView.swift b/apps/ios/Shared/Views/Chat/ChatView.swift index 90c277ce76..ac4066d23e 100644 --- a/apps/ios/Shared/Views/Chat/ChatView.swift +++ b/apps/ios/Shared/Views/Chat/ChatView.swift @@ -2007,6 +2007,8 @@ func updateChatSettings(_ chat: Chat, chatSettings: ChatSettings) { do { try await apiSetChatSettings(type: chat.chatInfo.chatType, id: chat.chatInfo.apiId, chatSettings: chatSettings) await MainActor.run { + let wasFavorite = chat.chatInfo.chatSettings?.favorite ?? false + ChatTagsModel.shared.updateChatFavorite(favorite: chatSettings.favorite, wasFavorite: wasFavorite) switch chat.chatInfo { case var .direct(contact): contact.chatSettings = chatSettings diff --git a/apps/ios/Shared/Views/Chat/Group/GroupMemberInfoView.swift b/apps/ios/Shared/Views/Chat/Group/GroupMemberInfoView.swift index a18de1b349..30972f7242 100644 --- a/apps/ios/Shared/Views/Chat/Group/GroupMemberInfoView.swift +++ b/apps/ios/Shared/Views/Chat/Group/GroupMemberInfoView.swift @@ -162,7 +162,7 @@ struct GroupMemberInfoView: View { } .disabled( connStats.rcvQueuesInfo.contains { $0.rcvSwitchStatus != nil } - || connStats.ratchetSyncSendProhibited + || !member.sendMsgEnabled ) if connStats.rcvQueuesInfo.contains(where: { $0.rcvSwitchStatus != nil }) { Button("Abort changing address") { @@ -170,7 +170,7 @@ struct GroupMemberInfoView: View { } .disabled( connStats.rcvQueuesInfo.contains { $0.rcvSwitchStatus != nil && !$0.canAbortSwitch } - || connStats.ratchetSyncSendProhibited + || !member.sendMsgEnabled ) } smpServers("Receiving via", connStats.rcvQueuesInfo.map { $0.rcvServer }, theme.colors.secondary) @@ -297,7 +297,7 @@ struct GroupMemberInfoView: View { if let contactId = member.memberContactId { newDirectChatButton(contactId, width: buttonWidth) } else if member.activeConn?.peerChatVRange.isCompatibleRange(CREATE_MEMBER_CONTACT_VRANGE) ?? false { - createMemberContactButton(width: buttonWidth) + createMemberContactButton(member, width: buttonWidth) } InfoViewButton(image: "phone.fill", title: "call", disabledLook: true, width: buttonWidth) { showSendMessageToEnableCallsAlert() } @@ -379,32 +379,41 @@ struct GroupMemberInfoView: View { } } - func createMemberContactButton(width: CGFloat) -> some View { - InfoViewButton(image: "message.fill", title: "message", width: width) { - if let connStats = connectionStats { - if connStats.ratchetSyncState == .ok { - progressIndicator = true - Task { - do { - let memberContact = try await apiCreateMemberContact(groupInfo.apiId, groupMember.groupMemberId) - await MainActor.run { - progressIndicator = false - chatModel.addChat(Chat(chatInfo: .direct(contact: memberContact))) - ItemsModel.shared.loadOpenChat(memberContact.id) { - dismissAllSheets(animated: true) - } - NetworkModel.shared.setContactNetworkStatus(memberContact, .connected) - } - } catch let error { - logger.error("createMemberContactButton apiCreateMemberContact error: \(responseError(error))") - let a = getErrorAlert(error, "Error creating member contact") - await MainActor.run { - progressIndicator = false - alert = .error(title: a.title, error: a.message) + func createMemberContactButton(_ member: GroupMember, width: CGFloat) -> some View { + InfoViewButton( + image: "message.fill", + title: "message", + disabledLook: + !( + member.sendMsgEnabled || + (member.activeConn?.connectionStats?.ratchetSyncAllowed ?? false) + ), + width: width + ) { + if member.sendMsgEnabled { + progressIndicator = true + Task { + do { + let memberContact = try await apiCreateMemberContact(groupInfo.apiId, groupMember.groupMemberId) + await MainActor.run { + progressIndicator = false + chatModel.addChat(Chat(chatInfo: .direct(contact: memberContact))) + ItemsModel.shared.loadOpenChat(memberContact.id) { + dismissAllSheets(animated: true) } + NetworkModel.shared.setContactNetworkStatus(memberContact, .connected) + } + } catch let error { + logger.error("createMemberContactButton apiCreateMemberContact error: \(responseError(error))") + let a = getErrorAlert(error, "Error creating member contact") + await MainActor.run { + progressIndicator = false + alert = .error(title: a.title, error: a.message) } } - } else if connStats.ratchetSyncAllowed { + } + } else if let connStats = connectionStats { + if connStats.ratchetSyncAllowed { alert = .someAlert(alert: SomeAlert( alert: Alert( title: Text("Fix connection?"), @@ -416,13 +425,21 @@ struct GroupMemberInfoView: View { ), id: "can't message member, fix connection" )) - } else { + } else if connStats.ratchetSyncInProgress { alert = .someAlert(alert: SomeAlert( alert: mkAlert( title: "Can't message member", message: "Encryption renegotiation in progress." ), - id: "can't message contact, encryption renegotiation in progress" + id: "can't message member, encryption renegotiation in progress" + )) + } else { + alert = .someAlert(alert: SomeAlert( + alert: mkAlert( + title: "Can't message member", + message: "Connection not ready." + ), + id: "can't message member, connection not ready" )) } } diff --git a/apps/ios/Shared/Views/ChatList/ChatListNavLink.swift b/apps/ios/Shared/Views/ChatList/ChatListNavLink.swift index 6c5dad1f74..6bf86840a8 100644 --- a/apps/ios/Shared/Views/ChatList/ChatListNavLink.swift +++ b/apps/ios/Shared/Views/ChatList/ChatListNavLink.swift @@ -8,6 +8,7 @@ import SwiftUI import SimpleXChat +import ElegantEmojiPicker typealias DynamicSizes = ( rowHeight: CGFloat, @@ -43,9 +44,11 @@ func dynamicSize(_ font: DynamicTypeSize) -> DynamicSizes { struct ChatListNavLink: View { @EnvironmentObject var chatModel: ChatModel @EnvironmentObject var theme: AppTheme + @EnvironmentObject var chatTagsModel: ChatTagsModel @Environment(\.dynamicTypeSize) private var userFont: DynamicTypeSize @AppStorage(GROUP_DEFAULT_ONE_HAND_UI, store: groupDefaults) private var oneHandUI = false @ObservedObject var chat: Chat + @Binding var parentSheet: SomeSheet? @State private var showContactRequestDialog = false @State private var showJoinGroupDialog = false @State private var showContactConnectionInfo = false @@ -85,6 +88,7 @@ struct ChatListNavLink: View { progressByTimeout = false } } + .actionSheet(item: $actionSheet) { $0.actionSheet } } @ViewBuilder private func contactNavLink(_ contact: Contact) -> some View { @@ -124,6 +128,7 @@ struct ChatListNavLink: View { toggleNtfsButton(chat: chat) } .swipeActions(edge: .trailing, allowsFullSwipe: true) { + tagChatButton(chat) if !chat.chatItems.isEmpty { clearChatButton() } @@ -145,11 +150,10 @@ struct ChatListNavLink: View { } } .alert(item: $alert) { $0.alert } - .actionSheet(item: $actionSheet) { $0.actionSheet } .sheet(item: $sheet) { if #available(iOS 16.0, *) { $0.content - .presentationDetents([.fraction(0.4)]) + .presentationDetents([.fraction($0.fraction)]) } else { $0.content } @@ -185,6 +189,7 @@ struct ChatListNavLink: View { AlertManager.shared.showAlert(groupInvitationAcceptedAlert()) } .swipeActions(edge: .trailing) { + tagChatButton(chat) if (groupInfo.membership.memberCurrent) { leaveGroupChatButton(groupInfo) } @@ -206,14 +211,25 @@ struct ChatListNavLink: View { toggleNtfsButton(chat: chat) } .swipeActions(edge: .trailing, allowsFullSwipe: true) { - if !chat.chatItems.isEmpty { + tagChatButton(chat) + let showClearButton = !chat.chatItems.isEmpty + let showDeleteGroup = groupInfo.canDelete + let showLeaveGroup = groupInfo.membership.memberCurrent + let totalNumberOfButtons = 1 + (showClearButton ? 1 : 0) + (showDeleteGroup ? 1 : 0) + (showLeaveGroup ? 1 : 0) + + if showClearButton, totalNumberOfButtons <= 3 { clearChatButton() } - if (groupInfo.membership.memberCurrent) { + if (showLeaveGroup) { leaveGroupChatButton(groupInfo) } - if groupInfo.canDelete { - deleteGroupChatButton(groupInfo) + + if showDeleteGroup { + if totalNumberOfButtons <= 3 { + deleteGroupChatButton(groupInfo) + } else { + moreOptionsButton(chat, groupInfo) + } } } } @@ -306,7 +322,67 @@ struct ChatListNavLink: View { } .tint(Color.orange) } - + + private func tagChatButton(_ chat: Chat) -> some View { + Button { + setTagChatSheet(chat) + } label: { + SwipeLabel(NSLocalizedString("List", comment: "swipe action"), systemImage: "tag.fill", inverted: oneHandUI) + } + .tint(.mint) + } + + private func setTagChatSheet(_ chat: Chat) { + let screenHeight = UIScreen.main.bounds.height + let reservedSpace: Double = 4 * 44 // 2 for padding, 1 for "Create list" and another for extra tag + let tagsSpace = Double(max(chatTagsModel.userTags.count, 3)) * 44 + let fraction = min((reservedSpace + tagsSpace) / screenHeight, 0.62) + + parentSheet = SomeSheet( + content: { + AnyView( + NavigationView { + if chatTagsModel.userTags.isEmpty { + ChatListTagEditor(chat: chat) + } else { + ChatListTag(chat: chat) + } + } + ) + }, + id: "lists sheet", + fraction: fraction + ) + } + + private func moreOptionsButton(_ chat: Chat, _ groupInfo: GroupInfo?) -> some View { + Button { + var buttons: [Alert.Button] = [ + .default(Text("Clear")) { + AlertManager.shared.showAlert(clearChatAlert()) + } + ] + + if let gi = groupInfo, gi.canDelete { + buttons.append(.destructive(Text("Delete")) { + AlertManager.shared.showAlert(deleteGroupAlert(gi)) + }) + } + + buttons.append(.cancel()) + + actionSheet = SomeActionSheet( + actionSheet: ActionSheet( + title: Text("Clear or delete group?"), + buttons: buttons + ), + id: "other options" + ) + } label: { + SwipeLabel(NSLocalizedString("More", comment: "swipe action"), systemImage: "ellipsis", inverted: oneHandUI) + } + } + private func clearNoteFolderButton() -> some View { Button { AlertManager.shared.showAlert(clearNoteFolderAlert()) @@ -484,6 +560,389 @@ struct ChatListNavLink: View { } } +struct TagEditorNavParams { + let chat: Chat? + let chatListTag: ChatTagData? + let tagId: Int64? +} + +struct ChatListTag: View { + var chat: Chat? = nil + var showEditButton: Bool = false + @Environment(\.dismiss) var dismiss: DismissAction + @EnvironmentObject var theme: AppTheme + @EnvironmentObject var chatTagsModel: ChatTagsModel + @EnvironmentObject var m: ChatModel + @State private var editMode = EditMode.inactive + @State private var tagEditorNavParams: TagEditorNavParams? = nil + + var chatTagsIds: [Int64] { chat?.chatInfo.contact?.chatTags ?? chat?.chatInfo.groupInfo?.chatTags ?? [] } + + var body: some View { + List { + Section { + ForEach(chatTagsModel.userTags, id: \.id) { tag in + let text = tag.chatTagText + let emoji = tag.chatTagEmoji + let tagId = tag.chatTagId + let selected = chatTagsIds.contains(tagId) + + HStack { + if let emoji { + Text(emoji) + } else { + Image(systemName: "tag") + } + Text(text) + .padding(.leading, 12) + Spacer() + if chat != nil { + radioButton(selected: selected) + } + } + .contentShape(Rectangle()) + .onTapGesture { + if let c = chat { + setTag(tagId: selected ? nil : tagId, chat: c) + } else { + tagEditorNavParams = TagEditorNavParams(chat: nil, chatListTag: ChatTagData(emoji: emoji, text: text), tagId: tagId) + } + } + .swipeActions(edge: .trailing, allowsFullSwipe: true) { + Button { + showAlert( + NSLocalizedString("Delete list?", comment: "alert title"), + message: NSLocalizedString("All chats will be removed from the list \(text), and the list deleted.", comment: "alert message"), + actions: {[ + UIAlertAction( + title: NSLocalizedString("Cancel", comment: "alert action"), + style: .default + ), + UIAlertAction( + title: NSLocalizedString("Delete", comment: "alert action"), + style: .destructive, + handler: { _ in + deleteTag(tagId) + } + ) + ]} + ) + } label: { + Label("Delete", systemImage: "trash.fill") + } + .tint(.red) + } + .swipeActions(edge: .leading, allowsFullSwipe: true) { + Button { + tagEditorNavParams = TagEditorNavParams(chat: nil, chatListTag: ChatTagData(emoji: emoji, text: text), tagId: tagId) + } label: { + Label("Edit", systemImage: "pencil") + } + .tint(theme.colors.primary) + } + .background( + // isActive required to navigate to edit view from any possible tag edited in swipe action + NavigationLink(isActive: Binding(get: { tagEditorNavParams != nil }, set: { _ in tagEditorNavParams = nil })) { + if let params = tagEditorNavParams { + ChatListTagEditor( + chat: params.chat, + tagId: params.tagId, + emoji: params.chatListTag?.emoji, + name: params.chatListTag?.text ?? "" + ) + } + } label: { + EmptyView() + } + .opacity(0) + ) + } + .onMove(perform: moveItem) + + NavigationLink { + ChatListTagEditor(chat: chat) + } label: { + Label("Create list", systemImage: "plus") + } + } header: { + if showEditButton { + editTagsButton() + .textCase(nil) + .frame(maxWidth: .infinity, alignment: .trailing) + } + } + } + .modifier(ThemedBackground(grouped: true)) + .environment(\.editMode, $editMode) + } + + private func editTagsButton() -> some View { + if editMode.isEditing { + Button("Done") { + editMode = .inactive + dismiss() + } + } else { + Button("Edit") { + editMode = .active + } + } + } + + @ViewBuilder private func radioButton(selected: Bool) -> some View { + Image(systemName: selected ? "checkmark.circle.fill" : "circle") + .imageScale(.large) + .foregroundStyle(selected ? Color.accentColor : Color(.tertiaryLabel)) + } + + private func moveItem(from source: IndexSet, to destination: Int) { + Task { + do { + var tags = chatTagsModel.userTags + tags.move(fromOffsets: source, toOffset: destination) + try await apiReorderChatTags(tagIds: tags.map { $0.chatTagId }) + + await MainActor.run { + chatTagsModel.userTags = tags + } + } catch let error { + showAlert( + NSLocalizedString("Error reordering lists", comment: "alert title"), + message: responseError(error) + ) + } + } + } + + private func setTag(tagId: Int64?, chat: Chat) { + Task { + do { + let tagIds: [Int64] = if let t = tagId { [t] } else {[]} + let (userTags, chatTags) = try await apiSetChatTags( + type: chat.chatInfo.chatType, + id: chat.chatInfo.apiId, + tagIds: tagIds + ) + + await MainActor.run { + chatTagsModel.userTags = userTags + if var contact = chat.chatInfo.contact { + contact.chatTags = chatTags + m.updateContact(contact) + } else if var group = chat.chatInfo.groupInfo { + group.chatTags = chatTags + m.updateGroup(group) + } + dismiss() + } + } catch let error { + showAlert( + NSLocalizedString("Error saving chat list", comment: "alert title"), + message: responseError(error) + ) + } + } + } + + private func deleteTag(_ tagId: Int64) { + Task { + try await apiDeleteChatTag(tagId: tagId) + + await MainActor.run { + chatTagsModel.userTags = chatTagsModel.userTags.filter { $0.chatTagId != tagId } + if case let .userTag(tag) = chatTagsModel.activeFilter, tagId == tag.chatTagId { + chatTagsModel.activeFilter = nil + } + m.chats.forEach { c in + if var contact = c.chatInfo.contact, contact.chatTags.contains(tagId) { + contact.chatTags = contact.chatTags.filter({ $0 != tagId }) + m.updateContact(contact) + } else if var group = c.chatInfo.groupInfo, group.chatTags.contains(tagId) { + group.chatTags = group.chatTags.filter({ $0 != tagId }) + m.updateGroup(group) + } + } + } + } + } +} + +struct EmojiPickerView: UIViewControllerRepresentable { + @Binding var selectedEmoji: String? + @Binding var showingPicker: Bool + @Environment(\.presentationMode) var presentationMode + + class Coordinator: NSObject, ElegantEmojiPickerDelegate, UIAdaptivePresentationControllerDelegate { + var parent: EmojiPickerView + + init(parent: EmojiPickerView) { + self.parent = parent + } + + func emojiPicker(_ picker: ElegantEmojiPicker, didSelectEmoji emoji: Emoji?) { + parent.selectedEmoji = emoji?.emoji + parent.showingPicker = false + picker.dismiss(animated: true) + } + + // Called when the picker is dismissed manually (without selection) + func presentationControllerWillDismiss(_ presentationController: UIPresentationController) { + parent.showingPicker = false + } + } + + func makeCoordinator() -> Coordinator { + return Coordinator(parent: self) + } + + func makeUIViewController(context: Context) -> UIViewController { + let config = ElegantConfiguration(showRandom: false, showReset: true, showClose: false) + let picker = ElegantEmojiPicker(delegate: context.coordinator, configuration: config) + + picker.presentationController?.delegate = context.coordinator + + let viewController = UIViewController() + DispatchQueue.main.async { + if let topVC = getTopViewController() { + topVC.present(picker, animated: true) + } + } + + return viewController + } + + func updateUIViewController(_ uiViewController: UIViewController, context: Context) { + // No need to update the controller after creation + } +} + +struct ChatListTagEditor: View { + var chat: Chat? = nil + var tagId: Int64? = nil + @Environment(\.dismiss) var dismiss: DismissAction + @EnvironmentObject var chatTagsModel: ChatTagsModel + @EnvironmentObject var theme: AppTheme + var emoji: String? + var name: String = "" + @State private var newEmoji: String? + @State private var newName: String = "" + @State private var isPickerPresented = false + @State private var saving: Bool? + + var body: some View { + VStack { + List { + let isDuplicateEmojiOrName = chatTagsModel.userTags.contains { tag in + tag.chatTagId != tagId && + ((newEmoji != nil && tag.chatTagEmoji == newEmoji) || tag.chatTagText == trimmedName) + } + + Section { + HStack { + Button { + isPickerPresented = true + } label: { + if let newEmoji { + Text(newEmoji) + } else { + Image(systemName: "face.smiling") + .foregroundColor(.secondary) + } + } + TextField("List name...", text: $newName) + } + + Button { + saving = true + if let tId = tagId { + updateChatTag(tagId: tId, chatTagData: ChatTagData(emoji: newEmoji, text: trimmedName)) + } else { + createChatTag() + } + } label: { + Text(NSLocalizedString(tagId == nil ? "Create list" : "Save list", comment: "list editor button")) + } + .disabled(saving != nil || (trimmedName == name && newEmoji == emoji) || trimmedName.isEmpty || isDuplicateEmojiOrName) + } footer: { + if isDuplicateEmojiOrName && saving != false { // if not saved already, to prevent flickering + HStack { + Image(systemName: "exclamationmark.circle") + .foregroundColor(.red) + Text("List name and emoji should be different for all lists.") + .foregroundColor(theme.colors.secondary) + } + } + } + } + + if isPickerPresented { + EmojiPickerView(selectedEmoji: $newEmoji, showingPicker: $isPickerPresented) + } + } + .modifier(ThemedBackground(grouped: true)) + .onAppear { + newEmoji = emoji + newName = name + } + } + + var trimmedName: String { + newName.trimmingCharacters(in: .whitespaces) + } + + private func createChatTag() { + Task { + do { + let userTags = try await apiCreateChatTag( + tag: ChatTagData(emoji: newEmoji , text: trimmedName) + ) + await MainActor.run { + saving = false + chatTagsModel.userTags = userTags + dismiss() + } + } catch let error { + await MainActor.run { + saving = nil + showAlert( + NSLocalizedString("Error creating list", comment: "alert title"), + message: responseError(error) + ) + } + } + } + } + + private func updateChatTag(tagId: Int64, chatTagData: ChatTagData) { + Task { + do { + try await apiUpdateChatTag(tagId: tagId, tag: chatTagData) + await MainActor.run { + saving = false + for i in 0.. Alert { Alert( title: Text("Reject contact request"), @@ -585,15 +1044,15 @@ struct ChatListNavLink_Previews: PreviewProvider { ChatListNavLink(chat: Chat( chatInfo: ChatInfo.sampleData.direct, chatItems: [ChatItem.getSample(1, .directSnd, .now, "hello")] - )) + ), parentSheet: .constant(nil)) ChatListNavLink(chat: Chat( chatInfo: ChatInfo.sampleData.direct, chatItems: [ChatItem.getSample(1, .directSnd, .now, "hello")] - )) + ), parentSheet: .constant(nil)) ChatListNavLink(chat: Chat( chatInfo: ChatInfo.sampleData.contactRequest, chatItems: [] - )) + ), parentSheet: .constant(nil)) } .previewLayout(.fixed(width: 360, height: 82)) } diff --git a/apps/ios/Shared/Views/ChatList/ChatListView.swift b/apps/ios/Shared/Views/ChatList/ChatListView.swift index b18e9295b9..9cb87a4b22 100644 --- a/apps/ios/Shared/Views/ChatList/ChatListView.swift +++ b/apps/ios/Shared/Views/ChatList/ChatListView.swift @@ -31,6 +31,29 @@ enum UserPickerSheet: Identifiable { } } +enum PresetTag: Int, Identifiable, CaseIterable, Equatable { + case favorites = 0 + case contacts = 1 + case groups = 2 + case business = 3 + + var id: Int { rawValue } +} + +enum ActiveFilter: Identifiable, Equatable { + case presetTag(PresetTag) + case userTag(ChatTag) + case unread + + var id: String { + switch self { + case let .presetTag(tag): "preset \(tag.id)" + case let .userTag(tag): "user \(tag.chatTagId)" + case .unread: "unread" + } + } +} + class SaveableSettings: ObservableObject { @Published var servers: ServerSettings = ServerSettings(currUserServers: [], userServers: [], serverErrors: []) } @@ -117,13 +140,14 @@ struct ChatListView: View { @State private var searchChatFilteredBySimplexLink: String? = nil @State private var scrollToSearchBar = false @State private var userPickerShown: Bool = false - - @AppStorage(DEFAULT_SHOW_UNREAD_AND_FAVORITES) private var showUnreadAndFavorites = false + @State private var sheet: SomeSheet? = nil + @StateObject private var chatTagsModel = ChatTagsModel.shared + @AppStorage(GROUP_DEFAULT_ONE_HAND_UI, store: groupDefaults) private var oneHandUI = true @AppStorage(DEFAULT_ONE_HAND_UI_CARD_SHOWN) private var oneHandUICardShown = false @AppStorage(DEFAULT_ADDRESS_CREATION_CARD_SHOWN) private var addressCreationCardShown = false @AppStorage(DEFAULT_TOOLBAR_MATERIAL) private var toolbarMaterial = ToolbarMaterial.defaultMaterial - + var body: some View { if #available(iOS 16.0, *) { viewBody.scrollDismissesKeyboard(.immediately) @@ -131,7 +155,7 @@ struct ChatListView: View { viewBody } } - + private var viewBody: some View { ZStack(alignment: oneHandUI ? .bottomLeading : .topLeading) { NavStackCompat( @@ -161,8 +185,9 @@ struct ChatListView: View { } } } + .environmentObject(chatTagsModel) } - + private var chatListView: some View { let tm = ToolbarMaterial.material(toolbarMaterial) return withToolbar(tm) { @@ -197,15 +222,22 @@ struct ChatListView: View { Divider().padding(.bottom, Self.hasHomeIndicator ? 0 : 8).background(tm) } } + .sheet(item: $sheet) { sheet in + if #available(iOS 16.0, *) { + sheet.content.presentationDetents([.fraction(sheet.fraction)]) + } else { + sheet.content + } + } } - + static var hasHomeIndicator: Bool = { if let windowScene = UIApplication.shared.connectedScenes.first as? UIWindowScene, let window = windowScene.windows.first { window.safeAreaInsets.bottom > 0 } else { false } }() - + @ViewBuilder func withToolbar(_ material: Material, content: () -> some View) -> some View { if #available(iOS 16.0, *) { if oneHandUI { @@ -226,13 +258,13 @@ struct ChatListView: View { } } } - + @ToolbarContentBuilder var topToolbar: some ToolbarContent { ToolbarItem(placement: .topBarLeading) { leadingToolbarItem } ToolbarItem(placement: .principal) { SubsStatusIndicator() } ToolbarItem(placement: .topBarTrailing) { trailingToolbarItem } } - + @ToolbarContentBuilder var bottomToolbar: some ToolbarContent { let padding: Double = Self.hasHomeIndicator ? 0 : 14 ToolbarItem(placement: .bottomBar) { @@ -247,7 +279,7 @@ struct ChatListView: View { .onTapGesture { scrollToSearchBar = true } } } - + @ToolbarContentBuilder var bottomToolbarGroup: some ToolbarContent { let padding: Double = Self.hasHomeIndicator ? 0 : 14 ToolbarItemGroup(placement: .bottomBar) { @@ -258,7 +290,7 @@ struct ChatListView: View { trailingToolbarItem.padding(.bottom, padding) } } - + @ViewBuilder var leadingToolbarItem: some View { let user = chatModel.currentUser ?? User.sampleData ZStack(alignment: .topTrailing) { @@ -275,7 +307,7 @@ struct ChatListView: View { userPickerShown = true } } - + @ViewBuilder var trailingToolbarItem: some View { switch chatModel.chatRunning { case .some(true): NewChatMenuButton() @@ -283,7 +315,7 @@ struct ChatListView: View { case .none: EmptyView() } } - + @ViewBuilder private var chatList: some View { let cs = filteredChats() ZStack { @@ -295,7 +327,8 @@ struct ChatListView: View { searchFocussed: $searchFocussed, searchText: $searchText, searchShowingSimplexLink: $searchShowingSimplexLink, - searchChatFilteredBySimplexLink: $searchChatFilteredBySimplexLink + searchChatFilteredBySimplexLink: $searchChatFilteredBySimplexLink, + parentSheet: $sheet ) .scaleEffect(x: 1, y: oneHandUI ? -1 : 1, anchor: .center) .listRowSeparator(.hidden) @@ -306,7 +339,7 @@ struct ChatListView: View { } if #available(iOS 16.0, *) { ForEach(cs, id: \.viewId) { chat in - ChatListNavLink(chat: chat) + ChatListNavLink(chat: chat, parentSheet: $sheet) .scaleEffect(x: 1, y: oneHandUI ? -1 : 1, anchor: .center) .padding(.trailing, -16) .disabled(chatModel.chatRunning != true || chatModel.deletedChats.contains(chat.chatInfo.id)) @@ -318,7 +351,7 @@ struct ChatListView: View { VStack(spacing: .zero) { Divider() .padding(.leading, 16) - ChatListNavLink(chat: chat) + ChatListNavLink(chat: chat, parentSheet: $sheet) .padding(.horizontal, 8) .padding(.vertical, 6) } @@ -363,80 +396,97 @@ struct ChatListView: View { } } if cs.isEmpty && !chatModel.chats.isEmpty { - Text("No filtered chats") + noChatsView() .scaleEffect(x: 1, y: oneHandUI ? -1 : 1, anchor: .center) .foregroundColor(.secondary) } } } + + @ViewBuilder private func noChatsView() -> some View { + if searchString().isEmpty { + switch chatTagsModel.activeFilter { + case .presetTag: Text("No filtered chats") // this should not happen + case let .userTag(tag): Text("No chats in list \(tag.chatTagText)") + case .unread: + Button { + chatTagsModel.activeFilter = nil + } label: { + HStack { + Image(systemName: "line.3.horizontal.decrease") + Text("No unread chats") + } + } + case .none: Text("No chats") + } + } else { + Text("No chats found") + } + } + private func unreadBadge(size: CGFloat = 18) -> some View { Circle() .frame(width: size, height: size) .foregroundColor(theme.colors.primary) } - + @ViewBuilder private func chatView() -> some View { if let chatId = chatModel.chatId, let chat = chatModel.getChat(chatId) { ChatView(chat: chat) } } - + func stopAudioPlayer() { VoiceItemState.smallView.values.forEach { $0.audioPlayer?.stop() } VoiceItemState.smallView = [:] } - + private func filteredChats() -> [Chat] { if let linkChatId = searchChatFilteredBySimplexLink { return chatModel.chats.filter { $0.id == linkChatId } } else { let s = searchString() - return s == "" && !showUnreadAndFavorites + return s == "" ? chatModel.chats.filter { chat in - !chat.chatInfo.chatDeleted && chatContactType(chat: chat) != ContactType.card + !chat.chatInfo.chatDeleted && !chat.chatInfo.contactCard && filtered(chat) } : chatModel.chats.filter { chat in let cInfo = chat.chatInfo - switch cInfo { + return switch cInfo { case let .direct(contact): - return !contact.chatDeleted && chatContactType(chat: chat) != ContactType.card && ( - s == "" - ? filtered(chat) - : (viewNameContains(cInfo, s) || - contact.profile.displayName.localizedLowercase.contains(s) || - contact.fullName.localizedLowercase.contains(s)) + !contact.chatDeleted && !chat.chatInfo.contactCard && ( + ( viewNameContains(cInfo, s) || + contact.profile.displayName.localizedLowercase.contains(s) || + contact.fullName.localizedLowercase.contains(s) + ) ) - case let .group(gInfo): - return s == "" - ? (filtered(chat) || gInfo.membership.memberStatus == .memInvited) - : viewNameContains(cInfo, s) - case .local: - return s == "" || viewNameContains(cInfo, s) - case .contactRequest: - return s == "" || viewNameContains(cInfo, s) - case let .contactConnection(conn): - return s != "" && conn.localAlias.localizedLowercase.contains(s) - case .invalidJSON: - return false + case .group: viewNameContains(cInfo, s) + case .local: viewNameContains(cInfo, s) + case .contactRequest: viewNameContains(cInfo, s) + case let .contactConnection(conn): conn.localAlias.localizedLowercase.contains(s) + case .invalidJSON: false } } } - - func searchString() -> String { - searchShowingSimplexLink ? "" : searchText.trimmingCharacters(in: .whitespaces).localizedLowercase - } - + func filtered(_ chat: Chat) -> Bool { - (chat.chatInfo.chatSettings?.favorite ?? false) || - chat.chatStats.unreadChat || - (chat.chatInfo.ntfsEnabled && chat.chatStats.unreadCount > 0) + switch chatTagsModel.activeFilter { + case let .presetTag(tag): presetTagMatchesChat(tag, chat.chatInfo) + case let .userTag(tag): chat.chatInfo.chatTags?.contains(tag.chatTagId) == true + case .unread: chat.chatStats.unreadChat || chat.chatInfo.ntfsEnabled && chat.chatStats.unreadCount > 0 + case .none: true + } } - + func viewNameContains(_ cInfo: ChatInfo, _ s: String) -> Bool { cInfo.chatViewName.localizedLowercase.contains(s) } } + + func searchString() -> String { + searchShowingSimplexLink ? "" : searchText.trimmingCharacters(in: .whitespaces).localizedLowercase + } } struct SubsStatusIndicator: View { @@ -500,18 +550,20 @@ struct SubsStatusIndicator: View { struct ChatListSearchBar: View { @EnvironmentObject var m: ChatModel @EnvironmentObject var theme: AppTheme + @EnvironmentObject var chatTagsModel: ChatTagsModel @Binding var searchMode: Bool @FocusState.Binding var searchFocussed: Bool @Binding var searchText: String @Binding var searchShowingSimplexLink: Bool @Binding var searchChatFilteredBySimplexLink: String? + @Binding var parentSheet: SomeSheet? @State private var ignoreSearchTextChange = false @State private var alert: PlanAndConnectAlert? @State private var sheet: PlanAndConnectActionSheet? - @AppStorage(DEFAULT_SHOW_UNREAD_AND_FAVORITES) private var showUnreadAndFavorites = false var body: some View { VStack(spacing: 12) { + ScrollView([.horizontal], showsIndicators: false) { ChatTagsView(parentSheet: $parentSheet) } HStack(spacing: 12) { HStack(spacing: 4) { Image(systemName: "magnifyingglass") @@ -578,16 +630,21 @@ struct ChatListSearchBar: View { } private func toggleFilterButton() -> some View { - ZStack { + let showUnread = chatTagsModel.activeFilter == .unread + return ZStack { Color.clear .frame(width: 22, height: 22) - Image(systemName: showUnreadAndFavorites ? "line.3.horizontal.decrease.circle.fill" : "line.3.horizontal.decrease") + Image(systemName: showUnread ? "line.3.horizontal.decrease.circle.fill" : "line.3.horizontal.decrease") .resizable() .scaledToFit() - .foregroundColor(showUnreadAndFavorites ? theme.colors.primary : theme.colors.secondary) - .frame(width: showUnreadAndFavorites ? 22 : 16, height: showUnreadAndFavorites ? 22 : 16) + .foregroundColor(showUnread ? theme.colors.primary : theme.colors.secondary) + .frame(width: showUnread ? 22 : 16, height: showUnread ? 22 : 16) .onTapGesture { - showUnreadAndFavorites = !showUnreadAndFavorites + if chatTagsModel.activeFilter == .unread { + chatTagsModel.activeFilter = nil + } else { + chatTagsModel.activeFilter = .unread + } } } } @@ -605,6 +662,185 @@ struct ChatListSearchBar: View { } } +struct ChatTagsView: View { + @EnvironmentObject var chatTagsModel: ChatTagsModel + @EnvironmentObject var chatModel: ChatModel + @EnvironmentObject var theme: AppTheme + @Binding var parentSheet: SomeSheet? + + var body: some View { + HStack { + tagsView() + } + } + + @ViewBuilder private func tagsView() -> some View { + if chatTagsModel.presetTags.count > 1 { + if chatTagsModel.presetTags.count + chatTagsModel.userTags.count <= 3 { + expandedPresetTagsFiltersView() + } else { + collapsedTagsFilterView() + } + } + let selectedTag: ChatTag? = if case let .userTag(tag) = chatTagsModel.activeFilter { + tag + } else { + nil + } + ForEach(chatTagsModel.userTags, id: \.id) { tag in + let current = tag == selectedTag + let color: Color = current ? .accentColor : .secondary + ZStack { + HStack(spacing: 4) { + if let emoji = tag.chatTagEmoji { + Text(emoji) + } else { + Image(systemName: current ? "tag.fill" : "tag") + .foregroundColor(color) + } + ZStack { + let badge = Text(verbatim: (chatTagsModel.unreadTags[tag.chatTagId] ?? 0) > 0 ? " ●" : "").font(.footnote) + (Text(tag.chatTagText).fontWeight(.semibold) + badge).foregroundColor(.clear) + Text(tag.chatTagText).fontWeight(current ? .semibold : .regular).foregroundColor(color) + badge.foregroundColor(theme.colors.primary) + } + } + .onTapGesture { + setActiveFilter(filter: .userTag(tag)) + } + .onLongPressGesture { + let screenHeight = UIScreen.main.bounds.height + let reservedSpace: Double = 4 * 44 // 2 for padding, 1 for "Create list" and another for extra tag + let tagsSpace = Double(max(chatTagsModel.userTags.count, 3)) * 44 + let fraction = min((reservedSpace + tagsSpace) / screenHeight, 0.62) + + parentSheet = SomeSheet( + content: { + AnyView( + NavigationView { + ChatListTag(chat: nil, showEditButton: true) + .modifier(ThemedBackground(grouped: true)) + } + ) + }, + id: "tag list", + fraction: fraction + ) + } + } + } + + Button { + parentSheet = SomeSheet( + content: { + AnyView( + NavigationView { + ChatListTagEditor() + } + ) + }, + id: "tag create" + ) + } label: { + if chatTagsModel.userTags.isEmpty { + HStack(spacing: 4) { + Image(systemName: "plus") + Text("Add list") + } + } else { + Image(systemName: "plus") + } + } + .foregroundColor(.secondary) + } + + @ViewBuilder private func expandedPresetTagsFiltersView() -> some View { + let selectedPresetTag: PresetTag? = if case let .presetTag(tag) = chatTagsModel.activeFilter { + tag + } else { + nil + } + ForEach(PresetTag.allCases, id: \.id) { tag in + if (chatTagsModel.presetTags[tag] ?? 0) > 0 { + let active = tag == selectedPresetTag + let (icon, text) = presetTagLabel(tag: tag, active: active) + let color: Color = active ? .accentColor : .secondary + + HStack(spacing: 4) { + Image(systemName: icon) + .foregroundColor(color) + ZStack { + Text(text).fontWeight(.semibold).foregroundColor(.clear) + Text(text).fontWeight(active ? .semibold : .regular).foregroundColor(color) + } + } + .onTapGesture { + setActiveFilter(filter: .presetTag(tag)) + } + } + } + } + + @ViewBuilder private func collapsedTagsFilterView() -> some View { + let selectedPresetTag: PresetTag? = if case let .presetTag(tag) = chatTagsModel.activeFilter { + tag + } else { + nil + } + Menu { + if selectedPresetTag != nil { + Button { + chatTagsModel.activeFilter = nil + } label: { + HStack { + Image(systemName: "list.bullet") + Text("All") + } + } + } + ForEach(PresetTag.allCases, id: \.id) { tag in + if (chatTagsModel.presetTags[tag] ?? 0) > 0 { + Button { + setActiveFilter(filter: .presetTag(tag)) + } label: { + let (systemName, text) = presetTagLabel(tag: tag, active: tag == selectedPresetTag) + HStack { + Image(systemName: systemName) + Text(text) + } + } + } + } + } label: { + if let tag = selectedPresetTag { + let (systemName, _) = presetTagLabel(tag: tag, active: true) + Image(systemName: systemName) + .foregroundColor(.accentColor) + } else { + Image(systemName: "list.bullet") + .foregroundColor(.secondary) + } + } + .frame(minWidth: 28) + } + + private func presetTagLabel(tag: PresetTag, active: Bool) -> (String, LocalizedStringKey) { + switch tag { + case .favorites: (active ? "star.fill" : "star", "Favorites") + case .contacts: (active ? "person.fill" : "person", "Contacts") + case .groups: (active ? "person.2.fill" : "person.2", "Groups") + case .business: (active ? "briefcase.fill" : "briefcase", "Businesses") + } + } + + private func setActiveFilter(filter: ActiveFilter) { + if filter != chatTagsModel.activeFilter { + chatTagsModel.activeFilter = filter + } else { + chatTagsModel.activeFilter = nil + } + } +} + func chatStoppedIcon() -> some View { Button { AlertManager.shared.showAlertMsg( @@ -616,6 +852,28 @@ func chatStoppedIcon() -> some View { } } +func presetTagMatchesChat(_ tag: PresetTag, _ chatInfo: ChatInfo) -> Bool { + switch tag { + case .favorites: + chatInfo.chatSettings?.favorite == true + case .contacts: + switch chatInfo { + case let .direct(contact): !(contact.activeConn == nil && contact.profile.contactLink != nil && contact.active) && !contact.chatDeleted + case .contactRequest: true + case .contactConnection: true + case let .group(groupInfo): groupInfo.businessChat?.chatType == .customer + default: false + } + case .groups: + switch chatInfo { + case let .group(groupInfo): groupInfo.businessChat == nil + default: false + } + case .business: + chatInfo.groupInfo?.businessChat?.chatType == .business + } +} + struct ChatListView_Previews: PreviewProvider { @State static var userPickerSheet: UserPickerSheet? = .none diff --git a/apps/ios/Shared/Views/Contacts/ContactListNavLink.swift b/apps/ios/Shared/Views/Contacts/ContactListNavLink.swift index 898a47cc86..242b492e83 100644 --- a/apps/ios/Shared/Views/Contacts/ContactListNavLink.swift +++ b/apps/ios/Shared/Views/Contacts/ContactListNavLink.swift @@ -20,7 +20,7 @@ struct ContactListNavLink: View { @State private var showContactRequestDialog = false var body: some View { - let contactType = chatContactType(chat: chat) + let contactType = chatContactType(chat) Group { switch (chat.chatInfo) { diff --git a/apps/ios/Shared/Views/NewChat/NewChatMenuButton.swift b/apps/ios/Shared/Views/NewChat/NewChatMenuButton.swift index 6f973983bf..39656c1534 100644 --- a/apps/ios/Shared/Views/NewChat/NewChatMenuButton.swift +++ b/apps/ios/Shared/Views/NewChat/NewChatMenuButton.swift @@ -186,7 +186,7 @@ struct NewChatSheet: View { } } -func chatContactType(chat: Chat) -> ContactType { +func chatContactType(_ chat: Chat) -> ContactType { switch chat.chatInfo { case .contactRequest: return .request @@ -207,7 +207,7 @@ func chatContactType(chat: Chat) -> ContactType { private func filterContactTypes(chats: [Chat], contactTypes: [ContactType]) -> [Chat] { return chats.filter { chat in - contactTypes.contains(chatContactType(chat: chat)) + contactTypes.contains(chatContactType(chat)) } } @@ -279,8 +279,8 @@ struct ContactsList: View { } private func chatsByTypeComparator(chat1: Chat, chat2: Chat) -> Bool { - let chat1Type = chatContactType(chat: chat1) - let chat2Type = chatContactType(chat: chat2) + let chat1Type = chatContactType(chat1) + let chat2Type = chatContactType(chat2) if chat1Type.rawValue < chat2Type.rawValue { return true diff --git a/apps/ios/Shared/Views/NewChat/NewChatView.swift b/apps/ios/Shared/Views/NewChat/NewChatView.swift index e18d932278..6e898f4cdf 100644 --- a/apps/ios/Shared/Views/NewChat/NewChatView.swift +++ b/apps/ios/Shared/Views/NewChat/NewChatView.swift @@ -25,6 +25,7 @@ struct SomeActionSheet: Identifiable { struct SomeSheet: Identifiable { @ViewBuilder var content: Content var id: String + var fraction = 0.4 } private enum NewChatViewAlert: Identifiable { diff --git a/apps/ios/Shared/Views/Onboarding/AddressCreationCard.swift b/apps/ios/Shared/Views/Onboarding/AddressCreationCard.swift index 2069ca9487..c8d0faafa7 100644 --- a/apps/ios/Shared/Views/Onboarding/AddressCreationCard.swift +++ b/apps/ios/Shared/Views/Onboarding/AddressCreationCard.swift @@ -21,7 +21,7 @@ struct AddressCreationCard: View { var body: some View { let addressExists = chatModel.userAddress != nil let chats = chatModel.chats.filter { chat in - !chat.chatInfo.chatDeleted && chatContactType(chat: chat) != ContactType.card + !chat.chatInfo.chatDeleted && !chat.chatInfo.contactCard } ZStack(alignment: .topTrailing) { HStack(alignment: .top, spacing: 16) { diff --git a/apps/ios/Shared/Views/Onboarding/CreateProfile.swift b/apps/ios/Shared/Views/Onboarding/CreateProfile.swift index 14ad9dfb08..409cb859ea 100644 --- a/apps/ios/Shared/Views/Onboarding/CreateProfile.swift +++ b/apps/ios/Shared/Views/Onboarding/CreateProfile.swift @@ -174,7 +174,6 @@ struct CreateFirstProfile: View { } .onAppear() { focusDisplayName = true - setLastVersionDefault() } .padding(.horizontal, 25) .padding(.top, 10) diff --git a/apps/ios/Shared/Views/Onboarding/SimpleXInfo.swift b/apps/ios/Shared/Views/Onboarding/SimpleXInfo.swift index a8704e964b..40dd29db53 100644 --- a/apps/ios/Shared/Views/Onboarding/SimpleXInfo.swift +++ b/apps/ios/Shared/Views/Onboarding/SimpleXInfo.swift @@ -89,6 +89,9 @@ struct SimpleXInfo: View { ) } } + .onAppear() { + setLastVersionDefault() + } .frame(maxHeight: .infinity) .padding(.horizontal, 25) .padding(.top, 75) diff --git a/apps/ios/SimpleX.xcodeproj/project.pbxproj b/apps/ios/SimpleX.xcodeproj/project.pbxproj index 759b16b196..ef98ddc678 100644 --- a/apps/ios/SimpleX.xcodeproj/project.pbxproj +++ b/apps/ios/SimpleX.xcodeproj/project.pbxproj @@ -167,9 +167,9 @@ 648010AB281ADD15009009B9 /* CIFileView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 648010AA281ADD15009009B9 /* CIFileView.swift */; }; 648679AB2BC96A74006456E7 /* ChatItemForwardingView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 648679AA2BC96A74006456E7 /* ChatItemForwardingView.swift */; }; 649B28DD2CFE07CF00536B68 /* libffi.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 649B28D82CFE07CF00536B68 /* libffi.a */; }; - 649B28DE2CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E-ghc9.6.3.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 649B28D92CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E-ghc9.6.3.a */; }; + 649B28DE2CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW-ghc9.6.3.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 649B28D92CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW-ghc9.6.3.a */; }; 649B28DF2CFE07CF00536B68 /* libgmpxx.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 649B28DA2CFE07CF00536B68 /* libgmpxx.a */; }; - 649B28E02CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 649B28DB2CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E.a */; }; + 649B28E02CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 649B28DB2CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW.a */; }; 649B28E12CFE07CF00536B68 /* libgmp.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 649B28DC2CFE07CF00536B68 /* libgmp.a */; }; 649BCDA0280460FD00C3A862 /* ComposeImageView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 649BCD9F280460FD00C3A862 /* ComposeImageView.swift */; }; 649BCDA22805D6EF00C3A862 /* CIImageView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 649BCDA12805D6EF00C3A862 /* CIImageView.swift */; }; @@ -203,6 +203,7 @@ 8CC4ED902BD7B8530078AEE8 /* CallAudioDeviceManager.swift in Sources */ = {isa = PBXBuildFile; fileRef = 8CC4ED8F2BD7B8530078AEE8 /* CallAudioDeviceManager.swift */; }; 8CC956EE2BC0041000412A11 /* NetworkObserver.swift in Sources */ = {isa = PBXBuildFile; fileRef = 8CC956ED2BC0041000412A11 /* NetworkObserver.swift */; }; 8CE848A32C5A0FA000D5C7C8 /* SelectableChatItemToolbars.swift in Sources */ = {isa = PBXBuildFile; fileRef = 8CE848A22C5A0FA000D5C7C8 /* SelectableChatItemToolbars.swift */; }; + B728945B2D0C62BF00F7A19A /* ElegantEmojiPicker in Frameworks */ = {isa = PBXBuildFile; productRef = B728945A2D0C62BF00F7A19A /* ElegantEmojiPicker */; }; B73EFE532CE5FA3500C778EA /* CreateSimpleXAddress.swift in Sources */ = {isa = PBXBuildFile; fileRef = B73EFE522CE5FA3500C778EA /* CreateSimpleXAddress.swift */; }; B76E6C312C5C41D900EC11AA /* ContactListNavLink.swift in Sources */ = {isa = PBXBuildFile; fileRef = B76E6C302C5C41D900EC11AA /* ContactListNavLink.swift */; }; B79ADAFF2CE4EF930083DFFD /* AddressCreationCard.swift in Sources */ = {isa = PBXBuildFile; fileRef = B79ADAFE2CE4EF930083DFFD /* AddressCreationCard.swift */; }; @@ -516,9 +517,9 @@ 648679AA2BC96A74006456E7 /* ChatItemForwardingView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = ChatItemForwardingView.swift; sourceTree = ""; }; 6493D667280ED77F007A76FB /* en */ = {isa = PBXFileReference; lastKnownFileType = text.plist.strings; name = en; path = en.lproj/Localizable.strings; sourceTree = ""; }; 649B28D82CFE07CF00536B68 /* libffi.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libffi.a; sourceTree = ""; }; - 649B28D92CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E-ghc9.6.3.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E-ghc9.6.3.a"; sourceTree = ""; }; + 649B28D92CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW-ghc9.6.3.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW-ghc9.6.3.a"; sourceTree = ""; }; 649B28DA2CFE07CF00536B68 /* libgmpxx.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmpxx.a; sourceTree = ""; }; - 649B28DB2CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E.a"; sourceTree = ""; }; + 649B28DB2CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW.a"; sourceTree = ""; }; 649B28DC2CFE07CF00536B68 /* libgmp.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmp.a; sourceTree = ""; }; 649BCD9F280460FD00C3A862 /* ComposeImageView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = ComposeImageView.swift; sourceTree = ""; }; 649BCDA12805D6EF00C3A862 /* CIImageView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = CIImageView.swift; sourceTree = ""; }; @@ -636,6 +637,7 @@ buildActionMask = 2147483647; files = ( 5CE2BA702845308900EC33A6 /* SimpleXChat.framework in Frameworks */, + B728945B2D0C62BF00F7A19A /* ElegantEmojiPicker in Frameworks */, 8C8118722C220B5B00E6FC94 /* Yams in Frameworks */, 8CB3476C2CF5CFFA006787A5 /* Ink in Frameworks */, D741547829AF89AF0022400A /* StoreKit.framework in Frameworks */, @@ -671,9 +673,9 @@ 5CE2BA93284534B000EC33A6 /* libiconv.tbd in Frameworks */, 649B28E12CFE07CF00536B68 /* libgmp.a in Frameworks */, 5CE2BA94284534BB00EC33A6 /* libz.tbd in Frameworks */, - 649B28E02CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E.a in Frameworks */, + 649B28E02CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW.a in Frameworks */, CE38A29C2C3FCD72005ED185 /* SwiftyGif in Frameworks */, - 649B28DE2CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E-ghc9.6.3.a in Frameworks */, + 649B28DE2CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW-ghc9.6.3.a in Frameworks */, 649B28DD2CFE07CF00536B68 /* libffi.a in Frameworks */, ); runOnlyForDeploymentPostprocessing = 0; @@ -754,8 +756,8 @@ 649B28D82CFE07CF00536B68 /* libffi.a */, 649B28DC2CFE07CF00536B68 /* libgmp.a */, 649B28DA2CFE07CF00536B68 /* libgmpxx.a */, - 649B28D92CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E-ghc9.6.3.a */, - 649B28DB2CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-3p784Fmu4gOAiEiFcsHj1E.a */, + 649B28D92CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW-ghc9.6.3.a */, + 649B28DB2CFE07CF00536B68 /* libHSsimplex-chat-6.2.0.7-1UFyc6WJuaw6s2eEIvrMnW.a */, ); path = Libraries; sourceTree = ""; @@ -1186,6 +1188,7 @@ D7197A1729AE89660055C05A /* WebRTC */, 8C8118712C220B5B00E6FC94 /* Yams */, 8CB3476B2CF5CFFA006787A5 /* Ink */, + B728945A2D0C62BF00F7A19A /* ElegantEmojiPicker */, ); productName = "SimpleX (iOS)"; productReference = 5CA059CA279559F40002BEB4 /* SimpleX.app */; @@ -1330,6 +1333,7 @@ D7197A1629AE89660055C05A /* XCRemoteSwiftPackageReference "WebRTC" */, 8C73C1162C21E17B00892670 /* XCRemoteSwiftPackageReference "Yams" */, 8CB3476A2CF5CFFA006787A5 /* XCRemoteSwiftPackageReference "ink" */, + B72894592D0C62BF00F7A19A /* XCRemoteSwiftPackageReference "Elegant-Emoji-Picker" */, ); productRefGroup = 5CA059CB279559F40002BEB4 /* Products */; projectDirPath = ""; @@ -2387,6 +2391,14 @@ version = 0.6.0; }; }; + B72894592D0C62BF00F7A19A /* XCRemoteSwiftPackageReference "Elegant-Emoji-Picker" */ = { + isa = XCRemoteSwiftPackageReference; + repositoryURL = "https://github.com/Finalet/Elegant-Emoji-Picker"; + requirement = { + branch = main; + kind = branch; + }; + }; D7197A1629AE89660055C05A /* XCRemoteSwiftPackageReference "WebRTC" */ = { isa = XCRemoteSwiftPackageReference; repositoryURL = "https://github.com/simplex-chat/WebRTC.git"; @@ -2429,6 +2441,11 @@ package = 8CB3476A2CF5CFFA006787A5 /* XCRemoteSwiftPackageReference "ink" */; productName = Ink; }; + B728945A2D0C62BF00F7A19A /* ElegantEmojiPicker */ = { + isa = XCSwiftPackageProductDependency; + package = B72894592D0C62BF00F7A19A /* XCRemoteSwiftPackageReference "Elegant-Emoji-Picker" */; + productName = ElegantEmojiPicker; + }; CE38A29B2C3FCD72005ED185 /* SwiftyGif */ = { isa = XCSwiftPackageProductDependency; package = D77B92DA2952372200A5A1CC /* XCRemoteSwiftPackageReference "SwiftyGif" */; diff --git a/apps/ios/SimpleX.xcodeproj/project.xcworkspace/xcshareddata/swiftpm/Package.resolved b/apps/ios/SimpleX.xcodeproj/project.xcworkspace/xcshareddata/swiftpm/Package.resolved index 7fdbff38af..2bddf5b5b8 100644 --- a/apps/ios/SimpleX.xcodeproj/project.xcworkspace/xcshareddata/swiftpm/Package.resolved +++ b/apps/ios/SimpleX.xcodeproj/project.xcworkspace/xcshareddata/swiftpm/Package.resolved @@ -1,5 +1,5 @@ { - "originHash" : "33afc44be5f4225325b3cb940ed71b6cbf3ef97290d348d7b6803697bcd0637d", + "originHash" : "07434ae88cbf078ce3d27c91c1f605836aaebff0e0cef5f25317795151c77db1", "pins" : [ { "identity" : "codescanner", @@ -10,6 +10,15 @@ "version" : "2.5.0" } }, + { + "identity" : "elegant-emoji-picker", + "kind" : "remoteSourceControl", + "location" : "https://github.com/Finalet/Elegant-Emoji-Picker", + "state" : { + "branch" : "main", + "revision" : "71d2d46092b4d550cc593614efc06438f845f6e6" + } + }, { "identity" : "ink", "kind" : "remoteSourceControl", diff --git a/apps/ios/SimpleXChat/APITypes.swift b/apps/ios/SimpleXChat/APITypes.swift index 884993f542..b6a8edb201 100644 --- a/apps/ios/SimpleXChat/APITypes.swift +++ b/apps/ios/SimpleXChat/APITypes.swift @@ -40,10 +40,16 @@ public enum ChatCommand { case testStorageEncryption(key: String) case apiSaveSettings(settings: AppSettings) case apiGetSettings(settings: AppSettings) + case apiGetChatTags(userId: Int64) case apiGetChats(userId: Int64) case apiGetChat(type: ChatType, id: Int64, pagination: ChatPagination, search: String) case apiGetChatItemInfo(type: ChatType, id: Int64, itemId: Int64) case apiSendMessages(type: ChatType, id: Int64, live: Bool, ttl: Int?, composedMessages: [ComposedMessage]) + case apiCreateChatTag(tag: ChatTagData) + case apiSetChatTags(type: ChatType, id: Int64, tagIds: [Int64]) + case apiDeleteChatTag(tagId: Int64) + case apiUpdateChatTag(tagId: Int64, tagData: ChatTagData) + case apiReorderChatTags(tagIds: [Int64]) case apiCreateChatItems(noteFolderId: Int64, composedMessages: [ComposedMessage]) case apiUpdateChatItem(type: ChatType, id: Int64, itemId: Int64, msg: MsgContent, live: Bool) case apiDeleteChatItem(type: ChatType, id: Int64, itemIds: [Int64], mode: CIDeleteMode) @@ -198,6 +204,7 @@ public enum ChatCommand { case let .testStorageEncryption(key): return "/db test key \(key)" case let .apiSaveSettings(settings): return "/_save app settings \(encodeJSON(settings))" case let .apiGetSettings(settings): return "/_get app settings \(encodeJSON(settings))" + case let .apiGetChatTags(userId): return "/_get tags \(userId)" case let .apiGetChats(userId): return "/_get chats \(userId) pcc=on" case let .apiGetChat(type, id, pagination, search): return "/_get chat \(ref(type, id)) \(pagination.cmdString)" + (search == "" ? "" : " search=\(search)") @@ -206,6 +213,11 @@ public enum ChatCommand { let msgs = encodeJSON(composedMessages) let ttlStr = ttl != nil ? "\(ttl!)" : "default" return "/_send \(ref(type, id)) live=\(onOff(live)) ttl=\(ttlStr) json \(msgs)" + case let .apiCreateChatTag(tag): return "/_create tag \(encodeJSON(tag))" + case let .apiSetChatTags(type, id, tagIds): return "/_tags \(ref(type, id)) \(tagIds.map({ "\($0)" }).joined(separator: ","))" + case let .apiDeleteChatTag(tagId): return "/_delete tag \(tagId)" + case let .apiUpdateChatTag(tagId, tagData): return "/_update tag \(tagId) \(encodeJSON(tagData))" + case let .apiReorderChatTags(tagIds): return "/_reorder tags \(tagIds.map({ "\($0)" }).joined(separator: ","))" case let .apiCreateChatItems(noteFolderId, composedMessages): let msgs = encodeJSON(composedMessages) return "/_create *\(noteFolderId) json \(msgs)" @@ -367,10 +379,16 @@ public enum ChatCommand { case .testStorageEncryption: return "testStorageEncryption" case .apiSaveSettings: return "apiSaveSettings" case .apiGetSettings: return "apiGetSettings" + case .apiGetChatTags: return "apiGetChatTags" case .apiGetChats: return "apiGetChats" case .apiGetChat: return "apiGetChat" case .apiGetChatItemInfo: return "apiGetChatItemInfo" case .apiSendMessages: return "apiSendMessages" + case .apiCreateChatTag: return "apiCreateChatTag" + case .apiSetChatTags: return "apiSetChatTags" + case .apiDeleteChatTag: return "apiDeleteChatTag" + case .apiUpdateChatTag: return "apiUpdateChatTag" + case .apiReorderChatTags: return "apiReorderChatTags" case .apiCreateChatItems: return "apiCreateChatItems" case .apiUpdateChatItem: return "apiUpdateChatItem" case .apiDeleteChatItem: return "apiDeleteChatItem" @@ -564,6 +582,7 @@ public enum ChatResponse: Decodable, Error { case chatSuspended case apiChats(user: UserRef, chats: [ChatData]) case apiChat(user: UserRef, chat: ChatData) + case chatTags(user: UserRef, userTags: [ChatTag]) case chatItemInfo(user: UserRef, chatItem: AChatItem, chatItemInfo: ChatItemInfo) case serverTestResult(user: UserRef, testServer: String, testFailure: ProtocolTestFailure?) case serverOperatorConditions(conditions: ServerOperatorConditions) @@ -590,6 +609,7 @@ public enum ChatResponse: Decodable, Error { case contactCode(user: UserRef, contact: Contact, connectionCode: String) case groupMemberCode(user: UserRef, groupInfo: GroupInfo, member: GroupMember, connectionCode: String) case connectionVerified(user: UserRef, verified: Bool, expectedCode: String) + case tagsUpdated(user: UserRef, userTags: [ChatTag], chatTags: [Int64]) case invitation(user: UserRef, connReqInvitation: String, connection: PendingContactConnection) case connectionIncognitoUpdated(user: UserRef, toConnection: PendingContactConnection) case connectionUserChanged(user: UserRef, fromConnection: PendingContactConnection, toConnection: PendingContactConnection, newUser: UserRef) @@ -741,6 +761,7 @@ public enum ChatResponse: Decodable, Error { case .chatSuspended: return "chatSuspended" case .apiChats: return "apiChats" case .apiChat: return "apiChat" + case .chatTags: return "chatTags" case .chatItemInfo: return "chatItemInfo" case .serverTestResult: return "serverTestResult" case .serverOperatorConditions: return "serverOperators" @@ -767,6 +788,7 @@ public enum ChatResponse: Decodable, Error { case .contactCode: return "contactCode" case .groupMemberCode: return "groupMemberCode" case .connectionVerified: return "connectionVerified" + case .tagsUpdated: return "tagsUpdated" case .invitation: return "invitation" case .connectionIncognitoUpdated: return "connectionIncognitoUpdated" case .connectionUserChanged: return "connectionUserChanged" @@ -914,6 +936,7 @@ public enum ChatResponse: Decodable, Error { case .chatSuspended: return noDetails case let .apiChats(u, chats): return withUser(u, String(describing: chats)) case let .apiChat(u, chat): return withUser(u, String(describing: chat)) + case let .chatTags(u, userTags): return withUser(u, "userTags: \(String(describing: userTags))") case let .chatItemInfo(u, chatItem, chatItemInfo): return withUser(u, "chatItem: \(String(describing: chatItem))\nchatItemInfo: \(String(describing: chatItemInfo))") case let .serverTestResult(u, server, testFailure): return withUser(u, "server: \(server)\nresult: \(String(describing: testFailure))") case let .serverOperatorConditions(conditions): return "conditions: \(String(describing: conditions))" @@ -942,6 +965,7 @@ public enum ChatResponse: Decodable, Error { case let .contactCode(u, contact, connectionCode): return withUser(u, "contact: \(String(describing: contact))\nconnectionCode: \(connectionCode)") case let .groupMemberCode(u, groupInfo, member, connectionCode): return withUser(u, "groupInfo: \(String(describing: groupInfo))\nmember: \(String(describing: member))\nconnectionCode: \(connectionCode)") case let .connectionVerified(u, verified, expectedCode): return withUser(u, "verified: \(verified)\nconnectionCode: \(expectedCode)") + case let .tagsUpdated(u, userTags, chatTags): return withUser(u, "userTags: \(String(describing: userTags))\nchatTags: \(String(describing: chatTags))") case let .invitation(u, connReqInvitation, connection): return withUser(u, "connReqInvitation: \(connReqInvitation)\nconnection: \(connection)") case let .connectionIncognitoUpdated(u, toConnection): return withUser(u, String(describing: toConnection)) case let .connectionUserChanged(u, fromConnection, toConnection, newUser): return withUser(u, "fromConnection: \(String(describing: fromConnection))\ntoConnection: \(String(describing: toConnection))\newUserId: \(String(describing: newUser.userId))") @@ -1172,6 +1196,16 @@ public enum ChatPagination { } } +public struct ChatTagData: Encodable { + public var emoji: String? + public var text: String + + public init(emoji: String?, text: String) { + self.emoji = emoji + self.text = text + } +} + public struct ComposedMessage: Encodable { public var fileSource: CryptoFile? var quotedItemId: Int64? @@ -2000,6 +2034,10 @@ public struct ConnectionStats: Decodable, Hashable { public var ratchetSyncSendProhibited: Bool { [.required, .started, .agreed].contains(ratchetSyncState) } + + public var ratchetSyncInProgress: Bool { + [.started, .agreed].contains(ratchetSyncState) + } } public struct RcvQueueInfo: Codable, Hashable { diff --git a/apps/ios/SimpleXChat/ChatTypes.swift b/apps/ios/SimpleXChat/ChatTypes.swift index da1ce24b73..b1a318c896 100644 --- a/apps/ios/SimpleXChat/ChatTypes.swift +++ b/apps/ios/SimpleXChat/ChatTypes.swift @@ -1334,6 +1334,13 @@ public enum ChatInfo: Identifiable, Decodable, NamedChat, Hashable { } } + public var contactCard: Bool { + switch self { + case let .direct(contact): contact.activeConn == nil && contact.profile.contactLink != nil && contact.active + default: false + } + } + public var groupInfo: GroupInfo? { switch self { case let .group(groupInfo): return groupInfo @@ -1444,6 +1451,14 @@ public enum ChatInfo: Identifiable, Decodable, NamedChat, Hashable { default: return nil } } + + public var chatTags: [Int64]? { + switch self { + case let .direct(contact): return contact.chatTags + case let .group(groupInfo): return groupInfo.chatTags + default: return nil + } + } var createdAt: Date { switch self { @@ -1545,6 +1560,7 @@ public struct Contact: Identifiable, Decodable, NamedChat, Hashable { var chatTs: Date? var contactGroupMemberId: Int64? var contactGrpInvSent: Bool + public var chatTags: [Int64] public var uiThemes: ThemeModeOverrides? public var chatDeleted: Bool @@ -1615,6 +1631,7 @@ public struct Contact: Identifiable, Decodable, NamedChat, Hashable { createdAt: .now, updatedAt: .now, contactGrpInvSent: false, + chatTags: [], chatDeleted: false ) } @@ -1910,6 +1927,7 @@ public struct GroupInfo: Identifiable, Decodable, NamedChat, Hashable { public var fullName: String { get { groupProfile.fullName } } public var image: String? { get { groupProfile.image } } public var localAlias: String { "" } + public var chatTags: [Int64] public var isOwner: Bool { return membership.memberRole == .owner && membership.memberCurrent @@ -1932,7 +1950,8 @@ public struct GroupInfo: Identifiable, Decodable, NamedChat, Hashable { hostConnCustomUserProfileId: nil, chatSettings: ChatSettings.defaults, createdAt: .now, - updatedAt: .now + updatedAt: .now, + chatTags: [] ) } @@ -1991,6 +2010,14 @@ public struct GroupMember: Identifiable, Decodable, Hashable { public var activeConn: Connection? public var id: String { "#\(groupId) @\(groupMemberId)" } + public var ready: Bool { get { activeConn?.connStatus == .ready } } + public var sndReady: Bool { get { ready || activeConn?.connStatus == .sndReady } } + public var sendMsgEnabled: Bool { get { + sndReady + && memberCurrent + && !(activeConn?.connectionStats?.ratchetSyncSendProhibited ?? false) + && !(activeConn?.connDisabled ?? true) + } } public var displayName: String { get { let p = memberProfile @@ -4210,6 +4237,20 @@ public enum ChatItemTTL: Identifiable, Comparable, Hashable { } } +public struct ChatTag: Decodable, Hashable { + public var chatTagId: Int64 + public var chatTagText: String + public var chatTagEmoji: String? + + public var id: Int64 { chatTagId } + + public init(chatTagId: Int64, chatTagText: String, chatTagEmoji: String?) { + self.chatTagId = chatTagId + self.chatTagText = chatTagText + self.chatTagEmoji = chatTagEmoji + } +} + public struct ChatItemInfo: Decodable, Hashable { public var itemVersions: [ChatItemVersion] public var memberDeliveryStatuses: [MemberDeliveryStatus]? diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt index d407174e52..db90c2e573 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/ChatModel.kt @@ -1575,6 +1575,13 @@ data class GroupMember ( var activeConn: Connection? = null ): NamedChat { val id: String get() = "#$groupId @$groupMemberId" + val ready get() = activeConn?.connStatus == ConnStatus.Ready + val sndReady get() = ready || activeConn?.connStatus == ConnStatus.SndReady + val sendMsgEnabled get() = + sndReady + && memberCurrent + && !(activeConn?.connectionStats?.ratchetSyncSendProhibited ?: false) + && !(activeConn?.connDisabled ?: true) override val displayName: String get() { val p = memberProfile diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt index e95fdb446f..7e3d8597b4 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt @@ -6032,6 +6032,9 @@ class ConnectionStats( val ratchetSyncSendProhibited: Boolean get() = listOf(RatchetSyncState.Required, RatchetSyncState.Started, RatchetSyncState.Agreed).contains(ratchetSyncState) + + val ratchetSyncInProgress: Boolean get() = + listOf(RatchetSyncState.Started, RatchetSyncState.Agreed).contains(ratchetSyncState) } @Serializable diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chat/group/GroupMemberInfoView.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chat/group/GroupMemberInfoView.kt index c9ac464438..e4e5494364 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chat/group/GroupMemberInfoView.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chat/group/GroupMemberInfoView.kt @@ -89,29 +89,34 @@ fun GroupMemberInfoView( } }, createMemberContact = { - if (connectionStats != null) { - if (connectionStats.ratchetSyncState == RatchetSyncState.Ok) { - withBGApi { - progressIndicator = true - val memberContact = chatModel.controller.apiCreateMemberContact(rhId, groupInfo.apiId, member.groupMemberId) - if (memberContact != null) { - val memberChat = Chat(remoteHostId = rhId, ChatInfo.Direct(memberContact), chatItems = arrayListOf()) - withChats { - addChat(memberChat) - openLoadedChat(memberChat) - } - closeAll() - chatModel.setContactNetworkStatus(memberContact, NetworkStatus.Connected()) + if (member.sendMsgEnabled) { + withBGApi { + progressIndicator = true + val memberContact = chatModel.controller.apiCreateMemberContact(rhId, groupInfo.apiId, member.groupMemberId) + if (memberContact != null) { + val memberChat = Chat(remoteHostId = rhId, ChatInfo.Direct(memberContact), chatItems = arrayListOf()) + withChats { + addChat(memberChat) + openLoadedChat(memberChat) } - progressIndicator = false + closeAll() + chatModel.setContactNetworkStatus(memberContact, NetworkStatus.Connected()) } - } else if (connectionStats.ratchetSyncAllowed) { + progressIndicator = false + } + } else if (connectionStats != null) { + if (connectionStats.ratchetSyncAllowed) { showFixConnectionAlert(syncConnection = { syncMemberConnection() }) - } else { + } else if (connectionStats.ratchetSyncInProgress) { AlertManager.shared.showAlertMsg( generalGetString(MR.strings.cant_send_message_to_member_alert_title), generalGetString(MR.strings.encryption_renegotiation_in_progress) ) + } else { + AlertManager.shared.showAlertMsg( + generalGetString(MR.strings.cant_send_message_to_member_alert_title), + generalGetString(MR.strings.connection_not_ready) + ) } } }, @@ -366,7 +371,11 @@ fun GroupMemberInfoLayout( if (contactId != null) { OpenChatButton(modifier = Modifier.fillMaxWidth(0.33f), onClick = { openDirectChat(contactId) }) // legacy - only relevant for direct contacts created when joining group } else { - OpenChatButton(modifier = Modifier.fillMaxWidth(0.33f), onClick = { createMemberContact() }) + OpenChatButton( + modifier = Modifier.fillMaxWidth(0.33f), + disabledLook = !(member.sendMsgEnabled || (member.activeConn?.connectionStats?.ratchetSyncAllowed ?: false)), + onClick = { createMemberContact() } + ) } InfoViewActionButton(modifier = Modifier.fillMaxWidth(0.5f), painterResource(MR.images.ic_call), generalGetString(MR.strings.info_view_call_button), disabled = false, disabledLook = true, onClick = { showSendMessageToEnableCallsAlert() @@ -437,12 +446,12 @@ fun GroupMemberInfoLayout( SectionDividerSpaced() SectionView(title = stringResource(MR.strings.conn_stats_section_title_servers)) { SwitchAddressButton( - disabled = cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null } || cStats.ratchetSyncSendProhibited, + disabled = cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null } || !member.sendMsgEnabled, switchAddress = switchMemberAddress ) if (cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null }) { AbortSwitchAddressButton( - disabled = cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null && !it.canAbortSwitch } || cStats.ratchetSyncSendProhibited, + disabled = cStats.rcvQueuesInfo.any { it.rcvSwitchStatus != null && !it.canAbortSwitch } || !member.sendMsgEnabled, abortSwitchAddress = abortSwitchMemberAddress ) } @@ -602,6 +611,7 @@ fun RemoveMemberButton(onClick: () -> Unit) { @Composable fun OpenChatButton( modifier: Modifier, + disabledLook: Boolean = false, onClick: () -> Unit ) { InfoViewActionButton( @@ -609,7 +619,7 @@ fun OpenChatButton( icon = painterResource(MR.images.ic_chat_bubble), title = generalGetString(MR.strings.info_view_message_button), disabled = false, - disabledLook = false, + disabledLook = disabledLook, onClick = onClick ) } diff --git a/apps/multiplatform/common/src/commonMain/resources/MR/base/strings.xml b/apps/multiplatform/common/src/commonMain/resources/MR/base/strings.xml index 34788b5bde..a209126a89 100644 --- a/apps/multiplatform/common/src/commonMain/resources/MR/base/strings.xml +++ b/apps/multiplatform/common/src/commonMain/resources/MR/base/strings.xml @@ -1696,6 +1696,7 @@ Can\'t call group member Send message to enable calls. Can\'t message group member + Connection not ready. Welcome message diff --git a/apps/simplex-chat/Server.hs b/apps/simplex-chat/Server.hs index 5351565946..fddad1cf2c 100644 --- a/apps/simplex-chat/Server.hs +++ b/apps/simplex-chat/Server.hs @@ -19,9 +19,9 @@ import GHC.Generics (Generic) import Network.Socket import qualified Network.WebSockets as WS import Numeric.Natural (Natural) -import Simplex.Chat import Simplex.Chat.Controller import Simplex.Chat.Core +import Simplex.Chat.Library.Commands import Simplex.Chat.Options import Simplex.Messaging.Transport.Server (runLocalTCPServer) import Simplex.Messaging.Util (raceAny_) diff --git a/blog/20241016-wired-attack-on-privacy.md b/blog/20241016-wired-attack-on-privacy.md index 3bc69c8176..1c2961e98a 100644 --- a/blog/20241016-wired-attack-on-privacy.md +++ b/blog/20241016-wired-attack-on-privacy.md @@ -10,6 +10,8 @@ permalink: "/blog/20241016-wired-attack-on-privacy.html" # Wired’s Attack on Privacy +**Published:** Oct 16, 2024 + The [Wired article](https://www.wired.com/story/neo-nazis-flee-telegram-encrypted-app-simplex/) by David Gilbert focusing on neo-Nazis moving to SimpleX Chat following the Telegram's changes in privacy policy is biased and misleading. By cherry-picking information from [the report](https://www.isdglobal.org/digital_dispatches/neo-nazi-accelerationists-seek-new-digital-refuge-amid-looming-telegram-crackdown/) by the Institute for Strategic Dialogue (ISD), Wired fails to mention that SimpleX network design prioritizes privacy in order to protect human rights defenders, journalists, and everyday users who value their privacy — many people feel safer using SimpleX than non-private apps, being protected from strangers contacting them. diff --git a/blog/20241218-oppose-digital-ids-they-break-law-lead-to-mass-scale-surveillance.md b/blog/20241218-oppose-digital-ids-they-break-law-lead-to-mass-scale-surveillance.md new file mode 100644 index 0000000000..8a8fffffb4 --- /dev/null +++ b/blog/20241218-oppose-digital-ids-they-break-law-lead-to-mass-scale-surveillance.md @@ -0,0 +1,53 @@ +--- +layout: layouts/article.html +title: "Oppose digital IDs – they break the law and lead to mass scale surveillance" +date: 2024-12-18 +preview: Starting next year, the UK government plans to introduce digital ID cards for the young people to prove their age when visiting pubs. +image: images/20241218-pub.jpg +imageWide: true +permalink: "/blog/20241218-oppose-digital-ids-they-break-law-lead-to-mass-scale-surveillance.html" +--- + +# Oppose digital IDs – they break the law and lead to mass scale surveillance + +**Published:** Dec 18, 2024 + + + +Starting next year, the UK government plans to introduce [digital ID cards](https://www.telegraph.co.uk/politics/2024/12/08/digital-id-to-be-introduced-for-pubs-and-clubs/) for the young people to prove their age when visiting pubs. While officials claim this system will remain optional, it's part of a broader government initiative to move more state functions online so that people can prove their identity for everything from paying taxes to opening a bank account using the government-backed app. This will be a step toward a society where every pub visit, purchase, and social interaction becomes a permanent digital record linked to a government-issued ID – a step to normalizing mass surveillance at scale. + +Digital IDs are promoted as a way to fight law violations, and some politicians support them as [a way to tackle illegal immigration](https://www.telegraph.co.uk/politics/2024/07/10/id-cards-inevitable-tackle-immigration-lord-blunkett-labour/). But digital IDs themselves break the law. Article 8 of the European Convention of Human Rights says: “Everyone has the right to respect for his private and family life”. It means that not only our right to privacy is enshrined in the law, but the right to have our privacy respected is also part of the law. Asking to present a digital ID when visiting a pub, even if it is optional, disrespects our privacy, and is therefore illegal. + +Digital IDs would not stop people who decide to break laws. Pubs already can refuse to serve alcohol to young people and require the ID in case the age is in doubt. And illegal immigration can also be reduced without any digital IDs. But introducing digital IDs and collecting our actions, names and locations in one government-controlled database will result in making this information easier to access for criminals, and being exploited for financial and identity crimes. + +What starts as a "convenient option" is likely to end as a mandatory requirement. The digital ID systems being pushed by governments and corporations aren't about making our lives easier. They're about tracking, monitoring, and controlling every move we make. And we can see [where this road leads in China](https://www.wired.com/story/china-social-credit-system-explained/), when IDs and social scores created for convenience are used to prevent access to basic services and bank accounts as a punishment for legal social media posts that the government disagrees with. What started as a convenience, is now trialed [to track the duration of public toilet visits](https://www.thesun.ie/news/13154812/china-installs-toilet-timers-to-broadcast-time-spent/). + +The United Kingdom is a democratic country, and the law protects our right to privacy and freedom of speech. If we accept digital IDs as something required for simple things, like buying a drink, it leaves the door wide open to a range of privacy violations. + +We call on everyone to oppose the digital ID systems. Do not use them. Do not install these systems in your pub, for as long as it is not legally required. Support local businesses that don’t use them. Protect your privacy and freedom by using software that respects them. Demand that your privacy is respected, as required by law. + +To make your voice heard, email your MP expressing your rejection of digital IDs as a violation of European Convention of Human Rights in three simple steps: + +1. **Copy the text below** or [click this link](mailto:?subject=Please%20oppose%20the%20plan%20for%20Digital%20IDs&body=Dear%20%E2%80%A6%2C%0A%0AI%20object%20to%20the%20introduction%20of%20digital%20IDs%20in%20pubs%20or%20any%20other%20public%20places%20for%20these%20reasons%3A%0A%0A1.%20It%20violates%20the%20European%20Convention%20of%20Human%20Rights%2C%20article%208%3A%20%E2%80%9CEveryone%20has%20the%20right%20to%20respect%20for%20his%20private%20and%20family%20life%E2%80%9D%20(https%3A%2F%2Ffra.europa.eu%2Fen%2Flaw-reference%2Feuropean-convention-human-rights-article-8-0).%0AAsking%20to%20present%20digital%20IDs%20when%20proof%20of%20identity%20is%20not%20legally%20required%2C%20even%20if%20it%20is%20optional%2C%20disrespects%20our%20privacy%2C%20and%20is%20therefore%20illegal.%0A%0A2.%20It%20will%20not%20be%20an%20effective%20measure%20in%20reducing%20the%20violations%20of%20the%20law.%20People%20who%20want%20to%20circumvent%20it%2C%20will%20find%20a%20way.%0A%0A3.%20It%20will%20increase%20crime%2C%20because%20combining%20a%20large%20amount%20of%20private%20information%20in%20a%20single%20system%20increases%20the%20risks%20of%20this%20information%20becoming%20available%20to%20criminals%2C%20who%20will%20exploit%20it%20for%20financial%20crimes%20and%20identity%20theft.%0A%0AI%20kindly%20ask%20you%20to%20oppose%20this%20plan%2C%20both%20publicly%20and%20during%20any%20discussions%20in%20the%20UK%20Parliament.%0A%0ASincerely%20yours%2C%0A%E2%80%A6) to copy it into email app: + +*Dear …,* + +*I object to the introduction of digital IDs in pubs or any other public places for these reasons:* + +1. *It violates the European Convention of Human Rights, article 8: “Everyone has the right to respect for his private and family life” (https://fra.europa.eu/en/law-reference/european-convention-human-rights-article-8-0).* +*Asking to present digital IDs when proof of identity is not legally required, even if it is optional, disrespects our privacy, and is therefore illegal.* +2. *It will not be an effective measure in reducing the violations of the law. People who want to circumvent it, will find a way.* +3. *It will increase crime, because combining a large amount of private information in a single system increases the risks of this information becoming available to criminals, who will exploit it for financial crimes and identity theft.* + +*I kindly ask you to oppose this plan, both publicly and during any discussions in the UK Parliament.* + +*Sincerely yours,* +*…* + +2. [**Find the email address of your MP**](https://members.parliament.uk/members/Commons) and copy it to the email. + +3. Fill in the blanks, edit the text if needed, and **send it**! + +Public opposition changed government decisions in many cases. + +It is your opportunity to tell the government which country you want to live in — please use it! diff --git a/blog/images/20241218-pub.jpg b/blog/images/20241218-pub.jpg new file mode 100644 index 0000000000..0acd5d7dc1 Binary files /dev/null and b/blog/images/20241218-pub.jpg differ diff --git a/cabal.project b/cabal.project index 5a1e7fd473..75baa5dd0d 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 0a827307d666de819d5cef17f70a78be5cd0e410 + tag: f5cef2556b05cf384db284644c112f822407b361 source-repository-package type: git diff --git a/package.yaml b/package.yaml index 5c75408111..de88891aa7 100644 --- a/package.yaml +++ b/package.yaml @@ -10,6 +10,7 @@ copyright: 2020-22 simplex.chat category: Web, System, Services, Cryptography extra-source-files: - README.md + - PRIVACY.md - cabal.project dependencies: diff --git a/scripts/flatpak/chat.simplex.simplex.metainfo.xml b/scripts/flatpak/chat.simplex.simplex.metainfo.xml index 9570f4bbca..9b915532f7 100644 --- a/scripts/flatpak/chat.simplex.simplex.metainfo.xml +++ b/scripts/flatpak/chat.simplex.simplex.metainfo.xml @@ -38,6 +38,25 @@ + + https://simplex.chat/blog/20241210-simplex-network-v6-2-servers-by-flux-business-chats.html + +

New in v6.2.1:

+
    +
  • fixes
    • +
  • offer to "fix" encryption when calling or making direct connection with member.
    • +
  • broken layout.
    • +
  • option to enable debug logs (disabled by default).
    • +
  • show who reacted in direct chats.
    • +
+

New in v6.2:

+
    +
  • SimpleX Chat and Flux made an agreement to include servers operated by Flux into the app – to improve metadata privacy.
    • +
  • Business chats – your customers privacy.
    • +
  • Improved user experience in chats: open on the first unread, jump to quoted messages, see who reacted.
    • +
+ + https://simplex.chat/blog/20241210-simplex-network-v6-2-servers-by-flux-business-chats.html diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index d270069a15..2bd862692c 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."0a827307d666de819d5cef17f70a78be5cd0e410" = "09z0y6w1c51szd9r90fl259inn76yahfbb164mawd34sr41ccp7g"; + "https://github.com/simplex-chat/simplexmq.git"."f5cef2556b05cf384db284644c112f822407b361" = "14w0fji1fdr63w4pjkhlrdiz93p2axghzkb1ykvnrw111by87g8l"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 99313028a6..b82e2c2c23 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -16,6 +16,7 @@ license-file: LICENSE build-type: Simple extra-source-files: README.md + PRIVACY.md cabal.project flag swift @@ -36,6 +37,9 @@ library Simplex.Chat.Files Simplex.Chat.Help Simplex.Chat.Image + Simplex.Chat.Library.Commands + Simplex.Chat.Library.Internal + Simplex.Chat.Library.Subscriber Simplex.Chat.Markdown Simplex.Chat.Messages Simplex.Chat.Messages.Batch @@ -156,6 +160,7 @@ library Simplex.Chat.Migrations.M20241125_indexes Simplex.Chat.Migrations.M20241128_business_chats Simplex.Chat.Migrations.M20241205_business_chat_members + Simplex.Chat.Migrations.M20241206_chat_tags Simplex.Chat.Mobile Simplex.Chat.Mobile.File Simplex.Chat.Mobile.Shared diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index f74e5ea070..7a23792a6a 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,131 +11,43 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat where -import Control.Applicative (optional, (<|>)) -import Control.Concurrent.STM (retry) import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift -import Control.Monad.Reader -import Crypto.Random (ChaChaDRG) -import qualified Data.Aeson as J -import Data.Attoparsec.ByteString.Char8 (Parser) -import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.Bifunctor (bimap, first, second) +import Data.Bifunctor (bimap, second) import Data.ByteArray (ScrubbedBytes) -import qualified Data.ByteArray as BA -import qualified Data.ByteString.Base64 as B64 -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Char -import Data.Constraint (Dict (..)) -import Data.Either (fromRight, lefts, partitionEithers, rights) -import Data.Fixed (div') -import Data.Foldable (foldr') -import Data.Functor (($>)) -import Data.Functor.Identity -import Data.Int (Int64) -import Data.List (find, foldl', isSuffixOf, mapAccumL, partition, sortOn, zipWith4) -import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.List (partition, sortOn) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L -import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) -import qualified Data.Set as S +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime) -import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay, nominalDiffTimeToSeconds) -import Data.Type.Equality -import qualified Data.UUID as UUID -import qualified Data.UUID.V4 as V4 -import Data.Word (Word32) -import qualified Database.SQLite.Simple as SQL -import Simplex.Chat.Archive -import Simplex.Chat.Call +import Data.Time.Clock (getCurrentTime) import Simplex.Chat.Controller -import Simplex.Chat.Files -import Simplex.Chat.Markdown -import Simplex.Chat.Messages -import Simplex.Chat.Messages.Batch (MsgBatch (..), batchMessages) -import Simplex.Chat.Messages.CIContent -import Simplex.Chat.Messages.CIContent.Events +import Simplex.Chat.Library.Commands import Simplex.Chat.Operators import Simplex.Chat.Options -import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol -import Simplex.Chat.Remote -import Simplex.Chat.Remote.Types -import Simplex.Chat.Stats import Simplex.Chat.Store -import Simplex.Chat.Store.AppSettings -import Simplex.Chat.Store.Connections -import Simplex.Chat.Store.Direct -import Simplex.Chat.Store.Files -import Simplex.Chat.Store.Groups -import Simplex.Chat.Store.Messages -import Simplex.Chat.Store.NoteFolders import Simplex.Chat.Store.Profiles -import Simplex.Chat.Store.Shared import Simplex.Chat.Types -import Simplex.Chat.Types.Preferences -import Simplex.Chat.Types.Shared -import Simplex.Chat.Util (encryptFile, liftIOEither, shuffle) -import qualified Simplex.Chat.Util as U +import Simplex.Chat.Util (shuffle) import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) -import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription, maxFileSize, maxFileSizeHard) -import qualified Simplex.FileTransfer.Description as FD -import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI) -import qualified Simplex.FileTransfer.Transport as XFTP -import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId) import Simplex.Messaging.Agent as Agent -import Simplex.Messaging.Agent.Client (SubInfo (..), agentClientStore, getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary, getFastNetworkConfig, ipAddressProtected, withLockMap) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), ServerCfg (..), ServerRoles (..), allRoles, createAgentStore, defaultAgentConfig, presetServerCfg) -import Simplex.Messaging.Agent.Lock (withLock) import Simplex.Messaging.Agent.Protocol -import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) -import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, SQLiteStore (dbNew), execSQL, upMigration, withConnection) -import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) +import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, SQLiteStore (dbNew)) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB -import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations -import Simplex.Messaging.Client (NetworkConfig (..), ProxyClientError (..), SocksMode (SMAlways), defaultNetworkConfig, textToHostMode) +import Simplex.Messaging.Client (defaultNetworkConfig) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) -import qualified Simplex.Messaging.Crypto.File as CF -import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) -import qualified Simplex.Messaging.Crypto.Ratchet as CR -import Simplex.Messaging.Encoding -import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (base64P) -import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), ErrorType (..), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolServer, ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol) -import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) +import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolType (..), SProtocolType (..), SubscriptionMode (..), UserProtocol) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (TransportError (..)) -import Simplex.Messaging.Transport.Client (defaultSocksProxyWithAuth) -import Simplex.Messaging.Util -import Simplex.Messaging.Version -import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..)) -import Simplex.RemoteControl.Types (RCCtrlAddress (..)) -import System.Exit (ExitCode, exitSuccess) -import System.FilePath (takeFileName, ()) -import qualified System.FilePath as FP -import System.IO (Handle, IOMode (..), SeekMode (..), hFlush) -import System.Random (randomRIO) -import Text.Read (readMaybe) -import UnliftIO.Async -import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay) -import UnliftIO.Directory import qualified UnliftIO.Exception as E -import UnliftIO.IO (hClose, hSeek, hTell, openFile) import UnliftIO.STM operatorSimpleXChat :: NewServerOperator @@ -269,28 +179,6 @@ fluxXFTPServers = "xftp://0AznwoyfX8Od9T_acp1QeeKtxUi676IBIiQjXVwbdyU=@xftp6.simplexonflux.com,upvzf23ou6nrmaf3qgnhd6cn3d74tvivlmz3p7wdfwq6fhthjrjiiqid.onion" ] -_defaultNtfServers :: [NtfServer] -_defaultNtfServers = - [ "ntf://FB-Uop7RTaZZEG0ZLD2CIaTjsPh-Fw0zFAnb7QyA8Ks=@ntf2.simplex.im,5ex3mupcazy3zlky64ab27phjhijpemsiby33qzq3pliejipbtx5xgad.onion" - -- "ntf://KmpZNNXiVZJx_G2T7jRUmDFxWXM3OAnunz3uLT0tqAA=@ntf3.simplex.im,pxculznuryunjdvtvh6s6szmanyadumpbmvevgdpe4wk5c65unyt4yid.onion", - -- "ntf://CJ5o7X6fCxj2FFYRU2KuCo70y4jSqz7td2HYhLnXWbU=@ntf4.simplex.im,wtvuhdj26jwprmomnyfu5wfuq2hjkzfcc72u44vi6gdhrwxldt6xauad.onion" - ] - -maxImageSize :: Integer -maxImageSize = 261120 * 2 -- auto-receive on mobiles - -imageExtensions :: [String] -imageExtensions = [".jpg", ".jpeg", ".png", ".gif"] - -maxMsgReactions :: Int -maxMsgReactions = 3 - -fixedImagePreview :: ImageData -fixedImagePreview = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAYAAACqaXHeAAAAAXNSR0IArs4c6QAAAKVJREFUeF7t1kENACEUQ0FQhnVQ9lfGO+xggITQdvbMzArPey+8fa3tAfwAEdABZQspQStgBssEcgAIkSAJkiAJljtEgiRIgmUCSZAESZAESZAEyx0iQRIkwTKBJEiCv5fgvTd1wDmn7QAP4AeIgA4oW0gJWgEzWCZwbQ7gAA7ggLKFOIADOKBMIAeAEAmSIAmSYLlDJEiCJFgmkARJkARJ8N8S/ADTZUewBvnTOQAAAABJRU5ErkJggg==" - -smallGroupsRcptsMemLimit :: Int -smallGroupsRcptsMemLimit = 20 - logCfg :: LogConfig logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} @@ -442,62 +330,6 @@ newChatController let auId = aUserId user' pure $ bimap (auId,) (auId,) $ useServers as opDomains uss' -updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig -updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} = - let cfg1 = maybe cfg (\smpProxyMode -> cfg {smpProxyMode}) smpProxyMode_ - cfg2 = maybe cfg1 (\smpProxyFallback -> cfg1 {smpProxyFallback}) smpProxyFallback_ - cfg3 = maybe cfg2 (\tcpTimeout -> cfg2 {tcpTimeout, tcpConnectTimeout = (tcpTimeout * 3) `div` 2}) tcpTimeout_ - in cfg3 {socksProxy, socksMode, hostMode, requiredHostMode, smpWebPort, logTLSErrors} - -withChatLock :: String -> CM a -> CM a -withChatLock name action = asks chatLock >>= \l -> withLock l name action - -withEntityLock :: String -> ChatLockEntity -> CM a -> CM a -withEntityLock name entity action = do - chatLock <- asks chatLock - ls <- asks entityLocks - atomically $ unlessM (isEmptyTMVar chatLock) retry - withLockMap ls entity name action - -withInvitationLock :: String -> ByteString -> CM a -> CM a -withInvitationLock name = withEntityLock name . CLInvitation -{-# INLINE withInvitationLock #-} - -withConnectionLock :: String -> Int64 -> CM a -> CM a -withConnectionLock name = withEntityLock name . CLConnection -{-# INLINE withConnectionLock #-} - -withContactLock :: String -> ContactId -> CM a -> CM a -withContactLock name = withEntityLock name . CLContact -{-# INLINE withContactLock #-} - -withGroupLock :: String -> GroupId -> CM a -> CM a -withGroupLock name = withEntityLock name . CLGroup -{-# INLINE withGroupLock #-} - -withUserContactLock :: String -> Int64 -> CM a -> CM a -withUserContactLock name = withEntityLock name . CLUserContact -{-# INLINE withUserContactLock #-} - -withFileLock :: String -> Int64 -> CM a -> CM a -withFileLock name = withEntityLock name . CLFile -{-# INLINE withFileLock #-} - -useServers :: Foldable f => RandomAgentServers -> [(Text, ServerOperator)] -> f UserOperatorServers -> (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP)) -useServers as opDomains uss = - let smp' = useServerCfgs SPSMP as opDomains $ concatMap (servers' SPSMP) uss - xftp' = useServerCfgs SPXFTP as opDomains $ concatMap (servers' SPXFTP) uss - in (smp', xftp') - -useServerCfgs :: forall p. UserProtocol p => SProtocolType p -> RandomAgentServers -> [(Text, ServerOperator)] -> [UserServer p] -> NonEmpty (ServerCfg p) -useServerCfgs p RandomAgentServers {smpServers, xftpServers} opDomains = - fromMaybe (rndAgentServers p) . L.nonEmpty . agentServerCfgs p opDomains - where - rndAgentServers :: SProtocolType p -> NonEmpty (ServerCfg p) - rndAgentServers = \case - SPSMP -> smpServers - SPXFTP -> xftpServers - chooseRandomServers :: PresetServers -> IO (NonEmpty PresetOperator) chooseRandomServers PresetServers {operators} = forM operators $ \op -> do @@ -524,8383 +356,3 @@ toJustOrError name = \case Nothing -> do putStrLn $ name <> ": expected Just, exiting" E.throwIO $ userError name - --- enableSndFiles has no effect when mainApp is True -startChatController :: Bool -> Bool -> CM' (Async ()) -startChatController mainApp enableSndFiles = do - asks smpAgent >>= liftIO . resumeAgentClient - unless mainApp $ chatWriteVar' subscriptionMode SMOnlyCreate - users <- fromRight [] <$> runExceptT (withFastStore' getUsers) - restoreCalls - s <- asks agentAsync - readTVarIO s >>= maybe (start s users) (pure . fst) - where - start s users = do - a1 <- async agentSubscriber - a2 <- - if mainApp - then Just <$> async (subscribeUsers False users) - else pure Nothing - atomically . writeTVar s $ Just (a1, a2) - if mainApp - then do - startXFTP xftpStartWorkers - void $ forkIO $ startFilesToReceive users - startCleanupManager - void $ forkIO $ startExpireCIs users - else when enableSndFiles $ startXFTP xftpStartSndWorkers - pure a1 - startXFTP startWorkers = do - tmp <- readTVarIO =<< asks tempDirectory - runExceptT (withAgent $ \a -> startWorkers a tmp) >>= \case - Left e -> liftIO $ putStrLn $ "Error starting XFTP workers: " <> show e - Right _ -> pure () - startCleanupManager = do - cleanupAsync <- asks cleanupManagerAsync - readTVarIO cleanupAsync >>= \case - Nothing -> do - a <- Just <$> async (void $ runExceptT cleanupManager) - atomically $ writeTVar cleanupAsync a - _ -> pure () - startExpireCIs users = - forM_ users $ \user -> do - ttl <- fromRight Nothing <$> runExceptT (withStore' (`getChatItemTTL` user)) - forM_ ttl $ \_ -> do - startExpireCIThread user - setExpireCIFlag user True - -subscribeUsers :: Bool -> [User] -> CM' () -subscribeUsers onlyNeeded users = do - let (us, us') = partition activeUser users - vr <- chatVersionRange' - subscribe vr us - subscribe vr us' - where - subscribe :: VersionRangeChat -> [User] -> CM' () - subscribe vr = mapM_ $ runExceptT . subscribeUserConnections vr onlyNeeded Agent.subscribeConnections - -startFilesToReceive :: [User] -> CM' () -startFilesToReceive users = do - let (us, us') = partition activeUser users - startReceive us - startReceive us' - where - startReceive :: [User] -> CM' () - startReceive = mapM_ $ runExceptT . startReceiveUserFiles - -startReceiveUserFiles :: User -> CM () -startReceiveUserFiles user = do - filesToReceive <- withStore' (`getRcvFilesToReceive` user) - forM_ filesToReceive $ \ft -> - flip catchChatError (toView . CRChatError (Just user)) $ - toView =<< receiveFile' user ft False Nothing Nothing - -restoreCalls :: CM' () -restoreCalls = do - savedCalls <- fromRight [] <$> runExceptT (withFastStore' getCalls) - let callsMap = M.fromList $ map (\call@Call {contactId} -> (contactId, call)) savedCalls - calls <- asks currentCalls - atomically $ writeTVar calls callsMap - -stopChatController :: ChatController -> IO () -stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do - readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd) - atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd) - disconnectAgentClient smpAgent - readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2) - closeFiles sndFiles - closeFiles rcvFiles - atomically $ do - keys <- M.keys <$> readTVar expireCIFlags - forM_ keys $ \k -> TM.insert k False expireCIFlags - writeTVar s Nothing - where - closeFiles :: TVar (Map Int64 Handle) -> IO () - closeFiles files = do - fs <- readTVarIO files - mapM_ hClose fs - atomically $ writeTVar files M.empty - -execChatCommand :: Maybe RemoteHostId -> ByteString -> CM' ChatResponse -execChatCommand rh s = do - u <- readTVarIO =<< asks currentUser - case parseChatCommand s of - Left e -> pure $ chatCmdError u e - Right cmd -> case rh of - Just rhId - | allowRemoteCommand cmd -> execRemoteCommand u rhId cmd s - | otherwise -> pure $ CRChatCmdError u $ ChatErrorRemoteHost (RHId rhId) $ RHELocalCommand - _ -> do - cc@ChatController {config = ChatConfig {chatHooks}} <- ask - liftIO (preCmdHook chatHooks cc cmd) >>= either pure (execChatCommand_ u) - -execChatCommand' :: ChatCommand -> CM' ChatResponse -execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd) - -execChatCommand_ :: Maybe User -> ChatCommand -> CM' ChatResponse -execChatCommand_ u cmd = handleCommandError u $ processChatCommand cmd - -execRemoteCommand :: Maybe User -> RemoteHostId -> ChatCommand -> ByteString -> CM' ChatResponse -execRemoteCommand u rhId cmd s = handleCommandError u $ getRemoteHostClient rhId >>= \rh -> processRemoteCommand rhId rh cmd s - -handleCommandError :: Maybe User -> CM ChatResponse -> CM' ChatResponse -handleCommandError u a = either (CRChatCmdError u) id <$> (runExceptT a `E.catches` ioErrors) - where - ioErrors = - [ E.Handler $ \(e :: ExitCode) -> E.throwIO e, - E.Handler $ pure . Left . mkChatError - ] - -parseChatCommand :: ByteString -> Either String ChatCommand -parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace - --- | Chat API commands interpreted in context of a local zone -processChatCommand :: ChatCommand -> CM ChatResponse -processChatCommand cmd = - chatVersionRange >>= (`processChatCommand'` cmd) -{-# INLINE processChatCommand #-} - -processChatCommand' :: VersionRangeChat -> ChatCommand -> CM ChatResponse -processChatCommand' vr = \case - ShowActiveUser -> withUser' $ pure . CRActiveUser - CreateActiveUser NewUser {profile, pastTimestamp} -> do - forM_ profile $ \Profile {displayName} -> checkValidName displayName - p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile - u <- asks currentUser - users <- withFastStore' getUsers - forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash} -> - when (n == displayName) . throwChatError $ - if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""} - (uss, (smp', xftp')) <- chooseServers =<< readTVarIO u - auId <- withAgent $ \a -> createUser a smp' xftp' - ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure - user <- withFastStore $ \db -> do - user <- createUserRecordAt db (AgentUserId auId) p True ts - mapM_ (setUserServers db user ts) uss - createPresetContactCards db user `catchStoreError` \_ -> pure () - createNoteFolder db user - pure user - atomically . writeTVar u $ Just user - pure $ CRActiveUser user - where - createPresetContactCards :: DB.Connection -> User -> ExceptT StoreError IO () - createPresetContactCards db user = do - createContact db user simplexStatusContactProfile - createContact db user simplexTeamContactProfile - chooseServers :: Maybe User -> CM ([UpdatedUserOperatorServers], (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))) - chooseServers user_ = do - as <- asks randomAgentServers - mapM (withFastStore . flip getUserServers >=> liftIO . groupByOperator) user_ >>= \case - Just uss -> do - let opDomains = operatorDomains $ mapMaybe operator' uss - uss' = map copyServers uss - pure $ (uss',) $ useServers as opDomains uss - Nothing -> do - ps <- asks randomPresetServers - uss <- presetUserServers <$> withFastStore' (\db -> getUpdateServerOperators db ps True) - let RandomAgentServers {smpServers = smp', xftpServers = xftp'} = as - pure (uss, (smp', xftp')) - copyServers :: UserOperatorServers -> UpdatedUserOperatorServers - copyServers UserOperatorServers {operator, smpServers, xftpServers} = - let new srv = AUS SDBNew srv {serverId = DBNewEntity} - in UpdatedUserOperatorServers {operator, smpServers = map new smpServers, xftpServers = map new xftpServers} - coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day) - day = 86400 - ListUsers -> CRUsersList <$> withFastStore' getUsersInfo - APISetActiveUser userId' viewPwd_ -> do - unlessM (lift chatStarted) $ throwChatError CEChatNotStarted - user_ <- chatReadVar currentUser - user' <- privateGetUser userId' - validateUserPassword_ user_ user' viewPwd_ - user'' <- withFastStore' (`setActiveUser` user') - chatWriteVar currentUser $ Just user'' - pure $ CRActiveUser user'' - SetActiveUser uName viewPwd_ -> do - tryChatError (withFastStore (`getUserIdByName` uName)) >>= \case - Left _ -> throwChatError CEUserUnknown - Right userId -> processChatCommand $ APISetActiveUser userId viewPwd_ - SetAllContactReceipts onOff -> withUser $ \_ -> withFastStore' (`updateAllContactReceipts` onOff) >> ok_ - APISetUserContactReceipts userId' settings -> withUser $ \user -> do - user' <- privateGetUser userId' - validateUserPassword user user' Nothing - withFastStore' $ \db -> updateUserContactReceipts db user' settings - ok user - SetUserContactReceipts settings -> withUser $ \User {userId} -> processChatCommand $ APISetUserContactReceipts userId settings - APISetUserGroupReceipts userId' settings -> withUser $ \user -> do - user' <- privateGetUser userId' - validateUserPassword user user' Nothing - withFastStore' $ \db -> updateUserGroupReceipts db user' settings - ok user - SetUserGroupReceipts settings -> withUser $ \User {userId} -> processChatCommand $ APISetUserGroupReceipts userId settings - APIHideUser userId' (UserPwd viewPwd) -> withUser $ \user -> do - user' <- privateGetUser userId' - case viewPwdHash user' of - Just _ -> throwChatError $ CEUserAlreadyHidden userId' - _ -> do - when (T.null viewPwd) $ throwChatError $ CEEmptyUserPassword userId' - users <- withFastStore' getUsers - unless (length (filter (isNothing . viewPwdHash) users) > 1) $ throwChatError $ CECantHideLastUser userId' - viewPwdHash' <- hashPassword - setUserPrivacy user user' {viewPwdHash = viewPwdHash', showNtfs = False} - where - hashPassword = do - salt <- drgRandomBytes 16 - let hash = B64UrlByteString $ C.sha512Hash $ encodeUtf8 viewPwd <> salt - pure $ Just UserPwdHash {hash, salt = B64UrlByteString salt} - APIUnhideUser userId' viewPwd@(UserPwd pwd) -> withUser $ \user -> do - user' <- privateGetUser userId' - case viewPwdHash user' of - Nothing -> throwChatError $ CEUserNotHidden userId' - _ -> do - when (T.null pwd) $ throwChatError $ CEEmptyUserPassword userId' - validateUserPassword user user' $ Just viewPwd - setUserPrivacy user user' {viewPwdHash = Nothing, showNtfs = True} - APIMuteUser userId' -> setUserNotifications userId' False - APIUnmuteUser userId' -> setUserNotifications userId' True - HideUser viewPwd -> withUser $ \User {userId} -> processChatCommand $ APIHideUser userId viewPwd - UnhideUser viewPwd -> withUser $ \User {userId} -> processChatCommand $ APIUnhideUser userId viewPwd - MuteUser -> withUser $ \User {userId} -> processChatCommand $ APIMuteUser userId - UnmuteUser -> withUser $ \User {userId} -> processChatCommand $ APIUnmuteUser userId - APIDeleteUser userId' delSMPQueues viewPwd_ -> withUser $ \user -> do - user' <- privateGetUser userId' - validateUserPassword user user' viewPwd_ - checkDeleteChatUser user' - withChatLock "deleteUser" . procCmd $ deleteChatUser user' delSMPQueues - DeleteUser uName delSMPQueues viewPwd_ -> withUserName uName $ \userId -> APIDeleteUser userId delSMPQueues viewPwd_ - StartChat {mainApp, enableSndFiles} -> withUser' $ \_ -> - asks agentAsync >>= readTVarIO >>= \case - Just _ -> pure CRChatRunning - _ -> checkStoreNotChanged . lift $ startChatController mainApp enableSndFiles $> CRChatStarted - CheckChatRunning -> maybe CRChatStopped (const CRChatRunning) <$> chatReadVar agentAsync - APIStopChat -> do - ask >>= liftIO . stopChatController - pure CRChatStopped - APIActivateChat restoreChat -> withUser $ \_ -> do - lift $ when restoreChat restoreCalls - lift $ withAgent' foregroundAgent - chatWriteVar chatActivated True - when restoreChat $ do - users <- withFastStore' getUsers - lift $ do - void . forkIO $ subscribeUsers True users - void . forkIO $ startFilesToReceive users - setAllExpireCIFlags True - ok_ - APISuspendChat t -> do - chatWriteVar chatActivated False - lift $ setAllExpireCIFlags False - stopRemoteCtrl - lift $ withAgent' (`suspendAgent` t) - ok_ - ResubscribeAllConnections -> withStore' getUsers >>= lift . subscribeUsers False >> ok_ - -- has to be called before StartChat - SetTempFolder tf -> do - createDirectoryIfMissing True tf - asks tempDirectory >>= atomically . (`writeTVar` Just tf) - ok_ - SetFilesFolder ff -> do - createDirectoryIfMissing True ff - asks filesFolder >>= atomically . (`writeTVar` Just ff) - ok_ - SetRemoteHostsFolder rf -> do - createDirectoryIfMissing True rf - chatWriteVar remoteHostsFolder $ Just rf - ok_ - -- has to be called before StartChat - APISetAppFilePaths cfg -> do - setFolder filesFolder $ appFilesFolder cfg - setFolder tempDirectory $ appTempFolder cfg - setFolder assetsDirectory $ appAssetsFolder cfg - mapM_ (setFolder remoteHostsFolder) $ appRemoteHostsFolder cfg - ok_ - where - setFolder sel f = do - createDirectoryIfMissing True f - chatWriteVar sel $ Just f - APISetEncryptLocalFiles on -> chatWriteVar encryptLocalFiles on >> ok_ - SetContactMergeEnabled onOff -> chatWriteVar contactMergeEnabled onOff >> ok_ - APIExportArchive cfg -> checkChatStopped $ CRArchiveExported <$> lift (exportArchive cfg) - ExportArchive -> do - ts <- liftIO getCurrentTime - let filePath = "simplex-chat." <> formatTime defaultTimeLocale "%FT%H%M%SZ" ts <> ".zip" - processChatCommand $ APIExportArchive $ ArchiveConfig filePath Nothing Nothing - APIImportArchive cfg -> checkChatStopped $ do - fileErrs <- lift $ importArchive cfg - setStoreChanged - pure $ CRArchiveImported fileErrs - APISaveAppSettings as -> withFastStore' (`saveAppSettings` as) >> ok_ - APIGetAppSettings platformDefaults -> CRAppSettings <$> withFastStore' (`getAppSettings` platformDefaults) - APIDeleteStorage -> withStoreChanged deleteStorage - APIStorageEncryption cfg -> withStoreChanged $ sqlCipherExport cfg - TestStorageEncryption key -> sqlCipherTestKey key >> ok_ - ExecChatStoreSQL query -> CRSQLResult <$> withStore' (`execSQL` query) - ExecAgentStoreSQL query -> CRSQLResult <$> withAgent (`execAgentStoreSQL` query) - SlowSQLQueries -> do - ChatController {chatStore, smpAgent} <- ask - chatQueries <- slowQueries chatStore - agentQueries <- slowQueries $ agentClientStore smpAgent - pure CRSlowSQLQueries {chatQueries, agentQueries} - where - slowQueries st = - liftIO $ - map (uncurry SlowSQLQuery . first SQL.fromQuery) - . sortOn (timeAvg . snd) - . M.assocs - <$> withConnection st (readTVarIO . DB.slow) - APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do - (errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user pendingConnections pagination query) - unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs) - pure $ CRApiChats user previews - APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of - -- TODO optimize queries calculating ChatStats, currently they're disabled - CTDirect -> do - (directChat, navInfo) <- withFastStore (\db -> getDirectChat db vr user cId pagination search) - pure $ CRApiChat user (AChat SCTDirect directChat) navInfo - CTGroup -> do - (groupChat, navInfo) <- withFastStore (\db -> getGroupChat db vr user cId pagination search) - pure $ CRApiChat user (AChat SCTGroup groupChat) navInfo - CTLocal -> do - (localChat, navInfo) <- withFastStore (\db -> getLocalChat db user cId pagination search) - pure $ CRApiChat user (AChat SCTLocal localChat) navInfo - CTContactRequest -> pure $ chatCmdError (Just user) "not implemented" - CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - APIGetChatItems pagination search -> withUser $ \user -> do - chatItems <- withFastStore $ \db -> getAllChatItems db vr user pagination search - pure $ CRChatItems user Nothing chatItems - APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do - (aci@(AChatItem cType dir _ ci), versions) <- withFastStore $ \db -> - (,) <$> getAChatItem db vr user chatRef itemId <*> liftIO (getChatItemVersions db itemId) - let itemVersions = if null versions then maybeToList $ mkItemVersion ci else versions - memberDeliveryStatuses <- case (cType, dir) of - (SCTGroup, SMDSnd) -> L.nonEmpty <$> withFastStore' (`getGroupSndStatuses` itemId) - _ -> pure Nothing - forwardedFromChatItem <- getForwardedFromItem user ci - pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses, forwardedFromChatItem} - where - getForwardedFromItem :: User -> ChatItem c d -> CM (Maybe AChatItem) - getForwardedFromItem user ChatItem {meta = CIMeta {itemForwarded}} = case itemForwarded of - Just (CIFFContact _ _ (Just ctId) (Just fwdItemId)) -> - Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTDirect ctId) fwdItemId) - Just (CIFFGroup _ _ (Just gId) (Just fwdItemId)) -> - Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId) - _ -> pure Nothing - APISendMessages (ChatRef cType chatId) live itemTTL cms -> withUser $ \user -> case cType of - CTDirect -> - withContactLock "sendMessage" chatId $ - sendContactContentMessages user chatId live itemTTL (L.map (,Nothing) cms) - CTGroup -> - withGroupLock "sendMessage" chatId $ - sendGroupContentMessages user chatId live itemTTL (L.map (,Nothing) cms) - CTLocal -> pure $ chatCmdError (Just user) "not supported" - CTContactRequest -> pure $ chatCmdError (Just user) "not supported" - CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - APICreateChatItems folderId cms -> withUser $ \user -> - createNoteFolderContentItems user folderId (L.map (,Nothing) cms) - APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> case cType of - CTDirect -> withContactLock "updateChatItem" chatId $ do - ct@Contact {contactId} <- withFastStore $ \db -> getContact db vr user chatId - assertDirectAllowed user MDSnd ct XMsgUpdate_ - cci <- withFastStore $ \db -> getDirectCIWithReactions db user ct itemId - case cci of - CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do - case (ciContent, itemSharedMsgId, editable) of - (CISndMsgContent oldMC, Just itemSharedMId, True) -> do - let changed = mc /= oldMC - if changed || fromMaybe False itemLive - then do - (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) - ci' <- withFastStore' $ \db -> do - currentTs <- liftIO getCurrentTime - when changed $ - addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) - let edited = itemLive /= Just True - updateDirectChatItem' db user contactId ci (CISndMsgContent mc) edited live Nothing $ Just msgId - startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci' - 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 -> withGroupLock "updateChatItem" chatId $ do - Group gInfo@GroupInfo {groupId, membership} ms <- withFastStore $ \db -> getGroup db vr user chatId - assertUserGroupRole gInfo GRAuthor - if prohibitedSimplexLinks gInfo membership mc - then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks)) - else do - cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId - case cci of - CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do - case (ciContent, itemSharedMsgId, editable) of - (CISndMsgContent oldMC, Just itemSharedMId, True) -> do - let changed = mc /= oldMC - if changed || fromMaybe False itemLive - then do - SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) - ci' <- withFastStore' $ \db -> do - currentTs <- liftIO getCurrentTime - when changed $ - addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) - let edited = itemLive /= Just True - updateGroupChatItem db user groupId ci (CISndMsgContent mc) edited live $ Just msgId - startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci' - pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci') - else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) - _ -> throwChatError CEInvalidChatItemUpdate - CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate - CTLocal -> do - (nf@NoteFolder {noteFolderId}, cci) <- withFastStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId - case cci of - CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent oldMC} - | mc == oldMC -> pure $ CRChatItemNotChanged user (AChatItem SCTLocal SMDSnd (LocalChat nf) ci) - | otherwise -> withFastStore' $ \db -> do - currentTs <- getCurrentTime - addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) - ci' <- updateLocalChatItem' db user noteFolderId ci (CISndMsgContent mc) True - pure $ CRChatItemUpdated user (AChatItem SCTLocal SMDSnd (LocalChat nf) ci') - _ -> throwChatError CEInvalidChatItemUpdate - CTContactRequest -> pure $ chatCmdError (Just user) "not supported" - CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - APIDeleteChatItem (ChatRef cType chatId) itemIds mode -> withUser $ \user -> case cType of - CTDirect -> withContactLock "deleteChatItem" chatId $ do - (ct, items) <- getCommandDirectChatItems user chatId itemIds - case mode of - CIDMInternal -> deleteDirectCIs user ct items True False - CIDMBroadcast -> do - assertDeletable items - assertDirectAllowed user MDSnd ct XMsgDel_ - let msgIds = itemsMsgIds items - events = map (\msgId -> XMsgDel msgId Nothing) msgIds - forM_ (L.nonEmpty events) $ \events' -> - sendDirectContactMessages user ct events' - if featureAllowed SCFFullDelete forUser ct - then deleteDirectCIs user ct items True False - else markDirectCIsDeleted user ct items True =<< liftIO getCurrentTime - CTGroup -> withGroupLock "deleteChatItem" chatId $ do - (gInfo, items) <- getCommandGroupChatItems user chatId itemIds - ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo - case mode of - CIDMInternal -> deleteGroupCIs user gInfo items True False Nothing =<< liftIO getCurrentTime - CIDMBroadcast -> do - assertDeletable items - assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier - let msgIds = itemsMsgIds items - events = L.nonEmpty $ map (`XMsgDel` Nothing) msgIds - mapM_ (sendGroupMessages user gInfo ms) events - delGroupChatItems user gInfo items Nothing - CTLocal -> do - (nf, items) <- getCommandLocalChatItems user chatId itemIds - deleteLocalCIs user nf items True False - CTContactRequest -> pure $ chatCmdError (Just user) "not supported" - CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - where - assertDeletable :: forall c. ChatTypeI c => [CChatItem c] -> CM () - assertDeletable items = do - currentTs <- liftIO getCurrentTime - unless (all (itemDeletable currentTs) items) $ throwChatError CEInvalidChatItemDelete - where - itemDeletable :: UTCTime -> CChatItem c -> Bool - itemDeletable currentTs (CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, itemTs, itemDeleted}, content}) = - case msgDir of - -- We check with a 6 hour margin compared to CIMeta deletable to account for deletion on the border - SMDSnd -> isJust itemSharedMsgId && deletable' content itemDeleted itemTs (nominalDay + 6 * 3600) currentTs - SMDRcv -> False - itemsMsgIds :: [CChatItem c] -> [SharedMsgId] - itemsMsgIds = mapMaybe (\(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) -> itemSharedMsgId) - APIDeleteMemberChatItem gId itemIds -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do - (gInfo@GroupInfo {membership}, items) <- getCommandGroupChatItems user gId itemIds - ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo - assertDeletable gInfo items - assertUserGroupRole gInfo GRAdmin - let msgMemIds = itemsMsgMemIds gInfo items - events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId (Just memId)) msgMemIds - mapM_ (sendGroupMessages user gInfo ms) events - delGroupChatItems user gInfo items (Just membership) - where - assertDeletable :: GroupInfo -> [CChatItem 'CTGroup] -> CM () - assertDeletable GroupInfo {membership = GroupMember {memberRole = membershipMemRole}} items = - unless (all itemDeletable items) $ throwChatError CEInvalidChatItemDelete - where - itemDeletable :: CChatItem 'CTGroup -> Bool - itemDeletable (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) = - case chatDir of - CIGroupRcv GroupMember {memberRole} -> membershipMemRole >= memberRole && isJust itemSharedMsgId - CIGroupSnd -> isJust itemSharedMsgId - itemsMsgMemIds :: GroupInfo -> [CChatItem 'CTGroup] -> [(SharedMsgId, MemberId)] - itemsMsgMemIds GroupInfo {membership = GroupMember {memberId = membershipMemId}} = mapMaybe itemMsgMemIds - where - itemMsgMemIds :: CChatItem 'CTGroup -> Maybe (SharedMsgId, MemberId) - itemMsgMemIds (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) = - join <$> forM itemSharedMsgId $ \msgId -> Just $ case chatDir of - CIGroupRcv GroupMember {memberId} -> (msgId, memberId) - CIGroupSnd -> (msgId, membershipMemId) - APIChatItemReaction (ChatRef cType chatId) itemId add reaction -> withUser $ \user -> case cType of - CTDirect -> - withContactLock "chatItemReaction" chatId $ - withFastStore (\db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId) >>= \case - (ct, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do - unless (featureAllowed SCFReactions forUser ct) $ - throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) - unless (ciReactionAllowed ci) $ - throwChatError (CECommandError "reaction not allowed - chat item has no content") - rs <- withFastStore' $ \db -> getDirectReactions db ct itemSharedMId True - checkReactionAllowed rs - (SndMessage {msgId}, _) <- sendDirectContactMessage user ct $ XMsgReact itemSharedMId Nothing reaction add - createdAt <- liftIO getCurrentTime - reactions <- withFastStore' $ \db -> do - setDirectReaction db ct itemSharedMId True reaction add msgId createdAt - liftIO $ getDirectCIReactions db ct itemSharedMId - let ci' = CChatItem md ci {reactions} - r = ACIReaction SCTDirect SMDSnd (DirectChat ct) $ CIReaction CIDirectSnd ci' createdAt reaction - pure $ CRChatItemReaction user add r - _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" - CTGroup -> - withGroupLock "chatItemReaction" chatId $ - withFastStore (\db -> (,) <$> getGroup db vr user chatId <*> getGroupChatItem db user chatId itemId) >>= \case - (Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do - unless (groupFeatureAllowed SGFReactions g) $ - throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) - unless (ciReactionAllowed ci) $ - throwChatError (CECommandError "reaction not allowed - chat item has no content") - let GroupMember {memberId = itemMemberId} = chatItemMember g ci - rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True - checkReactionAllowed rs - SndMessage {msgId} <- sendGroupMessage user g ms (XMsgReact itemSharedMId (Just itemMemberId) reaction add) - createdAt <- liftIO getCurrentTime - reactions <- withFastStore' $ \db -> do - setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt - liftIO $ getGroupCIReactions db g itemMemberId itemSharedMId - let ci' = CChatItem md ci {reactions} - r = ACIReaction SCTGroup SMDSnd (GroupChat g) $ CIReaction CIGroupSnd ci' createdAt reaction - pure $ CRChatItemReaction user add r - _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" - CTLocal -> pure $ chatCmdError (Just user) "not supported" - CTContactRequest -> pure $ chatCmdError (Just user) "not supported" - CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - where - checkReactionAllowed rs = do - when ((reaction `elem` rs) == add) $ - throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") - when (add && length rs >= maxMsgReactions) $ - throwChatError (CECommandError "too many reactions") - APIGetReactionMembers userId groupId itemId reaction -> withUserId userId $ \user -> do - memberReactions <- withStore $ \db -> do - CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}} <- getGroupChatItem db user groupId itemId - liftIO $ getReactionMembers db vr user groupId itemSharedMId reaction - pure $ CRReactionMembers user memberReactions - APIPlanForwardChatItems (ChatRef fromCType fromChatId) itemIds -> withUser $ \user -> case fromCType of - CTDirect -> planForward user . snd =<< getCommandDirectChatItems user fromChatId itemIds - CTGroup -> planForward user . snd =<< getCommandGroupChatItems user fromChatId itemIds - CTLocal -> planForward user . snd =<< getCommandLocalChatItems user fromChatId itemIds - CTContactRequest -> pure $ chatCmdError (Just user) "not supported" - CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - where - planForward :: User -> [CChatItem c] -> CM ChatResponse - planForward user items = do - (itemIds', forwardErrors) <- unzip <$> mapM planItemForward items - let forwardConfirmation = case catMaybes forwardErrors of - [] -> Nothing - errs -> Just $ case mainErr of - FFENotAccepted _ -> FCFilesNotAccepted fileIds - FFEInProgress -> FCFilesInProgress filesCount - FFEMissing -> FCFilesMissing filesCount - FFEFailed -> FCFilesFailed filesCount - where - mainErr = minimum errs - fileIds = catMaybes $ map (\case FFENotAccepted ftId -> Just ftId; _ -> Nothing) errs - filesCount = length $ filter (mainErr ==) errs - pure CRForwardPlan {user, itemsCount = length itemIds, chatItemIds = catMaybes itemIds', forwardConfirmation} - where - planItemForward :: CChatItem c -> CM (Maybe ChatItemId, Maybe ForwardFileError) - planItemForward (CChatItem _ ci) = forwardMsgContent ci >>= maybe (pure (Nothing, Nothing)) (forwardContentPlan ci) - forwardContentPlan :: ChatItem c d -> MsgContent -> CM (Maybe ChatItemId, Maybe ForwardFileError) - forwardContentPlan ChatItem {file, meta = CIMeta {itemId}} mc = case file of - Nothing -> pure (Just itemId, Nothing) - Just CIFile {fileId, fileStatus, fileSource} -> case ciFileForwardError fileId fileStatus of - Just err -> pure $ itemIdWithoutFile err - Nothing -> case fileSource of - Just CryptoFile {filePath} -> do - exists <- doesFileExist =<< lift (toFSFilePath filePath) - pure $ if exists then (Just itemId, Nothing) else itemIdWithoutFile FFEMissing - Nothing -> pure $ itemIdWithoutFile FFEMissing - where - itemIdWithoutFile err = (if hasContent then Just itemId else Nothing, Just err) - hasContent = case mc of - MCText _ -> True - MCLink {} -> True - MCImage {} -> True - MCVideo {text} -> text /= "" - MCVoice {text} -> text /= "" - MCFile t -> t /= "" - MCUnknown {} -> True - APIForwardChatItems (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemIds itemTTL -> withUser $ \user -> case toCType of - CTDirect -> do - cmrs <- prepareForward user - case L.nonEmpty cmrs of - Just cmrs' -> - withContactLock "forwardChatItem, to contact" toChatId $ - sendContactContentMessages user toChatId False itemTTL cmrs' - Nothing -> pure $ CRNewChatItems user [] - CTGroup -> do - cmrs <- prepareForward user - case L.nonEmpty cmrs of - Just cmrs' -> - withGroupLock "forwardChatItem, to group" toChatId $ - sendGroupContentMessages user toChatId False itemTTL cmrs' - Nothing -> pure $ CRNewChatItems user [] - CTLocal -> do - cmrs <- prepareForward user - case L.nonEmpty cmrs of - Just cmrs' -> - createNoteFolderContentItems user toChatId cmrs' - Nothing -> pure $ CRNewChatItems user [] - CTContactRequest -> pure $ chatCmdError (Just user) "not supported" - CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - where - prepareForward :: User -> CM [ComposeMessageReq] - prepareForward user = case fromCType of - CTDirect -> withContactLock "forwardChatItem, from contact" fromChatId $ do - (ct, items) <- getCommandDirectChatItems user fromChatId itemIds - catMaybes <$> mapM (\ci -> ciComposeMsgReq ct ci <$$> prepareMsgReq ci) items - where - ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq - ciComposeMsgReq ct (CChatItem md ci) (mc', file) = - let itemId = chatItemId' ci - ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) (toMsgDirection md) (Just fromChatId) (Just itemId)) - in (ComposedMessage file Nothing mc', ciff) - where - forwardName :: Contact -> ContactName - forwardName Contact {profile = LocalProfile {displayName, localAlias}} - | localAlias /= "" = localAlias - | otherwise = displayName - CTGroup -> withGroupLock "forwardChatItem, from group" fromChatId $ do - (gInfo, items) <- getCommandGroupChatItems user fromChatId itemIds - catMaybes <$> mapM (\ci -> ciComposeMsgReq gInfo ci <$$> prepareMsgReq ci) items - where - ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq - ciComposeMsgReq gInfo (CChatItem md ci) (mc', file) = do - let itemId = chatItemId' ci - ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) (toMsgDirection md) (Just fromChatId) (Just itemId)) - in (ComposedMessage file Nothing mc', ciff) - where - forwardName :: GroupInfo -> ContactName - forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName - CTLocal -> do - (_, items) <- getCommandLocalChatItems user fromChatId itemIds - catMaybes <$> mapM (\ci -> ciComposeMsgReq ci <$$> prepareMsgReq ci) items - where - ciComposeMsgReq :: CChatItem 'CTLocal -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq - ciComposeMsgReq (CChatItem _ ci) (mc', file) = - let ciff = forwardCIFF ci Nothing - in (ComposedMessage file Nothing mc', ciff) - CTContactRequest -> throwChatError $ CECommandError "not supported" - CTContactConnection -> throwChatError $ CECommandError "not supported" - where - prepareMsgReq :: CChatItem c -> CM (Maybe (MsgContent, Maybe CryptoFile)) - prepareMsgReq (CChatItem _ ci) = forwardMsgContent ci $>>= forwardContent ci - forwardCIFF :: ChatItem c d -> Maybe CIForwardedFrom -> Maybe CIForwardedFrom - forwardCIFF ChatItem {meta = CIMeta {itemForwarded}} ciff = case itemForwarded of - Nothing -> ciff - Just CIFFUnknown -> ciff - Just prevCIFF -> Just prevCIFF - forwardContent :: ChatItem c d -> MsgContent -> CM (Maybe (MsgContent, Maybe CryptoFile)) - forwardContent ChatItem {file} mc = case file of - Nothing -> pure $ Just (mc, Nothing) - Just CIFile {fileName, fileStatus, fileSource = Just fromCF@CryptoFile {filePath}} - | ciFileLoaded fileStatus -> - chatReadVar filesFolder >>= \case - Nothing -> - ifM (doesFileExist filePath) (pure $ Just (mc, Just fromCF)) (pure contentWithoutFile) - Just filesFolder -> do - let fsFromPath = filesFolder filePath - ifM - (doesFileExist fsFromPath) - ( do - fsNewPath <- liftIO $ filesFolder `uniqueCombine` fileName - liftIO $ B.writeFile fsNewPath "" -- create empty file - encrypt <- chatReadVar encryptLocalFiles - cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing - let toCF = CryptoFile fsNewPath cfArgs - -- to keep forwarded file in case original is deleted - liftIOEither $ runExceptT $ withExceptT (ChatError . CEInternalError . show) $ copyCryptoFile (fromCF {filePath = fsFromPath} :: CryptoFile) toCF - pure $ Just (mc, Just (toCF {filePath = takeFileName fsNewPath} :: CryptoFile)) - ) - (pure contentWithoutFile) - _ -> pure contentWithoutFile - where - contentWithoutFile = case mc of - MCImage {} -> Just (mc, Nothing) - MCLink {} -> Just (mc, Nothing) - _ | contentText /= "" -> Just (MCText contentText, Nothing) - _ -> Nothing - contentText = msgContentText mc - copyCryptoFile :: CryptoFile -> CryptoFile -> ExceptT CF.FTCryptoError IO () - copyCryptoFile fromCF@CryptoFile {filePath = fsFromPath, cryptoArgs = fromArgs} toCF@CryptoFile {cryptoArgs = toArgs} = do - fromSizeFull <- getFileSize fsFromPath - let fromSize = fromSizeFull - maybe 0 (const $ toInteger C.authTagSize) fromArgs - CF.withFile fromCF ReadMode $ \fromH -> - CF.withFile toCF WriteMode $ \toH -> do - copyChunks fromH toH fromSize - forM_ fromArgs $ \_ -> CF.hGetTag fromH - forM_ toArgs $ \_ -> liftIO $ CF.hPutTag toH - where - copyChunks :: CF.CryptoFileHandle -> CF.CryptoFileHandle -> Integer -> ExceptT CF.FTCryptoError IO () - copyChunks r w size = do - let chSize = min size U.chunkSize - chSize' = fromIntegral chSize - size' = size - chSize - ch <- liftIO $ CF.hGet r chSize' - when (B.length ch /= chSize') $ throwError $ CF.FTCEFileIOError "encrypting file: unexpected EOF" - liftIO . CF.hPut w $ LB.fromStrict ch - when (size' > 0) $ copyChunks r w size' - APIUserRead userId -> withUserId userId $ \user -> withFastStore' (`setUserChatsRead` user) >> ok user - UserRead -> withUser $ \User {userId} -> processChatCommand $ APIUserRead userId - APIChatRead chatRef@(ChatRef cType chatId) -> withUser $ \_ -> case cType of - CTDirect -> do - user <- withFastStore $ \db -> getUserByContactId db chatId - ts <- liftIO getCurrentTime - timedItems <- withFastStore' $ \db -> do - timedItems <- getDirectUnreadTimedItems db user chatId - updateDirectChatItemsRead db user chatId - setDirectChatItemsDeleteAt db user chatId timedItems ts - forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt - ok user - CTGroup -> do - user <- withFastStore $ \db -> getUserByGroupId db chatId - ts <- liftIO getCurrentTime - timedItems <- withFastStore' $ \db -> do - timedItems <- getGroupUnreadTimedItems db user chatId - updateGroupChatItemsRead db user chatId - setGroupChatItemsDeleteAt db user chatId timedItems ts - forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt - ok user - CTLocal -> do - user <- withFastStore $ \db -> getUserByNoteFolderId db chatId - withFastStore' $ \db -> updateLocalChatItemsRead db user chatId - ok user - CTContactRequest -> pure $ chatCmdError Nothing "not supported" - CTContactConnection -> pure $ chatCmdError Nothing "not supported" - APIChatItemsRead chatRef@(ChatRef cType chatId) itemIds -> withUser $ \_ -> case cType of - CTDirect -> do - user <- withFastStore $ \db -> getUserByContactId db chatId - timedItems <- withFastStore' $ \db -> do - timedItems <- updateDirectChatItemsReadList db user chatId itemIds - setDirectChatItemsDeleteAt db user chatId timedItems =<< getCurrentTime - forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt - ok user - CTGroup -> do - user <- withFastStore $ \db -> getUserByGroupId db chatId - timedItems <- withFastStore' $ \db -> do - timedItems <- updateGroupChatItemsReadList db user chatId itemIds - setGroupChatItemsDeleteAt db user chatId timedItems =<< getCurrentTime - forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt - ok user - CTLocal -> pure $ chatCmdError Nothing "not supported" - CTContactRequest -> pure $ chatCmdError Nothing "not supported" - CTContactConnection -> pure $ chatCmdError Nothing "not supported" - APIChatUnread (ChatRef cType chatId) unreadChat -> withUser $ \user -> case cType of - CTDirect -> do - withFastStore $ \db -> do - ct <- getContact db vr user chatId - liftIO $ updateContactUnreadChat db user ct unreadChat - ok user - CTGroup -> do - withFastStore $ \db -> do - Group {groupInfo} <- getGroup db vr user chatId - liftIO $ updateGroupUnreadChat db user groupInfo unreadChat - ok user - CTLocal -> do - withFastStore $ \db -> do - nf <- getNoteFolder db user chatId - liftIO $ updateNoteFolderUnreadChat db user nf unreadChat - ok user - _ -> pure $ chatCmdError (Just user) "not supported" - APIDeleteChat cRef@(ChatRef cType chatId) cdm -> withUser $ \user@User {userId} -> case cType of - CTDirect -> do - ct <- withFastStore $ \db -> getContact db vr user chatId - filesInfo <- withFastStore' $ \db -> getContactFileInfo db user ct - withContactLock "deleteChat direct" chatId . procCmd $ - case cdm of - CDMFull notify -> do - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo - sendDelDeleteConns ct notify - -- functions below are called in separate transactions to prevent crashes on android - -- (possibly, race condition on integrity check?) - withFastStore' $ \db -> do - deleteContactConnections db user ct - deleteContactFiles db user ct - withFastStore $ \db -> deleteContact db user ct - pure $ CRContactDeleted user ct - CDMEntity notify -> do - cancelFilesInProgress user filesInfo - sendDelDeleteConns ct notify - ct' <- withFastStore $ \db -> do - liftIO $ deleteContactConnections db user ct - liftIO $ void $ updateContactStatus db user ct CSDeletedByUser - getContact db vr user chatId - pure $ CRContactDeleted user ct' - CDMMessages -> do - void $ processChatCommand $ APIClearChat cRef - withFastStore' $ \db -> setContactChatDeleted db user ct True - pure $ CRContactDeleted user ct {chatDeleted = True} - where - sendDelDeleteConns ct notify = do - let doSendDel = contactReady ct && contactActive ct && notify - when doSendDel $ void (sendDirectContactMessage user ct XDirectDel) `catchChatError` const (pure ()) - contactConnIds <- map aConnId <$> withFastStore' (\db -> getContactConnections db vr userId ct) - deleteAgentConnectionsAsync' user contactConnIds doSendDel - CTContactConnection -> withConnectionLock "deleteChat contactConnection" chatId . procCmd $ do - conn@PendingContactConnection {pccAgentConnId = AgentConnId acId} <- withFastStore $ \db -> getPendingContactConnection db userId chatId - deleteAgentConnectionAsync user acId - withFastStore' $ \db -> deletePendingContactConnection db userId chatId - pure $ CRContactConnectionDeleted user conn - CTGroup -> do - Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user chatId - let GroupMember {memberRole = membershipMemRole} = membership - let isOwner = membershipMemRole == GROwner - canDelete = isOwner || not (memberCurrent membership) - unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner - filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo - withGroupLock "deleteChat group" chatId . procCmd $ do - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo - let doSendDel = memberActive membership && isOwner - when doSendDel . void $ sendGroupMessage' user gInfo members XGrpDel - deleteGroupLinkIfExists user gInfo - deleteMembersConnections' user members doSendDel - updateCIGroupInvitationStatus user gInfo CIGISRejected `catchChatError` \_ -> pure () - -- functions below are called in separate transactions to prevent crashes on android - -- (possibly, race condition on integrity check?) - withStore' $ \db -> deleteGroupConnectionsAndFiles db user gInfo members - withStore' $ \db -> deleteGroupItemsAndMembers db user gInfo members - withStore' $ \db -> deleteGroup db user gInfo - let contactIds = mapMaybe memberContactId members - (errs1, (errs2, connIds)) <- lift $ second unzip . partitionEithers <$> withStoreBatch (\db -> map (deleteUnusedContact db) contactIds) - let errs = errs1 <> mapMaybe (fmap ChatErrorStore) errs2 - unless (null errs) $ toView $ CRChatErrors (Just user) errs - deleteAgentConnectionsAsync user $ concat connIds - pure $ CRGroupDeletedUser user gInfo - where - deleteUnusedContact :: DB.Connection -> ContactId -> IO (Either ChatError (Maybe StoreError, [ConnId])) - deleteUnusedContact db contactId = runExceptT . withExceptT ChatErrorStore $ do - ct <- getContact db vr user contactId - ifM - ((directOrUsed ct ||) . isJust <$> liftIO (checkContactHasGroups db user ct)) - (pure (Nothing, [])) - (getConnections ct) - where - getConnections :: Contact -> ExceptT StoreError IO (Maybe StoreError, [ConnId]) - getConnections ct = do - conns <- liftIO $ getContactConnections db vr userId ct - e_ <- (setContactDeleted db user ct $> Nothing) `catchStoreError` (pure . Just) - pure (e_, map aConnId conns) - CTLocal -> pure $ chatCmdError (Just user) "not supported" - CTContactRequest -> pure $ chatCmdError (Just user) "not supported" - APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of - CTDirect -> do - ct <- withFastStore $ \db -> getContact db vr user chatId - filesInfo <- withFastStore' $ \db -> getContactFileInfo db user ct - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo - withFastStore' $ \db -> deleteContactCIs db user ct - pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct) - CTGroup -> do - gInfo <- withFastStore $ \db -> getGroupInfo db vr user chatId - filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo - withFastStore' $ \db -> deleteGroupChatItemsMessages db user gInfo - membersToDelete <- withFastStore' $ \db -> getGroupMembersForExpiration db vr user gInfo - forM_ membersToDelete $ \m -> withFastStore' $ \db -> deleteGroupMember db user m - pure $ CRChatCleared user (AChatInfo SCTGroup $ GroupChat gInfo) - CTLocal -> do - nf <- withFastStore $ \db -> getNoteFolder db user chatId - filesInfo <- withFastStore' $ \db -> getNoteFolderFileInfo db user nf - deleteFilesLocally filesInfo - withFastStore' $ \db -> deleteNoteFolderFiles db userId nf - withFastStore' $ \db -> deleteNoteFolderCIs db user nf - pure $ CRChatCleared user (AChatInfo SCTLocal $ LocalChat nf) - CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - CTContactRequest -> pure $ chatCmdError (Just user) "not supported" - APIAcceptContact incognito connReqId -> withUser $ \_ -> do - userContactLinkId <- withFastStore $ \db -> getUserContactLinkIdByCReq db connReqId - withUserContactLock "acceptContact" userContactLinkId $ do - (user@User {userId}, cReq) <- withFastStore $ \db -> getContactRequest' db connReqId - (ct, conn@Connection {connId}, sqSecured) <- acceptContactRequest user cReq incognito - ucl <- withFastStore $ \db -> getUserContactLinkById db userId userContactLinkId - let contactUsed = (\(_, groupId_, _) -> isNothing groupId_) ucl - ct' <- withStore' $ \db -> do - deleteContactRequestRec db user cReq - updateContactAccepted db user ct contactUsed - conn' <- - if sqSecured - then conn {connStatus = ConnSndReady} <$ updateConnectionStatusFromTo db connId ConnNew ConnSndReady - else pure conn - pure ct {contactUsed, activeConn = Just conn'} - pure $ CRAcceptingContactRequest user ct' - APIRejectContact connReqId -> withUser $ \user -> do - userContactLinkId <- withFastStore $ \db -> getUserContactLinkIdByCReq db connReqId - withUserContactLock "rejectContact" userContactLinkId $ do - cReq@UserContactRequest {agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <- - withFastStore $ \db -> - getContactRequest db user connReqId - `storeFinally` liftIO (deleteContactRequest db user connReqId) - withAgent $ \a -> rejectContact a connId invId - pure $ CRContactRequestRejected user cReq - APISendCallInvitation contactId callType -> withUser $ \user -> do - -- party initiating call - ct <- withFastStore $ \db -> getContact db vr user contactId - assertDirectAllowed user MDSnd ct XCallInv_ - if featureAllowed SCFCalls forUser ct - then do - calls <- asks currentCalls - withContactLock "sendCallInvitation" contactId $ do - g <- asks random - callId <- atomically $ CallId <$> C.randomBytes 16 g - callUUID <- UUID.toText <$> liftIO V4.nextRandom - dhKeyPair <- atomically $ if encryptedCall callType then Just <$> C.generateKeyPair g else pure Nothing - let invitation = CallInvitation {callType, callDhPubKey = fst <$> dhKeyPair} - callState = CallInvitationSent {localCallType = callType, localDhPrivKey = snd <$> dhKeyPair} - (msg, _) <- sendDirectContactMessage user ct (XCallInv callId invitation) - ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndCall CISCallPending 0) - let call' = Call {contactId, callId, callUUID, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci} - call_ <- atomically $ TM.lookupInsert contactId call' calls - forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing - toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] - ok user - else pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFCalls)) - SendCallInvitation cName callType -> withUser $ \user -> do - contactId <- withFastStore $ \db -> getContactIdByName db user cName - processChatCommand $ APISendCallInvitation contactId callType - APIRejectCall contactId -> - -- party accepting call - withCurrentCall contactId $ \user ct Call {chatItemId, callState} -> case callState of - CallInvitationReceived {} -> do - let aciContent = ACIContent SMDRcv $ CIRcvCall CISCallRejected 0 - withFastStore' $ \db -> setDirectChatItemRead db user contactId chatItemId - timed_ <- contactCITimed ct - updateDirectChatItemView user ct chatItemId aciContent False False timed_ Nothing - forM_ (timed_ >>= timedDeleteAt') $ - startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId) - pure Nothing - _ -> throwChatError . CECallState $ callStateTag callState - APISendCallOffer contactId WebRTCCallOffer {callType, rtcSession} -> - -- party accepting call - withCurrentCall contactId $ \user ct call@Call {callId, chatItemId, callState} -> case callState of - CallInvitationReceived {peerCallType, localDhPubKey, sharedKey} -> do - let callDhPubKey = if encryptedCall callType then localDhPubKey else Nothing - offer = CallOffer {callType, rtcSession, callDhPubKey} - callState' = CallOfferSent {localCallType = callType, peerCallType, localCallSession = rtcSession, sharedKey} - aciContent = ACIContent SMDRcv $ CIRcvCall CISCallAccepted 0 - (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XCallOffer callId offer) - withFastStore' $ \db -> setDirectChatItemRead db user contactId chatItemId - updateDirectChatItemView user ct chatItemId aciContent False False Nothing $ Just msgId - pure $ Just call {callState = callState'} - _ -> throwChatError . CECallState $ callStateTag callState - APISendCallAnswer contactId rtcSession -> - -- party initiating call - withCurrentCall contactId $ \user ct call@Call {callId, chatItemId, callState} -> case callState of - CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey} -> do - let callState' = CallNegotiated {localCallType, peerCallType, localCallSession = rtcSession, peerCallSession, sharedKey} - aciContent = ACIContent SMDSnd $ CISndCall CISCallNegotiated 0 - (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XCallAnswer callId CallAnswer {rtcSession}) - updateDirectChatItemView user ct chatItemId aciContent False False Nothing $ Just msgId - pure $ Just call {callState = callState'} - _ -> throwChatError . CECallState $ callStateTag callState - APISendCallExtraInfo contactId rtcExtraInfo -> - -- any call party - withCurrentCall contactId $ \user ct call@Call {callId, callState} -> case callState of - CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey} -> do - -- TODO update the list of ice servers in localCallSession - void . sendDirectContactMessage user ct $ XCallExtra callId CallExtraInfo {rtcExtraInfo} - let callState' = CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey} - pure $ Just call {callState = callState'} - CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} -> do - -- TODO update the list of ice servers in localCallSession - void . sendDirectContactMessage user ct $ XCallExtra callId CallExtraInfo {rtcExtraInfo} - let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} - pure $ Just call {callState = callState'} - _ -> throwChatError . CECallState $ callStateTag callState - APIEndCall contactId -> - -- any call party - withCurrentCall contactId $ \user ct call@Call {callId} -> do - (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XCallEnd callId) - updateCallItemStatus user ct call WCSDisconnected $ Just msgId - pure Nothing - APIGetCallInvitations -> withUser' $ \_ -> lift $ do - calls <- asks currentCalls >>= readTVarIO - let invs = mapMaybe callInvitation $ M.elems calls - rcvCallInvitations <- rights <$> mapM rcvCallInvitation invs - pure $ CRCallInvitations rcvCallInvitations - where - callInvitation Call {contactId, callUUID, callState, callTs} = case callState of - CallInvitationReceived {peerCallType, sharedKey} -> Just (contactId, callUUID, callTs, peerCallType, sharedKey) - _ -> Nothing - rcvCallInvitation (contactId, callUUID, callTs, peerCallType, sharedKey) = runExceptT . withFastStore $ \db -> do - user <- getUserByContactId db contactId - contact <- getContact db vr user contactId - pure RcvCallInvitation {user, contact, callType = peerCallType, sharedKey, callUUID, callTs} - APIGetNetworkStatuses -> withUser $ \_ -> - CRNetworkStatuses Nothing . map (uncurry ConnNetworkStatus) . M.toList <$> chatReadVar connNetworkStatuses - APICallStatus contactId receivedStatus -> - withCurrentCall contactId $ \user ct call -> - updateCallItemStatus user ct call receivedStatus Nothing $> Just call - APIUpdateProfile userId profile -> withUserId userId (`updateProfile` profile) - APISetContactPrefs contactId prefs' -> withUser $ \user -> do - ct <- withFastStore $ \db -> getContact db vr user contactId - updateContactPrefs user ct prefs' - APISetContactAlias contactId localAlias -> withUser $ \user@User {userId} -> do - ct' <- withFastStore $ \db -> do - ct <- getContact db vr user contactId - liftIO $ updateContactAlias db userId ct localAlias - pure $ CRContactAliasUpdated user ct' - APISetConnectionAlias connId localAlias -> withUser $ \user@User {userId} -> do - conn' <- withFastStore $ \db -> do - conn <- getPendingContactConnection db userId connId - liftIO $ updateContactConnectionAlias db userId conn localAlias - pure $ CRConnectionAliasUpdated user conn' - APISetUserUIThemes uId uiThemes -> withUser $ \user@User {userId} -> do - user'@User {userId = uId'} <- withFastStore $ \db -> do - user' <- getUser db uId - liftIO $ setUserUIThemes db user uiThemes - pure user' - when (userId == uId') $ chatWriteVar currentUser $ Just (user :: User) {uiThemes} - ok user' - APISetChatUIThemes (ChatRef cType chatId) uiThemes -> withUser $ \user -> case cType of - CTDirect -> do - withFastStore $ \db -> do - ct <- getContact db vr user chatId - liftIO $ setContactUIThemes db user ct uiThemes - ok user - CTGroup -> do - withFastStore $ \db -> do - g <- getGroupInfo db vr user chatId - liftIO $ setGroupUIThemes db user g uiThemes - ok user - _ -> pure $ chatCmdError (Just user) "not supported" - APIParseMarkdown text -> pure . CRApiParsedMarkdown $ parseMaybeMarkdownList text - APIGetNtfToken -> withUser' $ \_ -> crNtfToken <$> withAgent getNtfToken - APIRegisterToken token mode -> withUser $ \_ -> - CRNtfTokenStatus <$> withAgent (\a -> registerNtfToken a token mode) - APIVerifyToken token nonce code -> withUser $ \_ -> withAgent (\a -> verifyNtfToken a token nonce code) >> ok_ - APIDeleteToken token -> withUser $ \_ -> withAgent (`deleteNtfToken` token) >> ok_ - APIGetNtfConns nonce encNtfInfo -> withUser $ \user -> do - ntfInfos <- withAgent $ \a -> getNotificationConns a nonce encNtfInfo - (errs, ntfMsgs) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (getMsgConn db) (L.toList ntfInfos)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure $ CRNtfConns ntfMsgs - where - getMsgConn :: DB.Connection -> NotificationInfo -> IO NtfConn - getMsgConn db NotificationInfo {ntfConnId, ntfMsgMeta = nMsgMeta} = do - let agentConnId = AgentConnId ntfConnId - user_ <- getUserByAConnId db agentConnId - connEntity_ <- - pure user_ $>>= \user -> - eitherToMaybe <$> runExceptT (getConnectionEntity db vr user agentConnId) - pure $ - NtfConn - { user_, - connEntity_, - -- Decrypted ntf meta of the expected message (the one notification was sent for) - expectedMsg_ = expectedMsgInfo <$> nMsgMeta - } - ApiGetConnNtfMessages connIds -> withUser $ \_ -> do - let acIds = L.map (\(AgentConnId acId) -> acId) connIds - msgs <- lift $ withAgent' $ \a -> getConnectionMessages a acIds - let ntfMsgs = L.map (\msg -> receivedMsgInfo <$> msg) msgs - pure $ CRConnNtfMessages ntfMsgs - GetUserProtoServers (AProtocolType p) -> withUser $ \user -> withServerProtocol p $ do - srvs <- withFastStore (`getUserServers` user) - liftIO $ CRUserServers user <$> groupByOperator (protocolServers p srvs) - SetUserProtoServers (AProtocolType (p :: SProtocolType p)) srvs -> withUser $ \user@User {userId} -> withServerProtocol p $ do - userServers_ <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user) - case L.nonEmpty userServers_ of - Nothing -> throwChatError $ CECommandError "no servers" - Just userServers -> case srvs of - [] -> throwChatError $ CECommandError "no servers" - _ -> do - srvs' <- mapM aUserServer srvs - processChatCommand $ APISetUserServers userId $ L.map (updatedServers p srvs') userServers - where - aUserServer :: AProtoServerWithAuth -> CM (AUserServer p) - aUserServer (AProtoServerWithAuth p' srv) = case testEquality p p' of - Just Refl -> pure $ AUS SDBNew $ newUserServer srv - Nothing -> throwChatError $ CECommandError $ "incorrect server protocol: " <> B.unpack (strEncode srv) - APITestProtoServer userId srv@(AProtoServerWithAuth _ server) -> withUserId userId $ \user -> - lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server) - TestProtoServer srv -> withUser $ \User {userId} -> - processChatCommand $ APITestProtoServer userId srv - APIGetServerOperators -> CRServerOperatorConditions <$> withFastStore getServerOperators - APISetServerOperators operators -> do - as <- asks randomAgentServers - (opsConds, srvs) <- withFastStore $ \db -> do - liftIO $ setServerOperators db operators - opsConds <- getServerOperators db - let ops = serverOperators opsConds - ops' = map Just ops <> [Nothing] - opDomains = operatorDomains ops - liftIO $ fmap (opsConds,) . mapM (getServers db as ops' opDomains) =<< getUsers db - lift $ withAgent' $ \a -> forM_ srvs $ \(auId, (smp', xftp')) -> do - setProtocolServers a auId smp' - setProtocolServers a auId xftp' - pure $ CRServerOperatorConditions opsConds - where - getServers :: DB.Connection -> RandomAgentServers -> [Maybe ServerOperator] -> [(Text, ServerOperator)] -> User -> IO (UserId, (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))) - getServers db as ops opDomains user = do - smpSrvs <- getProtocolServers db SPSMP user - xftpSrvs <- getProtocolServers db SPXFTP user - uss <- groupByOperator (ops, smpSrvs, xftpSrvs) - pure $ (aUserId user,) $ useServers as opDomains uss - SetServerOperators operatorsRoles -> do - ops <- serverOperators <$> withFastStore getServerOperators - ops' <- mapM (updateOp ops) operatorsRoles - processChatCommand $ APISetServerOperators ops' - where - updateOp :: [ServerOperator] -> ServerOperatorRoles -> CM ServerOperator - updateOp ops r = - case find (\ServerOperator {operatorId = DBEntityId opId} -> operatorId' r == opId) ops of - Just op -> pure op {enabled = enabled' r, smpRoles = smpRoles' r, xftpRoles = xftpRoles' r} - Nothing -> throwError $ ChatErrorStore $ SEOperatorNotFound $ operatorId' r - APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db -> do - CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user) - APISetUserServers userId userServers -> withUserId userId $ \user -> do - errors <- validateAllUsersServers userId $ L.toList userServers - unless (null errors) $ throwChatError (CECommandError $ "user servers validation error(s): " <> show errors) - uss <- withFastStore $ \db -> do - ts <- liftIO getCurrentTime - mapM (setUserServers db user ts) userServers - as <- asks randomAgentServers - lift $ withAgent' $ \a -> do - let auId = aUserId user - opDomains = operatorDomains $ mapMaybe operator' $ L.toList uss - (smp', xftp') = useServers as opDomains uss - setProtocolServers a auId smp' - setProtocolServers a auId xftp' - ok_ - APIValidateServers userId userServers -> withUserId userId $ \user -> - CRUserServersValidation user <$> validateAllUsersServers userId userServers - APIGetUsageConditions -> do - (usageConditions, acceptedConditions) <- withFastStore $ \db -> do - usageConditions <- getCurrentUsageConditions db - acceptedConditions <- liftIO $ getLatestAcceptedConditions db - pure (usageConditions, acceptedConditions) - -- TODO if db commit is different from source commit, conditionsText should be nothing in response - pure - CRUsageConditions - { usageConditions, - conditionsText = usageConditionsText, - acceptedConditions - } - APISetConditionsNotified condId -> do - currentTs <- liftIO getCurrentTime - withFastStore' $ \db -> setConditionsNotified db condId currentTs - ok_ - APIAcceptConditions condId opIds -> withFastStore $ \db -> do - currentTs <- liftIO getCurrentTime - acceptConditions db condId opIds currentTs - CRServerOperatorConditions <$> getServerOperators db - APISetChatItemTTL userId newTTL_ -> withUserId userId $ \user -> - checkStoreNotChanged $ - withChatLock "setChatItemTTL" $ do - case newTTL_ of - Nothing -> do - withFastStore' $ \db -> setChatItemTTL db user newTTL_ - lift $ setExpireCIFlag user False - Just newTTL -> do - oldTTL <- withFastStore' (`getChatItemTTL` user) - when (maybe True (newTTL <) oldTTL) $ do - lift $ setExpireCIFlag user False - expireChatItems user newTTL True - withFastStore' $ \db -> setChatItemTTL db user newTTL_ - lift $ startExpireCIThread user - lift . whenM chatStarted $ setExpireCIFlag user True - ok user - SetChatItemTTL newTTL_ -> withUser' $ \User {userId} -> do - processChatCommand $ APISetChatItemTTL userId newTTL_ - APIGetChatItemTTL userId -> withUserId' userId $ \user -> do - ttl <- withFastStore' (`getChatItemTTL` user) - pure $ CRChatItemTTL user ttl - GetChatItemTTL -> withUser' $ \User {userId} -> do - processChatCommand $ APIGetChatItemTTL userId - APISetNetworkConfig cfg -> withUser' $ \_ -> lift (withAgent' (`setNetworkConfig` cfg)) >> ok_ - APIGetNetworkConfig -> withUser' $ \_ -> - CRNetworkConfig <$> lift getNetworkConfig - SetNetworkConfig simpleNetCfg -> do - cfg <- (`updateNetworkConfig` simpleNetCfg) <$> lift getNetworkConfig - void . processChatCommand $ APISetNetworkConfig cfg - pure $ CRNetworkConfig cfg - APISetNetworkInfo info -> lift (withAgent' (`setUserNetworkInfo` info)) >> ok_ - ReconnectAllServers -> withUser' $ \_ -> lift (withAgent' reconnectAllServers) >> ok_ - ReconnectServer userId srv -> withUserId userId $ \user -> do - lift (withAgent' $ \a -> reconnectSMPServer a (aUserId user) srv) - ok_ - APISetChatSettings (ChatRef cType chatId) chatSettings -> withUser $ \user -> case cType of - CTDirect -> do - ct <- withFastStore $ \db -> do - ct <- getContact db vr user chatId - liftIO $ updateContactSettings db user chatId chatSettings - pure ct - forM_ (contactConnId ct) $ \connId -> - withAgent $ \a -> toggleConnectionNtfs a connId (chatHasNtfs chatSettings) - ok user - CTGroup -> do - ms <- withFastStore $ \db -> do - Group _ ms <- getGroup db vr user chatId - liftIO $ updateGroupSettings db user chatId chatSettings - pure ms - forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId -> - 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 <- withFastStore $ \db -> do - liftIO $ updateGroupMemberSettings db user gId gMemberId settings - getGroupMember db vr user gId gMemberId - let ntfOn = showMessages $ memberSettings m - toggleNtf user m ntfOn - ok user - APIContactInfo contactId -> withUser $ \user@User {userId} -> do - -- [incognito] print user's incognito profile for this contact - ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId - incognitoProfile <- case activeConn of - Nothing -> pure Nothing - Just Connection {customUserProfileId} -> - forM customUserProfileId $ \profileId -> withFastStore (\db -> getProfileById db userId profileId) - connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct) - pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile) - APIContactQueueInfo contactId -> withUser $ \user -> do - ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId - case activeConn of - Just conn -> getConnQueueInfo user conn - Nothing -> throwChatError $ CEContactNotActive ct - APIGroupInfo gId -> withUser $ \user -> do - (g, s) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> liftIO (getGroupSummary db user gId) - pure $ CRGroupInfo user g s - APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do - (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId - connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m) - pure $ CRGroupMemberInfo user g m connectionStats - APIGroupMemberQueueInfo gId gMemberId -> withUser $ \user -> do - GroupMember {activeConn} <- withFastStore $ \db -> getGroupMember db vr user gId gMemberId - case activeConn of - Just conn -> getConnQueueInfo user conn - Nothing -> throwChatError CEGroupMemberNotActive - APISwitchContact contactId -> withUser $ \user -> do - ct <- withFastStore $ \db -> getContact db vr user contactId - case contactConnId ct of - Just connId -> do - connectionStats <- withAgent $ \a -> switchConnectionAsync a "" connId - pure $ CRContactSwitchStarted user ct connectionStats - Nothing -> throwChatError $ CEContactNotActive ct - APISwitchGroupMember gId gMemberId -> withUser $ \user -> do - (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId - case memberConnId m of - Just connId -> do - connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId) - pure $ CRGroupMemberSwitchStarted user g m connectionStats - _ -> throwChatError CEGroupMemberNotActive - APIAbortSwitchContact contactId -> withUser $ \user -> do - ct <- withFastStore $ \db -> getContact db vr user contactId - case contactConnId ct of - Just connId -> do - connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId - pure $ CRContactSwitchAborted user ct connectionStats - Nothing -> throwChatError $ CEContactNotActive ct - APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do - (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId - case memberConnId m of - Just connId -> do - connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId - pure $ CRGroupMemberSwitchAborted user g m connectionStats - _ -> throwChatError CEGroupMemberNotActive - APISyncContactRatchet contactId force -> withUser $ \user -> withContactLock "syncContactRatchet" contactId $ do - ct <- withFastStore $ \db -> getContact db vr user contactId - case contactConn ct of - Just conn@Connection {pqSupport} -> do - cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a (aConnId conn) pqSupport force - createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCERatchetSync rss Nothing) Nothing - pure $ CRContactRatchetSyncStarted user ct cStats - Nothing -> throwChatError $ CEContactNotActive ct - APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> withGroupLock "syncGroupMemberRatchet" gId $ do - (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId - case memberConnId m of - Just connId -> do - cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId PQSupportOff force - createInternalChatItem user (CDGroupSnd g) (CISndConnEvent . SCERatchetSync rss . Just $ groupMemberRef m) Nothing - pure $ CRGroupMemberRatchetSyncStarted user g m cStats - _ -> throwChatError CEGroupMemberNotActive - APIGetContactCode contactId -> withUser $ \user -> do - ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId - case activeConn of - Just conn@Connection {connId} -> do - code <- getConnectionCode $ aConnId conn - ct' <- case contactSecurityCode ct of - Just SecurityCode {securityCode} - | sameVerificationCode code securityCode -> pure ct - | otherwise -> do - withFastStore' $ \db -> setConnectionVerified db user connId Nothing - pure (ct :: Contact) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} - _ -> pure ct - pure $ CRContactCode user ct' code - Nothing -> throwChatError $ CEContactNotActive ct - APIGetGroupMemberCode gId gMemberId -> withUser $ \user -> do - (g, m@GroupMember {activeConn}) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId - case activeConn of - Just conn@Connection {connId} -> do - code <- getConnectionCode $ aConnId conn - m' <- case memberSecurityCode m of - Just SecurityCode {securityCode} - | sameVerificationCode code securityCode -> pure m - | otherwise -> do - withFastStore' $ \db -> setConnectionVerified db user connId Nothing - pure (m :: GroupMember) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} - _ -> pure m - pure $ CRGroupMemberCode user g m' code - _ -> throwChatError CEGroupMemberNotActive - APIVerifyContact contactId code -> withUser $ \user -> do - ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId - case activeConn of - Just conn -> verifyConnectionCode user conn code - Nothing -> throwChatError $ CEContactNotActive ct - APIVerifyGroupMember gId gMemberId code -> withUser $ \user -> do - GroupMember {activeConn} <- withFastStore $ \db -> getGroupMember db vr user gId gMemberId - case activeConn of - Just conn -> verifyConnectionCode user conn code - _ -> throwChatError CEGroupMemberNotActive - APIEnableContact contactId -> withUser $ \user -> do - ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId - case activeConn of - Just conn -> do - withFastStore' $ \db -> setAuthErrCounter db user conn 0 - ok user - Nothing -> throwChatError $ CEContactNotActive ct - APIEnableGroupMember gId gMemberId -> withUser $ \user -> do - GroupMember {activeConn} <- withFastStore $ \db -> getGroupMember db vr user gId gMemberId - case activeConn of - Just conn -> do - withFastStore' $ \db -> setAuthErrCounter db user conn 0 - ok user - _ -> 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 - gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId - m <- withFastStore $ \db -> getGroupMember db vr user gId mId - let GroupInfo {membership = GroupMember {memberRole = membershipRole}} = gInfo - when (membershipRole >= GRAdmin) $ throwChatError $ CECantBlockMemberForSelf gInfo m showMessages - let settings = (memberSettings m) {showMessages} - processChatCommand $ APISetMemberSettings gId mId settings - ContactInfo cName -> withContactName cName APIContactInfo - ShowGroupInfo gName -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APIGroupInfo groupId - GroupMemberInfo gName mName -> withMemberName gName mName APIGroupMemberInfo - ContactQueueInfo cName -> withContactName cName APIContactQueueInfo - GroupMemberQueueInfo gName mName -> withMemberName gName mName APIGroupMemberQueueInfo - SwitchContact cName -> withContactName cName APISwitchContact - SwitchGroupMember gName mName -> withMemberName gName mName APISwitchGroupMember - AbortSwitchContact cName -> withContactName cName APIAbortSwitchContact - AbortSwitchGroupMember gName mName -> withMemberName gName mName APIAbortSwitchGroupMember - SyncContactRatchet cName force -> withContactName cName $ \ctId -> APISyncContactRatchet ctId force - SyncGroupMemberRatchet gName mName force -> withMemberName gName mName $ \gId mId -> APISyncGroupMemberRatchet gId mId force - GetContactCode cName -> withContactName cName APIGetContactCode - GetGroupMemberCode gName mName -> withMemberName gName mName APIGetGroupMemberCode - VerifyContact cName code -> withContactName cName (`APIVerifyContact` code) - VerifyGroupMember gName mName code -> withMemberName gName mName $ \gId mId -> APIVerifyGroupMember gId mId code - EnableContact cName -> withContactName cName APIEnableContact - EnableGroupMember gName mName -> withMemberName gName mName $ \gId mId -> APIEnableGroupMember gId mId - ChatHelp section -> pure $ CRChatHelp section - Welcome -> withUser $ pure . CRWelcome - APIAddContact userId incognito -> withUserId userId $ \user -> procCmd $ do - -- [incognito] generate profile for connection - incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing - subMode <- chatReadVar subscriptionMode - (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing IKPQOn subMode - -- TODO PQ pass minVersion from the current range - conn <- withFastStore' $ \db -> createDirectConnection db user connId cReq ConnNew incognitoProfile subMode initialChatVersion PQSupportOn - pure $ CRInvitation user cReq conn - AddContact incognito -> withUser $ \User {userId} -> - processChatCommand $ APIAddContact userId incognito - APISetConnectionIncognito connId incognito -> withUser $ \user@User {userId} -> do - conn'_ <- withFastStore $ \db -> do - conn@PendingContactConnection {pccConnStatus, customUserProfileId} <- getPendingContactConnection db userId connId - case (pccConnStatus, customUserProfileId, incognito) of - (ConnNew, Nothing, True) -> liftIO $ do - incognitoProfile <- generateRandomProfile - pId <- createIncognitoProfile db user incognitoProfile - Just <$> updatePCCIncognito db user conn (Just pId) - (ConnNew, Just pId, False) -> liftIO $ do - deletePCCIncognitoProfile db user pId - Just <$> updatePCCIncognito db user conn Nothing - _ -> pure Nothing - case conn'_ of - Just conn' -> pure $ CRConnectionIncognitoUpdated user conn' - Nothing -> throwChatError CEConnectionIncognitoChangeProhibited - APIChangeConnectionUser connId newUserId -> withUser $ \user@User {userId} -> do - conn <- withFastStore $ \db -> getPendingContactConnection db userId connId - let PendingContactConnection {pccConnStatus, connReqInv} = conn - case (pccConnStatus, connReqInv) of - (ConnNew, Just cReqInv) -> do - newUser <- privateGetUser newUserId - conn' <- ifM (canKeepLink cReqInv newUser) (updateConnRecord user conn newUser) (recreateConn user conn newUser) - pure $ CRConnectionUserChanged user conn conn' newUser - _ -> throwChatError CEConnectionUserChangeProhibited - where - canKeepLink :: ConnReqInvitation -> User -> CM Bool - canKeepLink (CRInvitationUri crData _) newUser = do - let ConnReqUriData {crSmpQueues = q :| _} = crData - SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q - newUserServers <- - map protoServer' . L.filter (\ServerCfg {enabled} -> enabled) - <$> getKnownAgentServers SPSMP newUser - pure $ smpServer `elem` newUserServers - updateConnRecord user@User {userId} conn@PendingContactConnection {customUserProfileId} newUser = do - withAgent $ \a -> changeConnectionUser a (aUserId user) (aConnId' conn) (aUserId newUser) - withFastStore' $ \db -> do - conn' <- updatePCCUser db userId conn newUserId - forM_ customUserProfileId $ \profileId -> - deletePCCIncognitoProfile db user profileId - pure conn' - recreateConn user conn@PendingContactConnection {customUserProfileId} newUser = do - subMode <- chatReadVar subscriptionMode - (agConnId, cReq) <- withAgent $ \a -> createConnection a (aUserId newUser) True SCMInvitation Nothing IKPQOn subMode - conn' <- withFastStore' $ \db -> do - deleteConnectionRecord db user connId - forM_ customUserProfileId $ \profileId -> - deletePCCIncognitoProfile db user profileId - createDirectConnection db newUser agConnId cReq ConnNew Nothing subMode initialChatVersion PQSupportOn - deleteAgentConnectionAsync user (aConnId' conn) - pure conn' - APIConnectPlan userId cReqUri -> withUserId userId $ \user -> - CRConnectionPlan user <$> connectPlan user cReqUri - APIConnect userId incognito (Just (ACR SCMInvitation cReq@(CRInvitationUri crData e2e))) -> withUserId userId $ \user -> withInvitationLock "connect" (strEncode cReq) . procCmd $ do - subMode <- chatReadVar subscriptionMode - -- [incognito] generate profile to send - incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing - let profileToSend = userProfileToSend user incognitoProfile Nothing False - lift (withAgent' $ \a -> connRequestPQSupport a PQSupportOn cReq) >>= \case - Nothing -> throwChatError CEInvalidConnReq - -- TODO PQ the error above should be CEIncompatibleConnReqVersion, also the same API should be called in Plan - Just (agentV, pqSup') -> do - let chatV = agentToChatVersion agentV - dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend - withFastStore' (\db -> getConnectionEntityByConnReq db vr user cReqs) >>= \case - Nothing -> joinNewConn chatV dm - Just (RcvDirectMsgConnection conn@Connection {connId, connStatus, contactConnInitiated} Nothing) - | connStatus == ConnNew && contactConnInitiated -> joinNewConn chatV dm -- own connection link - | connStatus == ConnPrepared -> do - -- retrying join after error - pcc <- withFastStore $ \db -> getPendingContactConnection db userId connId - joinPreparedConn (aConnId conn) pcc dm - Just ent -> throwChatError $ CECommandError $ "connection exists: " <> show (connEntityInfo ent) - where - joinNewConn chatV dm = do - connId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup' - pcc <- withFastStore' $ \db -> createDirectConnection db user connId cReq ConnPrepared (incognitoProfile $> profileToSend) subMode chatV pqSup' - joinPreparedConn connId pcc dm - joinPreparedConn connId pcc@PendingContactConnection {pccConnId} dm = do - void $ withAgent $ \a -> joinConnection a (aUserId user) connId True cReq dm pqSup' subMode - withFastStore' $ \db -> updateConnectionStatusFromTo db pccConnId ConnPrepared ConnJoined - pure $ CRSentConfirmation user pcc {pccConnStatus = ConnJoined} - cReqs = - ( CRInvitationUri crData {crScheme = SSSimplex} e2e, - CRInvitationUri crData {crScheme = simplexChat} e2e - ) - APIConnect userId incognito (Just (ACR SCMContact cReq)) -> withUserId userId $ \user -> connectViaContact user incognito cReq - APIConnect _ _ Nothing -> throwChatError CEInvalidConnReq - Connect incognito aCReqUri@(Just cReqUri) -> withUser $ \user@User {userId} -> do - plan <- connectPlan user cReqUri `catchChatError` const (pure $ CPInvitationLink ILPOk) - unless (connectionPlanProceed plan) $ throwChatError (CEConnectionPlan plan) - case plan of - CPContactAddress (CAPContactViaAddress Contact {contactId}) -> - processChatCommand $ APIConnectContactViaAddress userId incognito contactId - _ -> processChatCommand $ APIConnect userId incognito aCReqUri - Connect _ Nothing -> throwChatError CEInvalidConnReq - APIConnectContactViaAddress userId incognito contactId -> withUserId userId $ \user -> do - ct@Contact {activeConn, profile = LocalProfile {contactLink}} <- withFastStore $ \db -> getContact db vr user contactId - when (isJust activeConn) $ throwChatError (CECommandError "contact already has connection") - case contactLink of - Just cReq -> connectContactViaAddress user incognito ct cReq - Nothing -> throwChatError (CECommandError "no address in contact profile") - ConnectSimplex incognito -> withUser $ \user@User {userId} -> do - let cReqUri = ACR SCMContact adminContactReq - plan <- connectPlan user cReqUri `catchChatError` const (pure $ CPInvitationLink ILPOk) - unless (connectionPlanProceed plan) $ throwChatError (CEConnectionPlan plan) - case plan of - CPContactAddress (CAPContactViaAddress Contact {contactId}) -> - processChatCommand $ APIConnectContactViaAddress userId incognito contactId - _ -> processChatCommand $ APIConnect userId incognito (Just cReqUri) - DeleteContact cName cdm -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId) cdm - ClearContact cName -> withContactName cName $ APIClearChat . ChatRef CTDirect - APIListContacts userId -> withUserId userId $ \user -> - CRContactsList user <$> withFastStore' (\db -> getUserContacts db vr user) - ListContacts -> withUser $ \User {userId} -> - processChatCommand $ APIListContacts userId - APICreateMyAddress userId -> withUserId userId $ \user -> procCmd $ do - subMode <- chatReadVar subscriptionMode - (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact Nothing IKPQOn subMode - withFastStore $ \db -> createUserContactLink db user connId cReq subMode - pure $ CRUserContactLinkCreated user cReq - CreateMyAddress -> withUser $ \User {userId} -> - processChatCommand $ APICreateMyAddress userId - APIDeleteMyAddress userId -> withUserId userId $ \user@User {profile = p} -> do - conns <- withFastStore $ \db -> getUserAddressConnections db vr user - withChatLock "deleteMyAddress" $ do - deleteAgentConnectionsAsync user $ map aConnId conns - withFastStore' (`deleteUserAddress` user) - let p' = (fromLocalProfile p :: Profile) {contactLink = Nothing} - r <- updateProfile_ user p' $ withFastStore' $ \db -> setUserProfileContactLink db user Nothing - let user' = case r of - CRUserProfileUpdated u' _ _ _ -> u' - _ -> user - pure $ CRUserContactLinkDeleted user' - DeleteMyAddress -> withUser $ \User {userId} -> - processChatCommand $ APIDeleteMyAddress userId - APIShowMyAddress userId -> withUserId' userId $ \user -> - CRUserContactLink user <$> withFastStore (`getUserAddress` user) - ShowMyAddress -> withUser' $ \User {userId} -> - processChatCommand $ APIShowMyAddress userId - APISetProfileAddress userId False -> withUserId userId $ \user@User {profile = p} -> do - let p' = (fromLocalProfile p :: Profile) {contactLink = Nothing} - updateProfile_ user p' $ withFastStore' $ \db -> setUserProfileContactLink db user Nothing - APISetProfileAddress userId True -> withUserId userId $ \user@User {profile = p} -> do - ucl@UserContactLink {connReqContact} <- withFastStore (`getUserAddress` user) - let p' = (fromLocalProfile p :: Profile) {contactLink = Just connReqContact} - updateProfile_ user p' $ withFastStore' $ \db -> setUserProfileContactLink db user $ Just ucl - SetProfileAddress onOff -> withUser $ \User {userId} -> - processChatCommand $ APISetProfileAddress userId onOff - APIAddressAutoAccept userId autoAccept_ -> withUserId userId $ \user -> do - forM_ autoAccept_ $ \AutoAccept {businessAddress, acceptIncognito} -> - when (businessAddress && acceptIncognito) $ throwChatError $ CECommandError "requests to business address cannot be accepted incognito" - contactLink <- withFastStore (\db -> updateUserAddressAutoAccept db user autoAccept_) - pure $ CRUserContactLinkUpdated user contactLink - AddressAutoAccept autoAccept_ -> withUser $ \User {userId} -> - processChatCommand $ APIAddressAutoAccept userId autoAccept_ - AcceptContact incognito cName -> withUser $ \User {userId} -> do - connReqId <- withFastStore $ \db -> getContactRequestIdByName db userId cName - processChatCommand $ APIAcceptContact incognito connReqId - RejectContact cName -> withUser $ \User {userId} -> do - connReqId <- withFastStore $ \db -> getContactRequestIdByName db userId cName - processChatCommand $ APIRejectContact connReqId - ForwardMessage toChatName fromContactName forwardedMsg -> withUser $ \user -> do - contactId <- withFastStore $ \db -> getContactIdByName db user fromContactName - forwardedItemId <- withFastStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg - toChatRef <- getChatRef user toChatName - processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId) (forwardedItemId :| []) Nothing - ForwardGroupMessage toChatName fromGroupName fromMemberName_ forwardedMsg -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user fromGroupName - forwardedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId fromMemberName_ forwardedMsg - toChatRef <- getChatRef user toChatName - processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId) (forwardedItemId :| []) Nothing - ForwardLocalMessage toChatName forwardedMsg -> withUser $ \user -> do - folderId <- withFastStore (`getUserNoteFolderId` user) - forwardedItemId <- withFastStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg - toChatRef <- getChatRef user toChatName - processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId) (forwardedItemId :| []) Nothing - SendMessage (ChatName cType name) msg -> withUser $ \user -> do - let mc = MCText msg - case cType of - CTDirect -> - withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case - Right ctId -> do - let chatRef = ChatRef CTDirect ctId - processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) - Left _ -> - withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case - Right [(gInfo, member)] -> do - let GroupInfo {localDisplayName = gName} = gInfo - GroupMember {localDisplayName = mName} = member - processChatCommand $ SendMemberContactMessage gName mName msg - Right (suspectedMember : _) -> - throwChatError $ CEContactNotFound name (Just suspectedMember) - _ -> - throwChatError $ CEContactNotFound name Nothing - CTGroup -> do - gId <- withFastStore $ \db -> getGroupIdByName db user name - let chatRef = ChatRef CTGroup gId - processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) - CTLocal - | name == "" -> do - folderId <- withFastStore (`getUserNoteFolderId` user) - processChatCommand $ APICreateChatItems folderId (ComposedMessage Nothing Nothing mc :| []) - | otherwise -> throwChatError $ CECommandError "not supported" - _ -> throwChatError $ CECommandError "not supported" - SendMemberContactMessage gName mName msg -> withUser $ \user -> do - (gId, mId) <- getGroupAndMemberId user gName mName - m <- withFastStore $ \db -> getGroupMember db vr user gId mId - let mc = MCText msg - case memberContactId m of - Nothing -> do - g <- withFastStore $ \db -> getGroupInfo db vr user gId - unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed" - toView $ CRNoMemberContactCreating user g m - processChatCommand (APICreateMemberContact gId mId) >>= \case - cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do - toView cr - processChatCommand $ APISendMemberContactInvitation contactId (Just mc) - cr -> pure cr - Just ctId -> do - let chatRef = ChatRef CTDirect ctId - processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) - SendLiveMessage chatName msg -> withUser $ \user -> do - chatRef <- getChatRef user chatName - let mc = MCText msg - processChatCommand $ APISendMessages chatRef True Nothing (ComposedMessage Nothing Nothing mc :| []) - SendMessageBroadcast msg -> withUser $ \user -> do - contacts <- withFastStore' $ \db -> getUserContacts db vr user - withChatLock "sendMessageBroadcast" . procCmd $ do - let ctConns_ = L.nonEmpty $ foldr addContactConn [] contacts - case ctConns_ of - Nothing -> do - timestamp <- liftIO getCurrentTime - pure CRBroadcastSent {user, msgContent = mc, successes = 0, failures = 0, timestamp} - Just (ctConns :: NonEmpty (Contact, Connection)) -> do - let idsEvts = L.map ctSndEvent ctConns - sndMsgs <- lift $ createSndMessages idsEvts - let msgReqs_ :: NonEmpty (Either ChatError ChatMsgReq) = L.zipWith (fmap . ctMsgReq) ctConns sndMsgs - (errs, ctSndMsgs :: [(Contact, SndMessage)]) <- - partitionEithers . L.toList . zipWith3' combineResults ctConns sndMsgs <$> deliverMessagesB msgReqs_ - timestamp <- liftIO getCurrentTime - lift . void $ withStoreBatch' $ \db -> map (createCI db user timestamp) ctSndMsgs - pure CRBroadcastSent {user, msgContent = mc, successes = length ctSndMsgs, failures = length errs, timestamp} - where - mc = MCText msg - addContactConn :: Contact -> [(Contact, Connection)] -> [(Contact, Connection)] - addContactConn ct ctConns = case contactSendConn_ ct of - Right conn | directOrUsed ct -> (ct, conn) : ctConns - _ -> ctConns - ctSndEvent :: (Contact, Connection) -> (ConnOrGroupId, ChatMsgEvent 'Json) - ctSndEvent (_, Connection {connId}) = (ConnectionId connId, XMsgNew $ MCSimple (extMsgContent mc Nothing)) - ctMsgReq :: (Contact, Connection) -> SndMessage -> ChatMsgReq - ctMsgReq (_, conn) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgNew_}, msgBody, [msgId]) - zipWith3' :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d - zipWith3' f ~(x :| xs) ~(y :| ys) ~(z :| zs) = f x y z :| zipWith3 f xs ys zs - combineResults :: (Contact, Connection) -> Either ChatError SndMessage -> Either ChatError ([Int64], PQEncryption) -> Either ChatError (Contact, SndMessage) - combineResults (ct, _) (Right msg') (Right _) = Right (ct, msg') - combineResults _ (Left e) _ = Left e - combineResults _ _ (Left e) = Left e - createCI :: DB.Connection -> User -> UTCTime -> (Contact, SndMessage) -> IO () - createCI db user createdAt (ct, sndMsg) = - void $ createNewSndChatItem db user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False createdAt - SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do - contactId <- withFastStore $ \db -> getContactIdByName db user cName - quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg - let mc = MCText msg - processChatCommand $ APISendMessages (ChatRef CTDirect contactId) False Nothing (ComposedMessage Nothing (Just quotedItemId) mc :| []) - DeleteMessage chatName deletedMsg -> withUser $ \user -> do - chatRef <- getChatRef user chatName - deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg - processChatCommand $ APIDeleteChatItem chatRef (deletedItemId :| []) CIDMBroadcast - DeleteMemberMessage gName mName deletedMsg -> withUser $ \user -> do - gId <- withFastStore $ \db -> getGroupIdByName db user gName - deletedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) deletedMsg - processChatCommand $ APIDeleteMemberChatItem gId (deletedItemId :| []) - EditMessage chatName editedMsg msg -> withUser $ \user -> do - chatRef <- getChatRef user chatName - editedItemId <- getSentChatItemIdByText user chatRef editedMsg - let mc = MCText msg - processChatCommand $ APIUpdateChatItem chatRef editedItemId False mc - UpdateLiveMessage chatName chatItemId live msg -> withUser $ \user -> do - chatRef <- getChatRef user chatName - let mc = MCText msg - processChatCommand $ APIUpdateChatItem chatRef chatItemId live mc - ReactToMessage add reaction chatName msg -> withUser $ \user -> do - chatRef <- getChatRef user chatName - chatItemId <- getChatItemIdByText user chatRef msg - processChatCommand $ APIChatItemReaction chatRef chatItemId add reaction - APINewGroup userId incognito gProfile@GroupProfile {displayName} -> withUserId userId $ \user -> do - checkValidName displayName - gVar <- asks random - -- [incognito] generate incognito profile for group membership - incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing - gInfo <- withFastStore $ \db -> createNewGroup db vr gVar user gProfile incognitoProfile - let cd = CDGroupSnd gInfo - createInternalChatItem user cd (CISndGroupE2EEInfo E2EInfo {pqEnabled = PQEncOff}) Nothing - createGroupFeatureItems user cd CISndGroupFeature gInfo - pure $ CRGroupCreated user gInfo - NewGroup incognito gProfile -> withUser $ \User {userId} -> - processChatCommand $ APINewGroup userId incognito gProfile - APIAddMember groupId contactId memRole -> withUser $ \user -> withGroupLock "addMember" groupId $ do - -- TODO for large groups: no need to load all members to determine if contact is a member - (group, contact) <- withFastStore $ \db -> (,) <$> getGroup db vr user groupId <*> getContact db vr user contactId - assertDirectAllowed user MDSnd contact XGrpInv_ - let Group gInfo members = group - Contact {localDisplayName = cName} = contact - assertUserGroupRole gInfo $ max GRAdmin memRole - -- [incognito] forbid to invite contact to whom user is connected incognito - when (contactConnIncognito contact) $ throwChatError CEContactIncognitoCantInvite - -- [incognito] forbid to invite contacts if user joined the group using an incognito profile - when (incognitoMembership gInfo) $ throwChatError CEGroupIncognitoCantInvite - let sendInvitation = sendGrpInvitation user contact gInfo - case contactMember contact members of - Nothing -> do - gVar <- asks random - subMode <- chatReadVar subscriptionMode - (agentConnId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing IKPQOff subMode - member <- withFastStore $ \db -> createNewContactMember db gVar user gInfo contact memRole agentConnId cReq subMode - sendInvitation member cReq - pure $ CRSentGroupInvitation user gInfo contact member - Just member@GroupMember {groupMemberId, memberStatus, memberRole = mRole} - | memberStatus == GSMemInvited -> do - unless (mRole == memRole) $ withFastStore' $ \db -> updateGroupMemberRole db user member memRole - withFastStore' (\db -> getMemberInvitation db user groupMemberId) >>= \case - Just cReq -> do - sendInvitation member {memberRole = memRole} cReq - pure $ CRSentGroupInvitation user gInfo contact member {memberRole = memRole} - Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName - | otherwise -> throwChatError $ CEGroupDuplicateMember cName - APIJoinGroup groupId -> withUser $ \user@User {userId} -> do - withGroupLock "joinGroup" groupId . procCmd $ do - (invitation, ct) <- withFastStore $ \db -> do - inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId - (inv,) <$> getContactViaMember db vr user fromMember - let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation - GroupMember {memberId = membershipMemId} = membership - Contact {activeConn} = ct - case activeConn of - Just Connection {peerChatVRange} -> do - subMode <- chatReadVar subscriptionMode - dm <- encodeConnInfo $ XGrpAcpt membershipMemId - agentConnId <- case memberConn fromMember of - Nothing -> do - agentConnId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connRequest PQSupportOff - let chatV = vr `peerConnChatVersion` peerChatVRange - void $ withFastStore' $ \db -> createMemberConnection db userId fromMember agentConnId chatV peerChatVRange subMode - pure agentConnId - Just conn -> pure $ aConnId conn - withFastStore' $ \db -> do - updateGroupMemberStatus db userId fromMember GSMemAccepted - updateGroupMemberStatus db userId membership GSMemAccepted - void (withAgent $ \a -> joinConnection a (aUserId user) agentConnId True connRequest dm PQSupportOff subMode) - `catchChatError` \e -> do - withFastStore' $ \db -> do - updateGroupMemberStatus db userId fromMember GSMemInvited - updateGroupMemberStatus db userId membership GSMemInvited - throwError e - updateCIGroupInvitationStatus user g CIGISAccepted `catchChatError` (toView . CRChatError (Just user)) - pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing - Nothing -> throwChatError $ CEContactNotActive ct - APIMemberRole groupId memberId memRole -> withUser $ \user -> do - Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId - if memberId == groupMemberId' membership - then changeMemberRole user gInfo members membership $ SGEUserRole memRole - else case find ((== memberId) . groupMemberId') members of - Just m -> changeMemberRole user gInfo members m $ SGEMemberRole memberId (fromLocalProfile $ memberProfile m) memRole - _ -> throwChatError CEGroupMemberNotFound - where - changeMemberRole user gInfo members m gEvent = do - let GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberContactId, localDisplayName = cName} = m - assertUserGroupRole gInfo $ maximum ([GRAdmin, mRole, memRole] :: [GroupMemberRole]) - withGroupLock "memberRole" groupId . procCmd $ do - unless (mRole == memRole) $ do - withFastStore' $ \db -> updateGroupMemberRole db user m memRole - case mStatus of - GSMemInvited -> do - withFastStore (\db -> (,) <$> mapM (getContact db vr user) memberContactId <*> liftIO (getMemberInvitation db user $ groupMemberId' m)) >>= \case - (Just ct, Just cReq) -> sendGrpInvitation user ct gInfo (m :: GroupMember) {memberRole = memRole} cReq - _ -> throwChatError $ CEGroupCantResendInvitation gInfo cName - _ -> do - msg <- sendGroupMessage user gInfo members $ XGrpMemRole mId memRole - ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent gEvent) - toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] - pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole} - APIBlockMemberForAll groupId memberId blocked -> withUser $ \user -> do - Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId - when (memberId == groupMemberId' membership) $ throwChatError $ CECommandError "can't block/unblock self" - case splitMember memberId members of - Nothing -> throwChatError $ CEException "expected to find a single blocked member" - Just (bm, remainingMembers) -> do - let GroupMember {memberId = bmMemberId, memberRole = bmRole, memberProfile = bmp} = bm - assertUserGroupRole gInfo $ max GRAdmin bmRole - when (blocked == blockedByAdmin bm) $ throwChatError $ CECommandError $ if blocked then "already blocked" else "already unblocked" - withGroupLock "blockForAll" groupId . procCmd $ do - let mrs = if blocked then MRSBlocked else MRSUnrestricted - event = XGrpMemRestrict bmMemberId MemberRestrictions {restriction = mrs} - msg <- sendGroupMessage' user gInfo remainingMembers event - let ciContent = CISndGroupEvent $ SGEMemberBlocked memberId (fromLocalProfile bmp) blocked - ci <- saveSndChatItem user (CDGroupSnd gInfo) msg ciContent - toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] - bm' <- withFastStore $ \db -> do - liftIO $ updateGroupMemberBlocked db user groupId memberId mrs - getGroupMember db vr user groupId memberId - toggleNtf user bm' (not blocked) - pure CRMemberBlockedForAllUser {user, groupInfo = gInfo, member = bm', blocked} - where - splitMember mId ms = case break ((== mId) . groupMemberId') ms of - (_, []) -> Nothing - (ms1, bm : ms2) -> Just (bm, ms1 <> ms2) - APIRemoveMember groupId memberId -> withUser $ \user -> do - Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId - case find ((== memberId) . groupMemberId') members of - Nothing -> throwChatError CEGroupMemberNotFound - Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do - assertUserGroupRole gInfo $ max GRAdmin mRole - withGroupLock "removeMember" groupId . procCmd $ do - case mStatus of - GSMemInvited -> do - deleteMemberConnection user m - withFastStore' $ \db -> deleteGroupMember db user m - _ -> do - msg <- sendGroupMessage user gInfo members $ XGrpMemDel mId - ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile)) - toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] - deleteMemberConnection' user m True - -- undeleted "member connected" chat item will prevent deletion of member record - deleteOrUpdateMemberRecord user m - pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved} - APILeaveGroup groupId -> withUser $ \user@User {userId} -> do - Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId - filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo - withGroupLock "leaveGroup" groupId . procCmd $ do - cancelFilesInProgress user filesInfo - msg <- sendGroupMessage' user gInfo members XGrpLeave - ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) - toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] - -- TODO delete direct connections that were unused - deleteGroupLinkIfExists user gInfo - -- member records are not deleted to keep history - deleteMembersConnections' user members True - withFastStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft - pure $ CRLeftMemberUser user gInfo {membership = membership {memberStatus = GSMemLeft}} - APIListMembers groupId -> withUser $ \user -> - CRGroupMembers user <$> withFastStore (\db -> getGroup db vr user groupId) - AddMember gName cName memRole -> withUser $ \user -> do - (groupId, contactId) <- withFastStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName - processChatCommand $ APIAddMember groupId contactId memRole - JoinGroup gName -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APIJoinGroup groupId - MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMemberRole gId gMemberId memRole - BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMemberForAll gId gMemberId blocked - RemoveMember gName gMemberName -> withMemberName gName gMemberName APIRemoveMember - LeaveGroup gName -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APILeaveGroup groupId - DeleteGroup gName -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APIDeleteChat (ChatRef CTGroup groupId) (CDMFull True) - ClearGroup gName -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APIClearChat (ChatRef CTGroup groupId) - ListMembers gName -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APIListMembers groupId - APIListGroups userId contactId_ search_ -> withUserId userId $ \user -> - CRGroupsList user <$> withFastStore' (\db -> getUserGroupsWithSummary db vr user contactId_ search_) - ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do - ct_ <- forM cName_ $ \cName -> withFastStore $ \db -> getContactByName db vr user cName - processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_ - APIUpdateGroupProfile groupId p' -> withUser $ \user -> do - g <- withFastStore $ \db -> getGroup db vr user groupId - runUpdateGroupProfile user g p' - UpdateGroupNames gName GroupProfile {displayName, fullName} -> - updateGroupProfileByName gName $ \p -> p {displayName, fullName} - ShowGroupProfile gName -> withUser $ \user -> - CRGroupProfile user <$> withFastStore (\db -> getGroupInfoByName db vr user gName) - UpdateGroupDescription gName description -> - updateGroupProfileByName gName $ \p -> p {description} - ShowGroupDescription gName -> withUser $ \user -> - CRGroupDescription user <$> withFastStore (\db -> getGroupInfoByName db vr user gName) - APICreateGroupLink groupId mRole -> withUser $ \user -> withGroupLock "createGroupLink" groupId $ do - gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId - assertUserGroupRole gInfo GRAdmin - when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole - groupLinkId <- GroupLinkId <$> drgRandomBytes 16 - subMode <- chatReadVar subscriptionMode - let crClientData = encodeJSON $ CRDataGroup groupLinkId - (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact (Just crClientData) IKPQOff subMode - withFastStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode - pure $ CRGroupLinkCreated user gInfo cReq mRole - APIGroupLinkMemberRole groupId mRole' -> withUser $ \user -> withGroupLock "groupLinkMemberRole" groupId $ do - gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId - (groupLinkId, groupLink, mRole) <- withFastStore $ \db -> getGroupLink db user gInfo - assertUserGroupRole gInfo GRAdmin - when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole' - when (mRole' /= mRole) $ withFastStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole' - pure $ CRGroupLink user gInfo groupLink mRole' - APIDeleteGroupLink groupId -> withUser $ \user -> withGroupLock "deleteGroupLink" groupId $ do - gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId - deleteGroupLink' user gInfo - pure $ CRGroupLinkDeleted user gInfo - APIGetGroupLink groupId -> withUser $ \user -> do - gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId - (_, groupLink, mRole) <- withFastStore $ \db -> getGroupLink db user gInfo - pure $ CRGroupLink user gInfo groupLink mRole - APICreateMemberContact gId gMemberId -> withUser $ \user -> do - (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId - assertUserGroupRole g GRAuthor - unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed" - case memberConn m of - Just mConn@Connection {peerChatVRange} -> do - unless (maxVersion peerChatVRange >= groupDirectInvVersion) $ throwChatError CEPeerChatVRangeIncompatible - when (isJust $ memberContactId m) $ throwChatError $ CECommandError "member contact already exists" - subMode <- chatReadVar subscriptionMode - -- TODO PQ should negotitate contact connection with PQSupportOn? - (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing IKPQOff subMode - -- [incognito] reuse membership incognito profile - ct <- withFastStore' $ \db -> createMemberContact db user connId cReq g m mConn subMode - -- TODO not sure it is correct to set connections status here? - lift $ setContactNetworkStatus ct NSConnected - pure $ CRNewMemberContact user ct g m - _ -> throwChatError CEGroupMemberNotActive - APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do - (g@GroupInfo {groupId}, m, ct, cReq) <- withFastStore $ \db -> getMemberContact db vr user contactId - when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent" - case memberConn m of - Just mConn -> do - let msg = XGrpDirectInv cReq msgContent_ - (sndMsg, _, _) <- sendDirectMemberMessage mConn msg groupId - withFastStore' $ \db -> setContactGrpInvSent db ct True - let ct' = ct {contactGrpInvSent = True} - forM_ msgContent_ $ \mc -> do - ci <- saveSndChatItem user (CDDirectSnd ct') sndMsg (CISndMsgContent mc) - toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct') ci] - pure $ CRNewMemberContactSentInv user ct' g m - _ -> throwChatError CEGroupMemberNotActive - CreateGroupLink gName mRole -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APICreateGroupLink groupId mRole - GroupLinkMemberRole gName mRole -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APIGroupLinkMemberRole groupId mRole - DeleteGroupLink gName -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APIDeleteGroupLink groupId - ShowGroupLink gName -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APIGetGroupLink groupId - SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do - groupId <- withFastStore $ \db -> getGroupIdByName db user gName - quotedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg - let mc = MCText msg - processChatCommand $ APISendMessages (ChatRef CTGroup groupId) False Nothing (ComposedMessage Nothing (Just quotedItemId) mc :| []) - ClearNoteFolder -> withUser $ \user -> do - folderId <- withFastStore (`getUserNoteFolderId` user) - processChatCommand $ APIClearChat (ChatRef CTLocal folderId) - LastChats count_ -> withUser' $ \user -> do - let count = fromMaybe 5000 count_ - (errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user False (PTLast count) clqNoFilters) - unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs) - pure $ CRChats previews - LastMessages (Just chatName) count search -> withUser $ \user -> do - chatRef <- getChatRef user chatName - chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search - pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp) - LastMessages Nothing count search -> withUser $ \user -> do - chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast count) search - pure $ CRChatItems user Nothing chatItems - LastChatItemId (Just chatName) index -> withUser $ \user -> do - chatRef <- getChatRef user chatName - chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing) - pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp) - LastChatItemId Nothing index -> withUser $ \user -> do - chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast $ index + 1) Nothing - pure $ CRChatItemId user (fmap aChatItemId . listToMaybe $ chatItems) - ShowChatItem (Just itemId) -> withUser $ \user -> do - chatItem <- withFastStore $ \db -> do - chatRef <- getChatRefViaItemId db user itemId - getAChatItem db vr user chatRef itemId - pure $ CRChatItems user Nothing ((: []) chatItem) - ShowChatItem Nothing -> withUser $ \user -> do - chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast 1) Nothing - pure $ CRChatItems user Nothing chatItems - ShowChatItemInfo chatName msg -> withUser $ \user -> do - chatRef <- getChatRef user chatName - itemId <- getChatItemIdByText user chatRef msg - processChatCommand $ APIGetChatItemInfo chatRef itemId - ShowLiveItems on -> withUser $ \_ -> - asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_ - SendFile chatName f -> withUser $ \user -> do - chatRef <- getChatRef user chatName - case chatRef of - ChatRef CTLocal folderId -> processChatCommand $ APICreateChatItems folderId (ComposedMessage (Just f) Nothing (MCFile "") :| []) - _ -> processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage (Just f) Nothing (MCFile "") :| []) - SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do - chatRef <- getChatRef user chatName - filePath <- lift $ toFSFilePath fPath - unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath} - fileSize <- getFileSize filePath - unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath} - -- TODO include file description for preview - processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview) :| []) - ForwardFile chatName fileId -> forwardFile chatName fileId SendFile - ForwardImage chatName fileId -> forwardFile chatName fileId SendImage - SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" - -- TODO to use priority transactions we need a parameter that differentiates manual and automatic acceptance - ReceiveFile fileId userApprovedRelays encrypted_ rcvInline_ filePath_ -> withUser $ \_ -> - withFileLock "receiveFile" fileId . procCmd $ do - (user, ft@RcvFileTransfer {fileStatus}) <- withStore (`getRcvFileTransferById` fileId) - encrypt <- (`fromMaybe` encrypted_) <$> chatReadVar encryptLocalFiles - ft' <- (if encrypt && fileStatus == RFSNew then setFileToEncrypt else pure) ft - receiveFile' user ft' userApprovedRelays rcvInline_ filePath_ - SetFileToReceive fileId userApprovedRelays encrypted_ -> withUser $ \_ -> do - withFileLock "setFileToReceive" fileId . procCmd $ do - encrypt <- (`fromMaybe` encrypted_) <$> chatReadVar encryptLocalFiles - cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing - withStore' $ \db -> setRcvFileToReceive db fileId userApprovedRelays cfArgs - ok_ - CancelFile fileId -> withUser $ \user@User {userId} -> - withFileLock "cancelFile" fileId . procCmd $ - withFastStore (\db -> getFileTransfer db user fileId) >>= \case - FTSnd ftm@FileTransferMeta {xftpSndFile, cancelled} fts - | cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled" - | not (null fts) && all fileCancelledOrCompleteSMP fts -> - throwChatError $ CEFileCancel fileId "file transfer is complete" - | otherwise -> do - fileAgentConnIds <- cancelSndFile user ftm fts True - deleteAgentConnectionsAsync user fileAgentConnIds - withFastStore (\db -> liftIO $ lookupChatRefByFileId db user fileId) >>= \case - Nothing -> pure () - Just (ChatRef CTDirect contactId) -> do - (contact, sharedMsgId) <- withFastStore $ \db -> (,) <$> getContact db vr user contactId <*> getSharedMsgIdByFileId db userId fileId - void . sendDirectContactMessage user contact $ XFileCancel sharedMsgId - Just (ChatRef CTGroup groupId) -> do - (Group gInfo ms, sharedMsgId) <- withFastStore $ \db -> (,) <$> getGroup db vr user groupId <*> getSharedMsgIdByFileId db userId fileId - void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId - Just _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" - ci <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId - pure $ CRSndFileCancelled user ci ftm fts - where - fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} = - s == FSCancelled || (s == FSComplete && isNothing xftpSndFile) - FTRcv ftr@RcvFileTransfer {cancelled, fileStatus, xftpRcvFile} - | cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled" - | rcvFileComplete fileStatus -> throwChatError $ CEFileCancel fileId "file transfer is complete" - | otherwise -> case xftpRcvFile of - Nothing -> do - cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user) - ci <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId - pure $ CRRcvFileCancelled user ci ftr - Just XFTPRcvFile {agentRcvFileId} -> do - forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do - fsFilePath <- lift $ toFSFilePath filePath - liftIO $ removeFile fsFilePath `catchAll_` pure () - lift . forM_ agentRcvFileId $ \(AgentRcvFileId aFileId) -> - withAgent' (`xftpDeleteRcvFile` aFileId) - aci_ <- resetRcvCIFileStatus user fileId CIFSRcvInvitation - pure $ CRRcvFileCancelled user aci_ ftr - FileStatus fileId -> withUser $ \user -> do - withFastStore (\db -> lookupChatItemByFileId db vr user fileId) >>= \case - Nothing -> do - fileStatus <- withFastStore $ \db -> getFileTransferProgress db user fileId - pure $ CRFileTransferStatus user fileStatus - Just ci@(AChatItem _ _ _ ChatItem {file}) -> case file of - Just CIFile {fileProtocol = FPLocal} -> - throwChatError $ CECommandError "not supported for local files" - Just CIFile {fileProtocol = FPXFTP} -> - pure $ CRFileTransferStatusXFTP user ci - _ -> do - fileStatus <- withFastStore $ \db -> getFileTransferProgress db user fileId - pure $ CRFileTransferStatus user fileStatus - ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile) - UpdateProfile displayName fullName -> withUser $ \user@User {profile} -> do - let p = (fromLocalProfile profile :: Profile) {displayName = displayName, fullName = fullName} - updateProfile user p - UpdateProfileImage image -> withUser $ \user@User {profile} -> do - let p = (fromLocalProfile profile :: Profile) {image} - updateProfile user p - ShowProfileImage -> withUser $ \user@User {profile} -> pure $ CRUserProfileImage user $ fromLocalProfile profile - SetUserFeature (ACF f) allowed -> withUser $ \user@User {profile} -> do - let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user} - updateProfile user p - SetContactFeature (ACF f) cName allowed_ -> withUser $ \user -> do - ct@Contact {userPreferences} <- withFastStore $ \db -> getContactByName db vr user cName - let prefs' = setPreference f allowed_ $ Just userPreferences - updateContactPrefs user ct prefs' - SetGroupFeature (AGFNR f) gName enabled -> - updateGroupProfileByName gName $ \p -> - p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p} - SetGroupFeatureRole (AGFR f) gName enabled role -> - updateGroupProfileByName gName $ \p -> - p {groupPreferences = Just . setGroupPreferenceRole f enabled role $ groupPreferences p} - SetUserTimedMessages onOff -> withUser $ \user@User {profile} -> do - let allowed = if onOff then FAYes else FANo - pref = TimedMessagesPreference allowed Nothing - p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference' SCFTimedMessages (Just pref) $ preferences' user} - updateProfile user p - SetContactTimedMessages cName timedMessagesEnabled_ -> withUser $ \user -> do - ct@Contact {userPreferences = userPreferences@Preferences {timedMessages}} <- withFastStore $ \db -> getContactByName db vr user cName - let currentTTL = timedMessages >>= \TimedMessagesPreference {ttl} -> ttl - pref_ = tmeToPref currentTTL <$> timedMessagesEnabled_ - prefs' = setPreference' SCFTimedMessages pref_ $ Just userPreferences - updateContactPrefs user ct prefs' - SetGroupTimedMessages gName ttl_ -> do - let pref = uncurry TimedMessagesGroupPreference $ maybe (FEOff, Just 86400) (\ttl -> (FEOn, Just ttl)) ttl_ - updateGroupProfileByName gName $ \p -> - p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p} - SetLocalDeviceName name -> chatWriteVar localDeviceName name >> ok_ - ListRemoteHosts -> CRRemoteHostList <$> listRemoteHosts - SwitchRemoteHost rh_ -> CRCurrentRemoteHost <$> switchRemoteHost rh_ - StartRemoteHost rh_ ca_ bp_ -> do - (localAddrs, remoteHost_, inv@RCSignedInvitation {invitation = RCInvitation {port}}) <- startRemoteHost rh_ ca_ bp_ - pure CRRemoteHostStarted {remoteHost_, invitation = decodeLatin1 $ strEncode inv, ctrlPort = show port, localAddrs} - StopRemoteHost rh_ -> closeRemoteHost rh_ >> ok_ - DeleteRemoteHost rh -> deleteRemoteHost rh >> ok_ - StoreRemoteFile rh encrypted_ localPath -> CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath - GetRemoteFile rh rf -> getRemoteFile rh rf >> ok_ - ConnectRemoteCtrl inv -> withUser_ $ do - (remoteCtrl_, ctrlAppInfo) <- connectRemoteCtrlURI inv - pure CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion = currentAppVersion} - FindKnownRemoteCtrl -> withUser_ $ findKnownRemoteCtrl >> ok_ - ConfirmRemoteCtrl rcId -> withUser_ $ do - (rc, ctrlAppInfo) <- confirmRemoteCtrl rcId - pure CRRemoteCtrlConnecting {remoteCtrl_ = Just rc, ctrlAppInfo, appVersion = currentAppVersion} - VerifyRemoteCtrlSession sessId -> withUser_ $ CRRemoteCtrlConnected <$> verifyRemoteCtrlSession (execChatCommand Nothing) sessId - StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_ - ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls - DeleteRemoteCtrl rc -> withUser_ $ deleteRemoteCtrl rc >> ok_ - APIUploadStandaloneFile userId file@CryptoFile {filePath} -> withUserId userId $ \user -> do - fsFilePath <- lift $ toFSFilePath filePath - fileSize <- liftIO $ CF.getFileContentsSize file {filePath = fsFilePath} - when (fileSize > toInteger maxFileSizeHard) $ throwChatError $ CEFileSize filePath - (_, _, fileTransferMeta) <- xftpSndFileTransfer_ user file fileSize 1 Nothing - pure CRSndStandaloneFileCreated {user, fileTransferMeta} - APIStandaloneFileInfo FileDescriptionURI {clientData} -> pure . CRStandaloneFileInfo $ clientData >>= J.decodeStrict . encodeUtf8 - APIDownloadStandaloneFile userId uri file -> withUserId userId $ \user -> do - ft <- receiveViaURI user uri file - pure $ CRRcvStandaloneFileCreated user ft - QuitChat -> liftIO exitSuccess - ShowVersion -> do - -- simplexmqCommitQ makes iOS builds crash m( - let versionInfo = coreVersionInfo "" - chatMigrations <- map upMigration <$> withFastStore' (Migrations.getCurrent . DB.conn) - agentMigrations <- withAgent getAgentMigrations - pure $ CRVersionInfo {versionInfo, chatMigrations, agentMigrations} - DebugLocks -> lift $ do - chatLockName <- atomically . tryReadTMVar =<< asks chatLock - chatEntityLocks <- getLocks =<< asks entityLocks - agentLocks <- withAgent' debugAgentLocks - pure CRDebugLocks {chatLockName, chatEntityLocks, agentLocks} - where - getLocks ls = atomically $ M.mapKeys enityLockString . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls) - enityLockString cle = case cle of - CLInvitation bs -> "Invitation " <> B.unpack bs - CLConnection connId -> "Connection " <> show connId - CLContact ctId -> "Contact " <> show ctId - CLGroup gId -> "Group " <> show gId - CLUserContact ucId -> "UserContact " <> show ucId - CLFile fId -> "File " <> show fId - DebugEvent event -> toView event >> ok_ - GetAgentSubsTotal userId -> withUserId userId $ \user -> do - users <- withStore' $ \db -> getUsers db - let userIds = map aUserId $ filter (\u -> isNothing (viewPwdHash u) || aUserId u == aUserId user) users - (subsTotal, hasSession) <- lift $ withAgent' $ \a -> getAgentSubsTotal a userIds - pure $ CRAgentSubsTotal user subsTotal hasSession - GetAgentServersSummary userId -> withUserId userId $ \user -> do - agentServersSummary <- lift $ withAgent' getAgentServersSummary - withStore' $ \db -> do - users <- getUsers db - smpServers <- getServers db user SPSMP - xftpServers <- getServers db user SPXFTP - let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers _defaultNtfServers - pure $ CRAgentServersSummary user presentedServersSummary - where - getServers :: ProtocolTypeI p => DB.Connection -> User -> SProtocolType p -> IO [ProtocolServer p] - getServers db user p = map (\UserServer {server} -> protoServer server) <$> getProtocolServers db p user - ResetAgentServersStats -> withAgent resetAgentServersStats >> ok_ - GetAgentWorkers -> lift $ CRAgentWorkersSummary <$> withAgent' getAgentWorkersSummary - GetAgentWorkersDetails -> lift $ CRAgentWorkersDetails <$> withAgent' getAgentWorkersDetails - GetAgentSubs -> lift $ summary <$> withAgent' getAgentSubscriptions - where - summary SubscriptionsInfo {activeSubscriptions, pendingSubscriptions, removedSubscriptions} = - CRAgentSubs - { activeSubs = foldl' countSubs M.empty activeSubscriptions, - pendingSubs = foldl' countSubs M.empty pendingSubscriptions, - removedSubs = foldl' accSubErrors M.empty removedSubscriptions - } - where - countSubs m SubInfo {server} = M.alter (Just . maybe 1 (+ 1)) server m - accSubErrors m = \case - SubInfo {server, subError = Just e} -> M.alter (Just . maybe [e] (e :)) server m - _ -> m - GetAgentSubsDetails -> lift $ CRAgentSubsDetails <$> withAgent' getAgentSubscriptions - GetAgentQueuesInfo -> lift $ CRAgentQueuesInfo <$> withAgent' getAgentQueuesInfo - -- CustomChatCommand is unsupported, it can be processed in preCmdHook - -- in a modified CLI app or core - the hook should return Either ChatResponse ChatCommand - CustomChatCommand _cmd -> withUser $ \user -> pure $ chatCmdError (Just user) "not supported" - where - -- below code would make command responses asynchronous where they can be slow - -- in View.hs `r'` should be defined as `id` in this case - -- procCmd :: m ChatResponse -> m ChatResponse - -- procCmd action = do - -- ChatController {chatLock = l, smpAgent = a, outputQ = q, random = gVar} <- ask - -- corrId <- liftIO $ SMP.CorrId <$> randomBytes gVar 8 - -- void . forkIO $ - -- withAgentLock a . withLock l name $ - -- (atomically . writeTBQueue q) . (Just corrId,) =<< (action `catchChatError` (pure . CRChatError)) - -- pure $ CRCmdAccepted corrId - -- use function below to make commands "synchronous" - procCmd :: CM ChatResponse -> CM ChatResponse - procCmd = id - ok_ = pure $ CRCmdOk Nothing - ok = pure . CRCmdOk . Just - getChatRef :: User -> ChatName -> CM ChatRef - getChatRef user (ChatName cType name) = - ChatRef cType <$> case cType of - CTDirect -> withFastStore $ \db -> getContactIdByName db user name - CTGroup -> withFastStore $ \db -> getGroupIdByName db user name - CTLocal - | name == "" -> withFastStore (`getUserNoteFolderId` user) - | otherwise -> throwChatError $ CECommandError "not supported" - _ -> throwChatError $ CECommandError "not supported" - checkChatStopped :: CM ChatResponse -> CM ChatResponse - checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped) - setStoreChanged :: CM () - setStoreChanged = asks chatStoreChanged >>= atomically . (`writeTVar` True) - withStoreChanged :: CM () -> CM ChatResponse - withStoreChanged a = checkChatStopped $ a >> setStoreChanged >> ok_ - checkStoreNotChanged :: CM ChatResponse -> CM ChatResponse - checkStoreNotChanged = ifM (asks chatStoreChanged >>= readTVarIO) (throwChatError CEChatStoreChanged) - withUserName :: UserName -> (UserId -> ChatCommand) -> CM ChatResponse - withUserName uName cmd = withFastStore (`getUserIdByName` uName) >>= processChatCommand . cmd - withContactName :: ContactName -> (ContactId -> ChatCommand) -> CM ChatResponse - withContactName cName cmd = withUser $ \user -> - withFastStore (\db -> getContactIdByName db user cName) >>= processChatCommand . cmd - withMemberName :: GroupName -> ContactName -> (GroupId -> GroupMemberId -> ChatCommand) -> CM ChatResponse - withMemberName gName mName cmd = withUser $ \user -> - getGroupAndMemberId user gName mName >>= processChatCommand . uncurry cmd - getConnectionCode :: ConnId -> CM Text - getConnectionCode connId = verificationCode <$> withAgent (`getConnectionRatchetAdHash` connId) - verifyConnectionCode :: User -> Connection -> Maybe Text -> CM ChatResponse - verifyConnectionCode user conn@Connection {connId} (Just code) = do - code' <- getConnectionCode $ aConnId conn - let verified = sameVerificationCode code code' - when verified . withFastStore' $ \db -> setConnectionVerified db user connId $ Just code' - pure $ CRConnectionVerified user verified code' - verifyConnectionCode user conn@Connection {connId} _ = do - code' <- getConnectionCode $ aConnId conn - withFastStore' $ \db -> setConnectionVerified db user connId Nothing - pure $ CRConnectionVerified user False code' - getSentChatItemIdByText :: User -> ChatRef -> Text -> CM Int64 - getSentChatItemIdByText user@User {userId, localDisplayName} (ChatRef cType cId) msg = case cType of - CTDirect -> withFastStore $ \db -> getDirectChatItemIdByText db userId cId SMDSnd msg - CTGroup -> withFastStore $ \db -> getGroupChatItemIdByText db user cId (Just localDisplayName) msg - CTLocal -> withFastStore $ \db -> getLocalChatItemIdByText db user cId SMDSnd msg - _ -> throwChatError $ CECommandError "not supported" - getChatItemIdByText :: User -> ChatRef -> Text -> CM Int64 - getChatItemIdByText user (ChatRef cType cId) msg = case cType of - CTDirect -> withFastStore $ \db -> getDirectChatItemIdByText' db user cId msg - CTGroup -> withFastStore $ \db -> getGroupChatItemIdByText' db user cId msg - CTLocal -> withFastStore $ \db -> getLocalChatItemIdByText' db user cId msg - _ -> throwChatError $ CECommandError "not supported" - connectViaContact :: User -> IncognitoEnabled -> ConnectionRequestUri 'CMContact -> CM ChatResponse - connectViaContact user@User {userId} incognito cReq@(CRContactUri ConnReqUriData {crClientData}) = withInvitationLock "connectViaContact" (strEncode cReq) $ do - let groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli - cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq - case groupLinkId of - -- contact address - Nothing -> - withFastStore' (\db -> getConnReqContactXContactId db vr 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 False - -- group link - Just gLinkId -> - withFastStore' (\db -> getConnReqContactXContactId db vr user cReqHash) >>= \case - (Just _contact, _) -> procCmd $ do - -- allow repeat contact request - newXContactId <- XContactId <$> drgRandomBytes 16 - connect' (Just gLinkId) cReqHash newXContactId True - (_, xContactId_) -> procCmd $ do - let randomXContactId = XContactId <$> drgRandomBytes 16 - xContactId <- maybe randomXContactId pure xContactId_ - connect' (Just gLinkId) cReqHash xContactId True - where - connect' groupLinkId cReqHash xContactId inGroup = do - let pqSup = if inGroup then PQSupportOff else PQSupportOn - (connId, chatV) <- prepareContact user cReq pqSup - -- [incognito] generate profile to send - incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing - subMode <- chatReadVar subscriptionMode - conn@PendingContactConnection {pccConnId} <- withFastStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile groupLinkId subMode chatV pqSup - joinContact user pccConnId connId cReq incognitoProfile xContactId inGroup pqSup chatV - pure $ CRSentInvitation user conn incognitoProfile - connectContactViaAddress :: User -> IncognitoEnabled -> Contact -> ConnectionRequestUri 'CMContact -> CM ChatResponse - connectContactViaAddress user incognito ct cReq = - withInvitationLock "connectContactViaAddress" (strEncode cReq) $ do - newXContactId <- XContactId <$> drgRandomBytes 16 - let pqSup = PQSupportOn - (connId, chatV) <- prepareContact user cReq pqSup - let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq - -- [incognito] generate profile to send - incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing - subMode <- chatReadVar subscriptionMode - (pccConnId, ct') <- withFastStore $ \db -> createAddressContactConnection db vr user ct connId cReqHash newXContactId incognitoProfile subMode chatV pqSup - joinContact user pccConnId connId cReq incognitoProfile newXContactId False pqSup chatV - pure $ CRSentInvitationToContact user ct' incognitoProfile - prepareContact :: User -> ConnectionRequestUri 'CMContact -> PQSupport -> CM (ConnId, VersionChat) - prepareContact user cReq pqSup = do - -- 0) toggle disabled - PQSupportOff - -- 1) toggle enabled, address supports PQ (connRequestPQSupport returns Just True) - PQSupportOn, enable support with compression - -- 2) toggle enabled, address doesn't support PQ - PQSupportOn but without compression, with version range indicating support - lift (withAgent' $ \a -> connRequestPQSupport a pqSup cReq) >>= \case - Nothing -> throwChatError CEInvalidConnReq - Just (agentV, _) -> do - let chatV = agentToChatVersion agentV - connId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup - pure (connId, chatV) - joinContact :: User -> Int64 -> ConnId -> ConnectionRequestUri 'CMContact -> Maybe Profile -> XContactId -> Bool -> PQSupport -> VersionChat -> CM () - joinContact user pccConnId connId cReq incognitoProfile xContactId inGroup pqSup chatV = do - let profileToSend = userProfileToSend user incognitoProfile Nothing inGroup - dm <- encodeConnInfoPQ pqSup chatV (XContact profileToSend $ Just xContactId) - subMode <- chatReadVar subscriptionMode - joinPreparedAgentConnection user pccConnId connId cReq dm pqSup subMode - joinPreparedAgentConnection :: User -> Int64 -> ConnId -> ConnectionRequestUri m -> ByteString -> PQSupport -> SubscriptionMode -> CM () - joinPreparedAgentConnection user pccConnId connId cReq connInfo pqSup subMode = do - void (withAgent $ \a -> joinConnection a (aUserId user) connId True cReq connInfo pqSup subMode) - `catchChatError` \e -> do - withFastStore' $ \db -> deleteConnectionRecord db user pccConnId - withAgent $ \a -> deleteConnectionAsync a False connId - throwError e - contactMember :: Contact -> [GroupMember] -> Maybe GroupMember - contactMember Contact {contactId} = - find $ \GroupMember {memberContactId = cId, memberStatus = s} -> - cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft - checkSndFile :: CryptoFile -> CM Integer - checkSndFile (CryptoFile f cfArgs) = do - fsFilePath <- lift $ toFSFilePath f - unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f - fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cfArgs - when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f - pure fileSize - updateProfile :: User -> Profile -> CM ChatResponse - updateProfile user p' = updateProfile_ user p' $ withFastStore $ \db -> updateUserProfile db user p' - updateProfile_ :: User -> Profile -> CM User -> CM ChatResponse - updateProfile_ user@User {profile = p@LocalProfile {displayName = n}} p'@Profile {displayName = n'} updateUser - | p' == fromLocalProfile p = pure $ CRUserProfileNoChange user - | otherwise = do - when (n /= n') $ checkValidName n' - -- read contacts before user update to correctly merge preferences - contacts <- withFastStore' $ \db -> getUserContacts db vr user - user' <- updateUser - asks currentUser >>= atomically . (`writeTVar` Just user') - withChatLock "updateProfile" . procCmd $ do - let changedCts_ = L.nonEmpty $ foldr (addChangedProfileContact user') [] contacts - summary <- case changedCts_ of - Nothing -> pure $ UserProfileUpdateSummary 0 0 [] - Just changedCts -> do - let idsEvts = L.map ctSndEvent changedCts - msgReqs_ <- lift $ L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts - (errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_ - unless (null errs) $ toView $ CRChatErrors (Just user) errs - let changedCts' = filter (\ChangedProfileContact {ct, ct'} -> directOrUsed ct' && mergedPreferences ct' /= mergedPreferences ct) cts - lift $ createContactsSndFeatureItems user' changedCts' - pure - UserProfileUpdateSummary - { updateSuccesses = length cts, - updateFailures = length errs, - changedContacts = map (\ChangedProfileContact {ct'} -> ct') changedCts' - } - pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary - where - -- [incognito] filter out contacts with whom user has incognito connections - addChangedProfileContact :: User -> Contact -> [ChangedProfileContact] -> [ChangedProfileContact] - addChangedProfileContact user' ct changedCts = case contactSendConn_ ct' of - Right conn - | not (connIncognito conn) && mergedProfile' /= mergedProfile -> - ChangedProfileContact ct ct' mergedProfile' conn : changedCts - _ -> changedCts - where - mergedProfile = userProfileToSend user Nothing (Just ct) False - ct' = updateMergedPreferences user' ct - mergedProfile' = userProfileToSend user' Nothing (Just ct') False - ctSndEvent :: ChangedProfileContact -> (ConnOrGroupId, ChatMsgEvent 'Json) - ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = (ConnectionId connId, XInfo mergedProfile') - ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq - ctMsgReq ChangedProfileContact {conn} = - fmap $ \SndMessage {msgId, msgBody} -> - (conn, MsgFlags {notification = hasNotification XInfo_}, msgBody, [msgId]) - updateContactPrefs :: User -> Contact -> Preferences -> CM ChatResponse - updateContactPrefs _ ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotActive ct - updateContactPrefs user@User {userId} ct@Contact {activeConn = Just Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs' - | contactUserPrefs == contactUserPrefs' = pure $ CRContactPrefsUpdated user ct ct - | otherwise = do - assertDirectAllowed user MDSnd ct XInfo_ - ct' <- withStore' $ \db -> updateContactUserPreferences db user ct contactUserPrefs' - incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId - let mergedProfile = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct) False - mergedProfile' = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct') False - when (mergedProfile' /= mergedProfile) $ - withContactLock "updateProfile" (contactId' ct) $ do - void (sendDirectContactMessage user ct' $ XInfo mergedProfile') `catchChatError` (toView . CRChatError (Just user)) - lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct' - pure $ CRContactPrefsUpdated user ct ct' - runUpdateGroupProfile :: User -> Group -> GroupProfile -> CM ChatResponse - runUpdateGroupProfile user (Group g@GroupInfo {businessChat, groupProfile = p@GroupProfile {displayName = n}} ms) p'@GroupProfile {displayName = n'} = do - assertUserGroupRole g GROwner - when (n /= n') $ checkValidName n' - g' <- withStore $ \db -> updateGroupProfile db user g p' - msg <- case businessChat of - Just BusinessChatInfo {businessId} -> do - let (newMs, oldMs) = partition (\m -> maxVersion (memberChatVRange m) >= businessChatPrefsVersion) ms - -- this is a fallback to send the members with the old version correct profile of the business when preferences change - unless (null oldMs) $ do - GroupMember {memberProfile = LocalProfile {displayName, fullName, image}} <- - withStore $ \db -> getGroupMemberByMemberId db vr user g businessId - let p'' = p' {displayName, fullName, image} :: GroupProfile - void $ sendGroupMessage user g' oldMs (XGrpInfo p'') - let ps' = fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' - sendGroupMessage user g' newMs $ XGrpPrefs ps' - Nothing -> sendGroupMessage user g' ms (XGrpInfo p') - let cd = CDGroupSnd g' - unless (sameGroupProfileInfo p p') $ do - ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p') - toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat g') ci] - createGroupFeatureChangedItems user cd CISndGroupFeature g g' - pure $ CRGroupUpdated user g g' Nothing - checkValidName :: GroupName -> CM () - checkValidName displayName = do - when (T.null displayName) $ throwChatError CEInvalidDisplayName {displayName, validName = ""} - let validName = T.pack $ mkValidName $ T.unpack displayName - when (displayName /= validName) $ throwChatError CEInvalidDisplayName {displayName, validName} - assertUserGroupRole :: GroupInfo -> GroupMemberRole -> CM () - assertUserGroupRole g@GroupInfo {membership} requiredRole = do - let GroupMember {memberRole = membershipMemRole} = membership - when (membershipMemRole < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole - when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g) - when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved - unless (memberActive membership) $ throwChatError CEGroupMemberNotActive - delGroupChatItems :: User -> GroupInfo -> [CChatItem 'CTGroup] -> Maybe GroupMember -> CM ChatResponse - delGroupChatItems user gInfo items byGroupMember = do - deletedTs <- liftIO getCurrentTime - if groupFeatureAllowed SGFFullDelete gInfo - then deleteGroupCIs user gInfo items True False byGroupMember deletedTs - else markGroupCIsDeleted user gInfo items True byGroupMember deletedTs - updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> CM ChatResponse - updateGroupProfileByName gName update = withUser $ \user -> do - g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> - getGroupIdByName db user gName >>= getGroup db vr user - runUpdateGroupProfile user g $ update p - withCurrentCall :: ContactId -> (User -> Contact -> Call -> CM (Maybe Call)) -> CM ChatResponse - withCurrentCall ctId action = do - (user, ct) <- withStore $ \db -> do - user <- getUserByContactId db ctId - (user,) <$> getContact db vr user ctId - calls <- asks currentCalls - withContactLock "currentCall" ctId $ - atomically (TM.lookup ctId calls) >>= \case - Nothing -> throwChatError CENoCurrentCall - Just call@Call {contactId} - | ctId == contactId -> do - call_ <- action user ct call - case call_ of - Just call' -> do - unless (isRcvInvitation call') $ withStore' $ \db -> deleteCalls db user ctId - atomically $ TM.insert ctId call' calls - _ -> do - withStore' $ \db -> deleteCalls db user ctId - atomically $ TM.delete ctId calls - ok user - | otherwise -> throwChatError $ CECallContact contactId - withServerProtocol :: ProtocolTypeI p => SProtocolType p -> (UserProtocol p => CM a) -> CM a - withServerProtocol p action = case userProtocol p of - Just Dict -> action - _ -> throwChatError $ CEServerProtocol $ AProtocolType p - validateAllUsersServers :: UserServersClass u => Int64 -> [u] -> CM [UserServersError] - validateAllUsersServers currUserId userServers = withFastStore $ \db -> do - users' <- filter (\User {userId} -> userId /= currUserId) <$> liftIO (getUsers db) - others <- mapM (getUserOperatorServers db) users' - pure $ validateUserServers userServers others - where - getUserOperatorServers :: DB.Connection -> User -> ExceptT StoreError IO (User, [UserOperatorServers]) - getUserOperatorServers db user = do - uss <- liftIO . groupByOperator =<< getUserServers db user - pure (user, map updatedUserSrvs uss) - updatedUserSrvs uss = uss {operator = updatedOp <$> operator' uss} :: UserOperatorServers - updatedOp op = fromMaybe op $ find matchingOp $ mapMaybe operator' userServers - where - matchingOp op' = operatorId op' == operatorId op - forwardFile :: ChatName -> FileTransferId -> (ChatName -> CryptoFile -> ChatCommand) -> CM ChatResponse - forwardFile chatName fileId sendCommand = withUser $ \user -> do - withStore (\db -> getFileTransfer db user fileId) >>= \case - FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}, cryptoArgs} -> forward filePath cryptoArgs - FTSnd {fileTransferMeta = FileTransferMeta {filePath, xftpSndFile}} -> forward filePath $ xftpSndFile >>= \XFTPSndFile {cryptoArgs} -> cryptoArgs - _ -> throwChatError CEFileNotReceived {fileId} - where - forward path cfArgs = processChatCommand . sendCommand chatName $ CryptoFile path cfArgs - getGroupAndMemberId :: User -> GroupName -> ContactName -> CM (GroupId, GroupMemberId) - getGroupAndMemberId user gName groupMemberName = - withStore $ \db -> do - groupId <- getGroupIdByName db user gName - groupMemberId <- getGroupMemberIdByName db user groupId groupMemberName - pure (groupId, groupMemberId) - sendGrpInvitation :: User -> Contact -> GroupInfo -> GroupMember -> ConnReqInvitation -> CM () - sendGrpInvitation user ct@Contact {contactId, localDisplayName} gInfo@GroupInfo {groupId, groupProfile, membership, businessChat} GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do - currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo - let GroupMember {memberRole = userRole, memberId = userMemberId} = membership - groupInv = - GroupInvitation - { fromMember = MemberIdRole userMemberId userRole, - invitedMember = MemberIdRole memberId memRole, - connRequest = cReq, - groupProfile, - business = businessChat, - groupLinkId = Nothing, - groupSize = Just currentMemCount - } - (msg, _) <- sendDirectContactMessage user ct $ XGrpInv groupInv - let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole - timed_ <- contactCITimed ct - ci <- saveSndChatItem' user (CDDirectSnd ct) msg content Nothing Nothing Nothing timed_ False - toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] - forM_ (timed_ >>= timedDeleteAt') $ - startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) - drgRandomBytes :: Int -> CM ByteString - drgRandomBytes n = asks random >>= atomically . C.randomBytes n - privateGetUser :: UserId -> CM User - privateGetUser userId = - tryChatError (withStore (`getUser` userId)) >>= \case - Left _ -> throwChatError CEUserUnknown - Right user -> pure user - validateUserPassword :: User -> User -> Maybe UserPwd -> CM () - validateUserPassword = validateUserPassword_ . Just - validateUserPassword_ :: Maybe User -> User -> Maybe UserPwd -> CM () - validateUserPassword_ user_ User {userId = userId', viewPwdHash} viewPwd_ = - forM_ viewPwdHash $ \pwdHash -> - let userId_ = (\User {userId} -> userId) <$> user_ - pwdOk = case viewPwd_ of - Nothing -> userId_ == Just userId' - Just (UserPwd viewPwd) -> validPassword viewPwd pwdHash - in unless pwdOk $ throwChatError CEUserUnknown - validPassword :: Text -> UserPwdHash -> Bool - validPassword pwd UserPwdHash {hash = B64UrlByteString hash, salt = B64UrlByteString salt} = - hash == C.sha512Hash (encodeUtf8 pwd <> salt) - setUserNotifications :: UserId -> Bool -> CM ChatResponse - setUserNotifications userId' showNtfs = withUser $ \user -> do - user' <- privateGetUser userId' - case viewPwdHash user' of - Just _ -> throwChatError $ CEHiddenUserAlwaysMuted userId' - _ -> setUserPrivacy user user' {showNtfs} - setUserPrivacy :: User -> User -> CM ChatResponse - setUserPrivacy user@User {userId} user'@User {userId = userId'} - | userId == userId' = do - asks currentUser >>= atomically . (`writeTVar` Just user') - withFastStore' (`updateUserPrivacy` user') - pure $ CRUserPrivacy {user = user', updatedUser = user'} - | otherwise = do - withFastStore' (`updateUserPrivacy` user') - pure $ CRUserPrivacy {user, updatedUser = user'} - checkDeleteChatUser :: User -> CM () - checkDeleteChatUser user@User {userId} = do - users <- withFastStore' getUsers - let otherVisible = filter (\User {userId = userId', viewPwdHash} -> userId /= userId' && isNothing viewPwdHash) users - when (activeUser user && length otherVisible > 0) $ throwChatError (CECantDeleteActiveUser userId) - deleteChatUser :: User -> Bool -> CM ChatResponse - deleteChatUser user delSMPQueues = do - filesInfo <- withFastStore' (`getUserFileInfo` user) - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo - withAgent (\a -> deleteUser a (aUserId user) delSMPQueues) - `catchChatError` \case - e@(ChatErrorAgent NO_USER _) -> toView $ CRChatError (Just user) e - e -> throwError e - withFastStore' (`deleteUserRecord` user) - when (activeUser user) $ chatWriteVar currentUser Nothing - ok_ - updateChatSettings :: ChatName -> (ChatSettings -> ChatSettings) -> CM ChatResponse - updateChatSettings (ChatName cType name) updateSettings = withUser $ \user -> do - (chatId, chatSettings) <- case cType of - CTDirect -> withFastStore $ \db -> do - ctId <- getContactIdByName db user name - Contact {chatSettings} <- getContact db vr user ctId - pure (ctId, chatSettings) - CTGroup -> - withFastStore $ \db -> do - gId <- getGroupIdByName db user name - GroupInfo {chatSettings} <- getGroupInfo db vr user gId - pure (gId, chatSettings) - _ -> throwChatError $ CECommandError "not supported" - processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings - connectPlan :: User -> AConnectionRequestUri -> CM ConnectionPlan - connectPlan user (ACR SCMInvitation (CRInvitationUri crData e2e)) = do - withFastStore' (\db -> getConnectionEntityByConnReq db vr user cReqSchemas) >>= \case - Nothing -> pure $ CPInvitationLink ILPOk - Just (RcvDirectMsgConnection Connection {connStatus = ConnPrepared} 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" - where - cReqSchemas :: (ConnReqInvitation, ConnReqInvitation) - cReqSchemas = - ( CRInvitationUri crData {crScheme = SSSimplex} e2e, - CRInvitationUri crData {crScheme = simplexChat} e2e - ) - connectPlan user (ACR SCMContact (CRContactUri crData)) = do - let ConnReqUriData {crClientData} = crData - groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli - case groupLinkId of - -- contact address - Nothing -> - withFastStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case - Just _ -> pure $ CPContactAddress CAPOwnLink - Nothing -> - withFastStore' (\db -> getContactConnEntityByConnReqHash db vr user cReqHashes) >>= \case - Nothing -> - withFastStore' (\db -> getContactWithoutConnViaAddress db vr user cReqSchemas) >>= \case - Nothing -> pure $ CPContactAddress CAPOk - Just ct -> pure $ CPContactAddress (CAPContactViaAddress ct) - Just (RcvDirectMsgConnection _conn Nothing) -> pure $ CPContactAddress CAPConnectingConfirmReconnect - Just (RcvDirectMsgConnection _ (Just ct)) - | not (contactReady ct) && contactActive ct -> pure $ CPContactAddress (CAPConnectingProhibit ct) - | contactDeleted ct -> pure $ CPContactAddress CAPOk - | otherwise -> pure $ CPContactAddress (CAPKnown ct) - Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo - Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection or RcvGroupMsgConnection" - -- group link - Just _ -> - withFastStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case - Just g -> pure $ CPGroupLink (GLPOwnLink g) - Nothing -> do - connEnt_ <- withFastStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes - gInfo_ <- withFastStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes - case (gInfo_, connEnt_) of - (Nothing, Nothing) -> pure $ CPGroupLink GLPOk - (Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> pure $ CPGroupLink GLPConnectingConfirmReconnect - (Nothing, Just (RcvDirectMsgConnection _ (Just ct))) - | not (contactReady ct) && contactActive ct -> pure $ CPGroupLink (GLPConnectingProhibit gInfo_) - | otherwise -> pure $ CPGroupLink GLPOk - (Nothing, Just _) -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" - (Just gInfo, _) -> groupPlan gInfo - where - groupPlan gInfo@GroupInfo {membership} - | not (memberActive membership) && not (memberRemoved membership) = - pure $ CPGroupLink (GLPConnectingProhibit $ Just gInfo) - | memberActive membership = pure $ CPGroupLink (GLPKnown gInfo) - | otherwise = pure $ CPGroupLink GLPOk - cReqSchemas :: (ConnReqContact, ConnReqContact) - cReqSchemas = - ( CRContactUri crData {crScheme = SSSimplex}, - CRContactUri crData {crScheme = simplexChat} - ) - cReqHashes :: (ConnReqUriHash, ConnReqUriHash) - cReqHashes = bimap hash hash cReqSchemas - hash = ConnReqUriHash . C.sha256Hash . strEncode - updateCIGroupInvitationStatus user GroupInfo {groupId} newStatus = do - AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withFastStore $ \db -> getChatItemByGroupId db vr user groupId - case (cInfo, content) of - (DirectChat ct@Contact {contactId}, CIRcvGroupInvitation ciGroupInv@CIGroupInvitation {status} memRole) - | status == CIGISPending -> do - let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = newStatus} memRole - timed_ <- contactCITimed ct - updateDirectChatItemView user ct itemId aciContent False False timed_ Nothing - forM_ (timed_ >>= timedDeleteAt') $ - startProximateTimedItemThread user (ChatRef CTDirect contactId, itemId) - _ -> pure () -- prohibited - sendContactContentMessages :: User -> ContactId -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse - sendContactContentMessages user contactId live itemTTL cmrs = do - assertMultiSendable live cmrs - ct@Contact {contactUsed} <- withFastStore $ \db -> getContact db vr user contactId - assertDirectAllowed user MDSnd ct XMsgNew_ - assertVoiceAllowed ct - unless contactUsed $ withFastStore' $ \db -> updateContactUsed db user ct - processComposedMessages ct - where - assertVoiceAllowed :: Contact -> CM () - assertVoiceAllowed ct = - when (not (featureAllowed SCFVoice forUser ct) && any (\(ComposedMessage {msgContent}, _) -> isVoice msgContent) cmrs) $ - throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFVoice)) - processComposedMessages :: Contact -> CM ChatResponse - processComposedMessages ct = do - (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers - timed_ <- sndContactCITimed live ct itemTTL - (msgContainers, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ - msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers - let itemsData = prepareSndItemsData msgs_ cmrs ciFiles_ quotedItems_ - when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch" - r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live - processSendErrs user r - forM_ (timed_ >>= timedDeleteAt') $ \deleteAt -> - forM_ cis $ \ci -> - startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) deleteAt - pure $ CRNewChatItems user (map (AChatItem SCTDirect SMDSnd (DirectChat ct)) cis) - where - setupSndFileTransfers :: CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd))) - setupSndFileTransfers = - forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> case file_ of - Just file -> do - fileSize <- checkSndFile file - (fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 $ CGContact ct - pure (Just fInv, Just ciFile) - Nothing -> pure (Nothing, Nothing) - prepareMsgs :: NonEmpty (ComposeMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect))) - prepareMsgs cmsFileInvs timed_ = - forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded), fInv_) -> - case (quotedItemId, itemForwarded) of - (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) - (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) - (Just qiId, Nothing) -> do - CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- - withFastStore $ \db -> getDirectChatItem db user contactId qiId - (origQmc, qd, sent) <- quoteData qci - let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} - qmc = quoteContent mc origQmc file - quotedItem = CIQuote {chatDir = qd, itemId = Just qiId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) - (Just _, Just _) -> throwChatError CEInvalidQuote - where - quoteData :: ChatItem c d -> CM (MsgContent, CIQDirection 'CTDirect, Bool) - quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote - quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True) - quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) - quoteData _ = throwChatError CEInvalidQuote - sendGroupContentMessages :: User -> GroupId -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse - sendGroupContentMessages user groupId live itemTTL cmrs = do - assertMultiSendable live cmrs - g@(Group gInfo _) <- withFastStore $ \db -> getGroup db vr user groupId - assertUserGroupRole gInfo GRAuthor - assertGroupContentAllowed gInfo - processComposedMessages g - where - assertGroupContentAllowed :: GroupInfo -> CM () - assertGroupContentAllowed gInfo@GroupInfo {membership} = - case findProhibited (L.toList cmrs) of - Just f -> throwChatError (CECommandError $ "feature not allowed " <> T.unpack (groupFeatureNameText f)) - Nothing -> pure () - where - findProhibited :: [ComposeMessageReq] -> Maybe GroupFeature - findProhibited = - foldr' - (\(ComposedMessage {fileSource, msgContent = mc}, _) acc -> prohibitedGroupContent gInfo membership mc fileSource <|> acc) - Nothing - processComposedMessages :: Group -> CM ChatResponse - processComposedMessages g@(Group gInfo ms) = do - (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length $ filter memberCurrent ms) - timed_ <- sndGroupCITimed live gInfo itemTTL - (msgContainers, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ - (msgs_, gsr) <- sendGroupMessages user gInfo ms $ L.map XMsgNew msgContainers - let itemsData = prepareSndItemsData (L.toList msgs_) cmrs ciFiles_ quotedItems_ - cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData timed_ live - when (length itemsData /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch" - createMemberSndStatuses cis_ msgs_ gsr - let r@(_, cis) = partitionEithers cis_ - processSendErrs user r - forM_ (timed_ >>= timedDeleteAt') $ \deleteAt -> - forM_ cis $ \ci -> - startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) deleteAt - pure $ CRNewChatItems user (map (AChatItem SCTGroup SMDSnd (GroupChat gInfo)) cis) - where - setupSndFileTransfers :: Int -> CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd))) - setupSndFileTransfers n = - forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> case file_ of - Just file -> do - fileSize <- checkSndFile file - (fInv, ciFile) <- xftpSndFileTransfer user file fileSize n $ CGGroup g - pure (Just fInv, Just ciFile) - Nothing -> pure (Nothing, Nothing) - prepareMsgs :: NonEmpty (ComposeMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTGroup))) - prepareMsgs cmsFileInvs timed_ = - forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded), fInv_) -> - prepareGroupMsg user gInfo mc quotedItemId itemForwarded fInv_ timed_ live - createMemberSndStatuses :: - [Either ChatError (ChatItem 'CTGroup 'MDSnd)] -> - NonEmpty (Either ChatError SndMessage) -> - GroupSndResult -> - CM () - createMemberSndStatuses cis_ msgs_ GroupSndResult {sentTo, pending, forwarded} = do - let msgToItem = mapMsgToItem - withFastStore' $ \db -> do - forM_ sentTo (processSentTo db msgToItem) - forM_ forwarded (processForwarded db) - forM_ pending (processPending db msgToItem) - where - mapMsgToItem :: Map MessageId ChatItemId - mapMsgToItem = foldr' addItem M.empty (zip (L.toList msgs_) cis_) - where - addItem (Right SndMessage {msgId}, Right ci) m = M.insert msgId (chatItemId' ci) m - addItem _ m = m - processSentTo :: DB.Connection -> Map MessageId ChatItemId -> (GroupMemberId, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption)) -> IO () - processSentTo db msgToItem (mId, msgIds_, deliveryResult) = forM_ msgIds_ $ \msgIds -> do - let ciIds = mapMaybe (`M.lookup` msgToItem) msgIds - status = case deliveryResult of - Right _ -> GSSNew - Left e -> GSSError $ SndErrOther $ tshow e - forM_ ciIds $ \ciId -> createGroupSndStatus db ciId mId status - processForwarded :: DB.Connection -> GroupMember -> IO () - processForwarded db GroupMember {groupMemberId} = - forM_ cis_ $ \ci_ -> - forM_ ci_ $ \ci -> createGroupSndStatus db (chatItemId' ci) groupMemberId GSSForwarded - processPending :: DB.Connection -> Map MessageId ChatItemId -> (GroupMemberId, Either ChatError MessageId, Either ChatError ()) -> IO () - processPending db msgToItem (mId, msgId_, pendingResult) = forM_ msgId_ $ \msgId -> do - let ciId_ = M.lookup msgId msgToItem - status = case pendingResult of - Right _ -> GSSInactive - Left e -> GSSError $ SndErrOther $ tshow e - forM_ ciId_ $ \ciId -> createGroupSndStatus db ciId mId status - assertMultiSendable :: Bool -> NonEmpty ComposeMessageReq -> CM () - assertMultiSendable live cmrs - | length cmrs == 1 = pure () - | otherwise = - -- When sending multiple messages only single quote is allowed. - -- This is to support case of sending multiple attachments while also quoting another message. - -- UI doesn't allow composing with multiple quotes, so api prohibits it as well, and doesn't bother - -- batching retrieval of quoted messages (prepareMsgs). - when (live || length (L.filter (\(ComposedMessage {quotedItemId}, _) -> isJust quotedItemId) cmrs) > 1) $ - throwChatError (CECommandError "invalid multi send: live and more than one quote not supported") - xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd) - xftpSndFileTransfer user file fileSize n contactOrGroup = do - (fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup - case contactOrGroup of - CGContact Contact {activeConn} -> forM_ activeConn $ \conn -> - withFastStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr - CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user)) - where - -- we are not sending files to pending members, same as with inline files - saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} = - when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $ - withFastStore' $ - \db -> createSndFTDescrXFTP db user (Just m) conn ft dummyFileDescr - saveMemberFD _ = pure () - pure (fInv, ciFile) - prepareSndItemsData :: - [Either ChatError SndMessage] -> - NonEmpty ComposeMessageReq -> - NonEmpty (Maybe (CIFile 'MDSnd)) -> - NonEmpty (Maybe (CIQuote c)) -> - [Either ChatError (NewSndChatItemData c)] - prepareSndItemsData msgs_ cmrs' ciFiles_ quotedItems_ = - [ ( case msg_ of - Right msg -> Right $ NewSndChatItemData msg (CISndMsgContent msgContent) f q itemForwarded - Left e -> Left e -- step over original error - ) - | (msg_, (ComposedMessage {msgContent}, itemForwarded), f, q) <- - zipWith4 (,,,) msgs_ (L.toList cmrs') (L.toList ciFiles_) (L.toList quotedItems_) - ] - processSendErrs :: User -> ([ChatError], [ChatItem c d]) -> CM () - processSendErrs user = \case - -- no errors - ([], _) -> pure () - -- at least one item is successfully created - (errs, _ci : _) -> toView $ CRChatErrors (Just user) errs - -- single error - ([err], []) -> throwError err - -- multiple errors - (errs@(err : _), []) -> do - toView $ CRChatErrors (Just user) errs - throwError err - getCommandDirectChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (Contact, [CChatItem 'CTDirect]) - getCommandDirectChatItems user ctId itemIds = do - ct <- withFastStore $ \db -> getContact db vr user ctId - (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getDirectCI db) (L.toList itemIds)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure (ct, items) - where - getDirectCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTDirect)) - getDirectCI db itemId = runExceptT . withExceptT ChatErrorStore $ getDirectChatItem db user ctId itemId - getCommandGroupChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (GroupInfo, [CChatItem 'CTGroup]) - getCommandGroupChatItems user gId itemIds = do - gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId - (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db) (L.toList itemIds)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure (gInfo, items) - where - getGroupCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup)) - getGroupCI db itemId = runExceptT . withExceptT ChatErrorStore $ getGroupChatItem db user gId itemId - getCommandLocalChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (NoteFolder, [CChatItem 'CTLocal]) - getCommandLocalChatItems user nfId itemIds = do - nf <- withStore $ \db -> getNoteFolder db user nfId - (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getLocalCI db) (L.toList itemIds)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure (nf, items) - where - getLocalCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTLocal)) - getLocalCI db itemId = runExceptT . withExceptT ChatErrorStore $ getLocalChatItem db user nfId itemId - forwardMsgContent :: ChatItem c d -> CM (Maybe MsgContent) - forwardMsgContent ChatItem {meta = CIMeta {itemDeleted = Just _}} = pure Nothing -- this can be deleted after selection - forwardMsgContent ChatItem {content = CISndMsgContent fmc} = pure $ Just fmc - forwardMsgContent ChatItem {content = CIRcvMsgContent fmc} = pure $ Just fmc - forwardMsgContent _ = throwChatError CEInvalidForward - createNoteFolderContentItems :: User -> NoteFolderId -> NonEmpty ComposeMessageReq -> CM ChatResponse - createNoteFolderContentItems user folderId cmrs = do - assertNoQuotes - nf <- withFastStore $ \db -> getNoteFolder db user folderId - createdAt <- liftIO getCurrentTime - ciFiles_ <- createLocalFiles nf createdAt - let itemsData = prepareLocalItemsData cmrs ciFiles_ - cis <- createLocalChatItems user (CDLocalSnd nf) itemsData createdAt - pure $ CRNewChatItems user (map (AChatItem SCTLocal SMDSnd (LocalChat nf)) cis) - where - assertNoQuotes :: CM () - assertNoQuotes = - when (any (\(ComposedMessage {quotedItemId}, _) -> isJust quotedItemId) cmrs) $ - throwChatError (CECommandError "createNoteFolderContentItems: quotes not supported") - createLocalFiles :: NoteFolder -> UTCTime -> CM (NonEmpty (Maybe (CIFile 'MDSnd))) - createLocalFiles nf createdAt = - forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> - forM file_ $ \cf@CryptoFile {filePath, cryptoArgs} -> do - fsFilePath <- lift $ toFSFilePath filePath - fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs - chunkSize <- asks $ fileChunkSize . config - withFastStore' $ \db -> do - fileId <- createLocalFile CIFSSndStored db user nf createdAt cf fileSize chunkSize - pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal} - prepareLocalItemsData :: - NonEmpty ComposeMessageReq -> - NonEmpty (Maybe (CIFile 'MDSnd)) -> - [(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom)] - prepareLocalItemsData cmrs' ciFiles_ = - [ (CISndMsgContent mc, f, itemForwarded) - | ((ComposedMessage {msgContent = mc}, itemForwarded), f) <- zip (L.toList cmrs') (L.toList ciFiles_) - ] - getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do - msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId) - CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId) - -protocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -protocolServers p (operators, smpServers, xftpServers) = case p of - SPSMP -> (operators, smpServers, []) - SPXFTP -> (operators, [], xftpServers) - --- disable preset and replace custom servers (groupByOperator always adds custom) -updatedServers :: forall p. UserProtocol p => SProtocolType p -> [AUserServer p] -> UserOperatorServers -> UpdatedUserOperatorServers -updatedServers p' srvs UserOperatorServers {operator, smpServers, xftpServers} = case p' of - SPSMP -> u (updateSrvs smpServers, map (AUS SDBStored) xftpServers) - SPXFTP -> u (map (AUS SDBStored) smpServers, updateSrvs xftpServers) - where - u = uncurry $ UpdatedUserOperatorServers operator - updateSrvs :: [UserServer p] -> [AUserServer p] - updateSrvs pSrvs = map disableSrv pSrvs <> maybe srvs (const []) operator - disableSrv srv@UserServer {preset} = - AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True} - -type ComposeMessageReq = (ComposedMessage, Maybe CIForwardedFrom) - -contactCITimed :: Contact -> CM (Maybe CITimed) -contactCITimed ct = sndContactCITimed False ct Nothing - -sndContactCITimed :: Bool -> Contact -> Maybe Int -> CM (Maybe CITimed) -sndContactCITimed live = sndCITimed_ live . contactTimedTTL - -sndGroupCITimed :: Bool -> GroupInfo -> Maybe Int -> CM (Maybe CITimed) -sndGroupCITimed live = sndCITimed_ live . groupTimedTTL - -sndCITimed_ :: Bool -> Maybe (Maybe Int) -> Maybe Int -> CM (Maybe CITimed) -sndCITimed_ live chatTTL itemTTL = - forM (chatTTL >>= (itemTTL <|>)) $ \ttl -> - CITimed ttl - <$> if live - then pure Nothing - else Just . addUTCTime (realToFrac ttl) <$> liftIO getCurrentTime - -toggleNtf :: User -> GroupMember -> Bool -> CM () -toggleNtf user m ntfOn = - when (memberActive m) $ - forM_ (memberConnId m) $ \connId -> - withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user)) - -data ChangedProfileContact = ChangedProfileContact - { ct :: Contact, - ct' :: Contact, - mergedProfile' :: Profile, - conn :: Connection - } - -prepareGroupMsg :: User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> CM (MsgContainer, Maybe (CIQuote 'CTGroup)) -prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of - (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) - (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) - (Just quotedItemId, Nothing) -> do - CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- - withStore $ \db -> getGroupChatItem db user groupId quotedItemId - (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership - let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} - qmc = quoteContent mc origQmc file - quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) - (Just _, Just _) -> throwChatError CEInvalidQuote - where - quoteData :: ChatItem c d -> GroupMember -> CM (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) - quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote - quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership') - quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m) - quoteData _ _ = throwChatError CEInvalidQuote - -quoteContent :: forall d. MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent -quoteContent mc qmc ciFile_ - | replaceContent = MCText qTextOrFile - | otherwise = case qmc of - MCImage _ image -> MCImage qTextOrFile image - MCFile _ -> MCFile qTextOrFile - -- consider same for voice messages - -- MCVoice _ voice -> MCVoice qTextOrFile voice - _ -> qmc - where - -- if the message we're quoting with is one of the "large" MsgContents - -- we replace the quote's content with MCText - replaceContent = case mc of - MCText _ -> False - MCFile _ -> False - MCLink {} -> True - MCImage {} -> True - MCVideo {} -> True - MCVoice {} -> False - MCUnknown {} -> True - qText = msgContentText qmc - getFileName :: CIFile d -> String - getFileName CIFile {fileName} = fileName - qFileName = maybe qText (T.pack . getFileName) ciFile_ - qTextOrFile = if T.null qText then qFileName else qText - -assertDirectAllowed :: User -> MsgDirection -> Contact -> CMEventTag e -> CM () -assertDirectAllowed user dir ct event = - unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $ - throwChatError (CEDirectMessagesProhibited dir ct) - where - directMessagesAllowed = any (uncurry $ groupFeatureMemberAllowed' SGFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct) - allowedChatEvent = case event of - XMsgNew_ -> False - XMsgUpdate_ -> False - XMsgDel_ -> False - XFile_ -> False - XGrpInv_ -> False - XCallInv_ -> False - _ -> True - -prohibitedGroupContent :: GroupInfo -> GroupMember -> MsgContent -> Maybe f -> Maybe GroupFeature -prohibitedGroupContent gInfo m mc file_ - | isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) = Just GFVoice - | not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles - | prohibitedSimplexLinks gInfo m mc = Just GFSimplexLinks - | otherwise = Nothing - -prohibitedSimplexLinks :: GroupInfo -> GroupMember -> MsgContent -> Bool -prohibitedSimplexLinks gInfo m mc = - not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo) - && maybe False (any ftIsSimplexLink) (parseMaybeMarkdownList $ msgContentText mc) - where - ftIsSimplexLink :: FormattedText -> Bool - ftIsSimplexLink FormattedText {format} = maybe False isSimplexLink format - -roundedFDCount :: Int -> Int -roundedFDCount n - | n <= 0 = 4 - | otherwise = max 4 $ fromIntegral $ (2 :: Integer) ^ (ceiling (logBase 2 (fromIntegral n) :: Double) :: Integer) - -startExpireCIThread :: User -> CM' () -startExpireCIThread user@User {userId} = do - expireThreads <- asks expireCIThreads - atomically (TM.lookup userId expireThreads) >>= \case - Nothing -> do - a <- Just <$> async runExpireCIs - atomically $ TM.insert userId a expireThreads - _ -> pure () - where - runExpireCIs = do - delay <- asks (initialCleanupManagerDelay . config) - liftIO $ threadDelay' delay - interval <- asks $ ciExpirationInterval . config - forever $ do - flip catchChatError' (toView' . CRChatError (Just user)) $ do - expireFlags <- asks expireCIFlags - atomically $ TM.lookup userId expireFlags >>= \b -> unless (b == Just True) retry - lift waitChatStartedAndActivated - ttl <- withStore' (`getChatItemTTL` user) - forM_ ttl $ \t -> expireChatItems user t False - liftIO $ threadDelay' interval - -setExpireCIFlag :: User -> Bool -> CM' () -setExpireCIFlag User {userId} b = do - expireFlags <- asks expireCIFlags - atomically $ TM.insert userId b expireFlags - -setAllExpireCIFlags :: Bool -> CM' () -setAllExpireCIFlags b = do - expireFlags <- asks expireCIFlags - atomically $ do - keys <- M.keys <$> readTVar expireFlags - forM_ keys $ \k -> TM.insert k b expireFlags - -cancelFilesInProgress :: User -> [CIFileInfo] -> CM () -cancelFilesInProgress user filesInfo = do - let filesInfo' = filter (not . fileEnded) filesInfo - (sfs, rfs) <- lift $ splitFTTypes <$> withStoreBatch (\db -> map (getFT db) filesInfo') - forM_ rfs $ \RcvFileTransfer {fileId} -> lift (closeFileHandle fileId rcvFiles) `catchChatError` \_ -> pure () - lift . void . withStoreBatch' $ \db -> map (updateSndFileCancelled db) sfs - lift . void . withStoreBatch' $ \db -> map (updateRcvFileCancelled db) rfs - let xsfIds = mapMaybe (\(FileTransferMeta {fileId, xftpSndFile}, _) -> (,fileId) <$> xftpSndFile) sfs - xrfIds = mapMaybe (\RcvFileTransfer {fileId, xftpRcvFile} -> (,fileId) <$> xftpRcvFile) rfs - lift $ agentXFTPDeleteSndFilesRemote user xsfIds - lift $ agentXFTPDeleteRcvFiles xrfIds - let smpSFConnIds = concatMap (\(ft, sfts) -> mapMaybe (smpSndFileConnId ft) sfts) sfs - smpRFConnIds = mapMaybe smpRcvFileConnId rfs - deleteAgentConnectionsAsync user smpSFConnIds - deleteAgentConnectionsAsync user smpRFConnIds - where - fileEnded CIFileInfo {fileStatus} = case fileStatus of - Just (AFS _ status) -> ciFileEnded status - Nothing -> True - getFT :: DB.Connection -> CIFileInfo -> IO (Either ChatError FileTransfer) - getFT db CIFileInfo {fileId} = runExceptT . withExceptT ChatErrorStore $ getFileTransfer db user fileId - updateSndFileCancelled :: DB.Connection -> (FileTransferMeta, [SndFileTransfer]) -> IO () - updateSndFileCancelled db (FileTransferMeta {fileId}, sfts) = do - updateFileCancelled db user fileId CIFSSndCancelled - forM_ sfts updateSndFTCancelled - where - updateSndFTCancelled :: SndFileTransfer -> IO () - updateSndFTCancelled ft = unless (sndFTEnded ft) $ do - updateSndFileStatus db ft FSCancelled - deleteSndFileChunks db ft - updateRcvFileCancelled :: DB.Connection -> RcvFileTransfer -> IO () - updateRcvFileCancelled db ft@RcvFileTransfer {fileId} = do - updateFileCancelled db user fileId CIFSRcvCancelled - updateRcvFileStatus db fileId FSCancelled - deleteRcvFileChunks db ft - splitFTTypes :: [Either ChatError FileTransfer] -> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer]) - splitFTTypes = foldr addFT ([], []) . rights - where - addFT f (sfs, rfs) = case f of - FTSnd ft@FileTransferMeta {cancelled} sfts | not cancelled -> ((ft, sfts) : sfs, rfs) - FTRcv ft@RcvFileTransfer {cancelled} | not cancelled -> (sfs, ft : rfs) - _ -> (sfs, rfs) - smpSndFileConnId :: FileTransferMeta -> SndFileTransfer -> Maybe ConnId - smpSndFileConnId FileTransferMeta {xftpSndFile} sft@SndFileTransfer {agentConnId = AgentConnId acId, fileInline} - | isNothing xftpSndFile && isNothing fileInline && not (sndFTEnded sft) = Just acId - | otherwise = Nothing - smpRcvFileConnId :: RcvFileTransfer -> Maybe ConnId - smpRcvFileConnId ft@RcvFileTransfer {xftpRcvFile, rcvFileInline} - | isNothing xftpRcvFile && isNothing rcvFileInline = liveRcvFileTransferConnId ft - | otherwise = Nothing - sndFTEnded SndFileTransfer {fileStatus} = fileStatus == FSCancelled || fileStatus == FSComplete - -deleteFilesLocally :: [CIFileInfo] -> CM () -deleteFilesLocally files = - withFilesFolder $ \filesFolder -> - liftIO . forM_ files $ \CIFileInfo {filePath} -> - mapM_ (delete . (filesFolder )) filePath - where - delete :: FilePath -> IO () - delete fPath = - removeFile fPath `catchAll` \_ -> - removePathForcibly fPath `catchAll_` pure () - -- perform an action only if filesFolder is set (i.e. on mobile devices) - withFilesFolder :: (FilePath -> CM ()) -> CM () - withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action - -updateCallItemStatus :: User -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> CM () -updateCallItemStatus user ct@Contact {contactId} Call {chatItemId} receivedStatus msgId_ = do - aciContent_ <- callStatusItemContent user ct chatItemId receivedStatus - forM_ aciContent_ $ \aciContent -> do - timed_ <- callTimed ct aciContent - updateDirectChatItemView user ct chatItemId aciContent False False timed_ msgId_ - forM_ (timed_ >>= timedDeleteAt') $ - startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId) - -callTimed :: Contact -> ACIContent -> CM (Maybe CITimed) -callTimed ct aciContent = - case aciContentCallStatus aciContent of - Just callStatus - | callComplete callStatus -> do - contactCITimed ct - _ -> pure Nothing - where - aciContentCallStatus :: ACIContent -> Maybe CICallStatus - aciContentCallStatus (ACIContent _ (CISndCall st _)) = Just st - aciContentCallStatus (ACIContent _ (CIRcvCall st _)) = Just st - aciContentCallStatus _ = Nothing - -updateDirectChatItemView :: User -> Contact -> ChatItemId -> ACIContent -> Bool -> Bool -> Maybe CITimed -> Maybe MessageId -> CM () -updateDirectChatItemView user ct chatItemId (ACIContent msgDir ciContent) edited live timed_ msgId_ = do - ci' <- withStore $ \db -> updateDirectChatItem db user ct chatItemId ciContent edited live timed_ msgId_ - toView $ CRChatItemUpdated user (AChatItem SCTDirect msgDir (DirectChat ct) ci') - -callStatusItemContent :: User -> Contact -> ChatItemId -> WebRTCCallStatus -> CM (Maybe ACIContent) -callStatusItemContent user Contact {contactId} chatItemId receivedStatus = do - CChatItem msgDir ChatItem {meta = CIMeta {updatedAt}, content} <- - withStore $ \db -> getDirectChatItem db user contactId chatItemId - ts <- liftIO getCurrentTime - let callDuration :: Int = nominalDiffTimeToSeconds (ts `diffUTCTime` updatedAt) `div'` 1 - callStatus = case content of - CISndCall st _ -> Just st - CIRcvCall st _ -> Just st - _ -> Nothing - newState_ = case (callStatus, receivedStatus) of - (Just CISCallProgress, WCSConnected) -> Nothing -- if call in-progress received connected -> no change - (Just CISCallProgress, WCSDisconnected) -> Just (CISCallEnded, callDuration) -- calculate in-progress duration - (Just CISCallProgress, WCSFailed) -> Just (CISCallEnded, callDuration) -- whether call disconnected or failed - (Just CISCallPending, WCSDisconnected) -> Just (CISCallMissed, 0) - (Just CISCallEnded, _) -> Nothing -- if call already ended or failed -> no change - (Just CISCallError, _) -> Nothing - (Just _, WCSConnecting) -> Just (CISCallNegotiated, 0) - (Just _, WCSConnected) -> Just (CISCallProgress, 0) -- if call ended that was never connected, duration = 0 - (Just _, WCSDisconnected) -> Just (CISCallEnded, 0) - (Just _, WCSFailed) -> Just (CISCallError, 0) - (Nothing, _) -> Nothing -- some other content - we should never get here, but no exception is thrown - pure $ aciContent msgDir <$> newState_ - where - aciContent :: forall d. SMsgDirection d -> (CICallStatus, Int) -> ACIContent - aciContent msgDir (callStatus', duration) = case msgDir of - SMDSnd -> ACIContent SMDSnd $ CISndCall callStatus' duration - SMDRcv -> ACIContent SMDRcv $ CIRcvCall callStatus' duration - --- mobile clients use file paths relative to app directory (e.g. for the reason ios app directory changes on updates), --- so we have to differentiate between the file path stored in db and communicated with frontend, and the file path --- used during file transfer for actual operations with file system -toFSFilePath :: FilePath -> CM' FilePath -toFSFilePath f = - maybe f ( f) <$> (chatReadVar' filesFolder) - -setFileToEncrypt :: RcvFileTransfer -> CM RcvFileTransfer -setFileToEncrypt ft@RcvFileTransfer {fileId} = do - cfArgs <- atomically . CF.randomArgs =<< asks random - withStore' $ \db -> setFileCryptoArgs db fileId cfArgs - pure (ft :: RcvFileTransfer) {cryptoArgs = Just cfArgs} - -receiveFile' :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM ChatResponse -receiveFile' user ft userApprovedRelays rcvInline_ filePath_ = do - (CRRcvFileAccepted user <$> acceptFileReceive user ft userApprovedRelays rcvInline_ filePath_) `catchChatError` processError - where - processError = \case - -- TODO AChatItem in Cancelled events - ChatErrorAgent (SMP _ SMP.AUTH) _ -> pure $ CRRcvFileAcceptedSndCancelled user ft - ChatErrorAgent (CONN DUPLICATE) _ -> pure $ CRRcvFileAcceptedSndCancelled user ft - e -> throwError e - -acceptFileReceive :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM AChatItem -acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId, cryptoArgs} userApprovedRelays rcvInline_ filePath_ = do - unless (fileStatus == RFSNew) $ case fileStatus of - RFSCancelled _ -> throwChatError $ CEFileCancelled fName - _ -> throwChatError $ CEFileAlreadyReceiving fName - vr <- chatVersionRange - case (xftpRcvFile, fileConnReq) of - -- direct file protocol - (Nothing, Just connReq) -> do - subMode <- chatReadVar subscriptionMode - dm <- encodeConnInfo $ XFileAcpt fName - connIds <- joinAgentConnectionAsync user True connReq dm subMode - filePath <- getRcvFilePath fileId filePath_ fName True - withStore $ \db -> acceptRcvFileTransfer db vr user fileId connIds ConnJoined filePath subMode - -- XFTP - (Just XFTPRcvFile {userApprovedRelays = approvedBeforeReady}, _) -> do - let userApproved = approvedBeforeReady || userApprovedRelays - filePath <- getRcvFilePath fileId filePath_ fName False - (ci, rfd) <- withStore $ \db -> do - -- marking file as accepted and reading description in the same transaction - -- to prevent race condition with appending description - ci <- xftpAcceptRcvFT db vr user fileId filePath userApproved - rfd <- getRcvFileDescrByRcvFileId db fileId - pure (ci, rfd) - receiveViaCompleteFD user fileId rfd userApproved cryptoArgs - pure ci - -- group & direct file protocol - _ -> do - chatRef <- withStore $ \db -> getChatRefByFileId db user fileId - case (chatRef, grpMemberId) of - (ChatRef CTDirect contactId, Nothing) -> do - ct <- withStore $ \db -> getContact db vr user contactId - acceptFile CFCreateConnFileInvDirect $ \msg -> void $ sendDirectContactMessage user ct msg - (ChatRef CTGroup groupId, Just memId) -> do - GroupMember {activeConn} <- withStore $ \db -> getGroupMember db vr user groupId memId - case activeConn of - Just conn -> do - acceptFile CFCreateConnFileInvGroup $ \msg -> void $ sendDirectMemberMessage conn msg groupId - _ -> throwChatError $ CEFileInternal "member connection not active" - _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" - where - acceptFile :: CommandFunction -> (ChatMsgEvent 'Json -> CM ()) -> CM AChatItem - acceptFile cmdFunction send = do - filePath <- getRcvFilePath fileId filePath_ fName True - inline <- receiveInline - vr <- chatVersionRange - if - | inline -> do - -- accepting inline - ci <- withStore $ \db -> acceptRcvInlineFT db vr user fileId filePath - sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId - send $ XFileAcptInv sharedMsgId Nothing fName - pure ci - | fileInline == Just IFMSent -> throwChatError $ CEFileAlreadyReceiving fName - | otherwise -> do - -- accepting via a new connection - subMode <- chatReadVar subscriptionMode - connIds <- createAgentConnectionAsync user cmdFunction True SCMInvitation subMode - withStore $ \db -> acceptRcvFileTransfer db vr user fileId connIds ConnNew filePath subMode - receiveInline :: CM Bool - receiveInline = do - ChatConfig {fileChunkSize, inlineFiles = InlineFilesConfig {receiveChunks, offerChunks}} <- asks config - pure $ - rcvInline_ /= Just False - && fileInline == Just IFMOffer - && ( fileSize <= fileChunkSize * receiveChunks - || (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks) - ) - -receiveViaCompleteFD :: User -> FileTransferId -> RcvFileDescr -> Bool -> Maybe CryptoFileArgs -> CM () -receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} userApprovedRelays cfArgs = - when fileDescrComplete $ do - rd <- parseFileDescription fileDescrText - if userApprovedRelays - then receive' rd True - else do - let srvs = fileServers rd - unknownSrvs <- getUnknownSrvs srvs - let approved = null unknownSrvs - ifM - ((approved ||) <$> ipProtectedForSrvs srvs) - (receive' rd approved) - (relaysNotApproved unknownSrvs) - where - receive' :: ValidFileDescription 'FRecipient -> Bool -> CM () - receive' rd approved = do - aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd cfArgs approved - startReceivingFile user fileId - withStore' $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId) - fileServers :: ValidFileDescription 'FRecipient -> [XFTPServer] - fileServers (FD.ValidFileDescription FD.FileDescription {chunks}) = - S.toList $ S.fromList $ concatMap (\FD.FileChunk {replicas} -> map (\FD.FileChunkReplica {server} -> server) replicas) chunks - getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer] - getUnknownSrvs srvs = do - knownSrvs <- L.map protoServer' <$> getKnownAgentServers SPXFTP user - pure $ filter (`notElem` knownSrvs) srvs - ipProtectedForSrvs :: [XFTPServer] -> CM Bool - ipProtectedForSrvs srvs = do - netCfg <- lift getNetworkConfig - pure $ all (ipAddressProtected netCfg) srvs - relaysNotApproved :: [XFTPServer] -> CM () - relaysNotApproved unknownSrvs = do - aci_ <- resetRcvCIFileStatus user fileId CIFSRcvInvitation - forM_ aci_ $ \aci -> do - cleanupACIFile aci - toView $ CRChatItemUpdated user aci - throwChatError $ CEFileNotApproved fileId unknownSrvs - -getKnownAgentServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> User -> CM (NonEmpty (ServerCfg p)) -getKnownAgentServers p user = do - as <- asks randomAgentServers - withStore $ \db -> do - opDomains <- operatorDomains . serverOperators <$> getServerOperators db - srvs <- liftIO $ getProtocolServers db p user - pure $ useServerCfgs p as opDomains srvs - -protoServer' :: ServerCfg p -> ProtocolServer p -protoServer' ServerCfg {server} = protoServer server - -getNetworkConfig :: CM' NetworkConfig -getNetworkConfig = withAgent' $ liftIO . getFastNetworkConfig - -resetRcvCIFileStatus :: User -> FileTransferId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem) -resetRcvCIFileStatus user fileId ciFileStatus = do - vr <- chatVersionRange - withStore $ \db -> do - liftIO $ do - updateCIFileStatus db user fileId ciFileStatus - updateRcvFileStatus db fileId FSNew - updateRcvFileAgentId db fileId Nothing - lookupChatItemByFileId db vr user fileId - -receiveViaURI :: User -> FileDescriptionURI -> CryptoFile -> CM RcvFileTransfer -receiveViaURI user@User {userId} FileDescriptionURI {description} cf@CryptoFile {cryptoArgs} = do - fileId <- withStore $ \db -> createRcvStandaloneFileTransfer db userId cf fileSize chunkSize - -- currently the only use case is user migrating via their configured servers, so we pass approvedRelays = True - aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) description cryptoArgs True - withStore $ \db -> do - liftIO $ do - updateRcvFileStatus db fileId FSConnected - updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1 - updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId) - getRcvFileTransfer db user fileId - where - FD.ValidFileDescription FD.FileDescription {size = FD.FileSize fileSize, chunkSize = FD.FileSize chunkSize} = description - -startReceivingFile :: User -> FileTransferId -> CM () -startReceivingFile user fileId = do - vr <- chatVersionRange - ci <- withStore $ \db -> do - liftIO $ updateRcvFileStatus db fileId FSConnected - liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1 - getChatItemByFileId db vr user fileId - toView $ CRRcvFileStart user ci - -getRcvFilePath :: FileTransferId -> Maybe FilePath -> String -> Bool -> CM FilePath -getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of - Nothing -> - chatReadVar filesFolder >>= \case - Nothing -> do - defaultFolder <- lift getDefaultFilesFolder - fPath <- liftIO $ defaultFolder `uniqueCombine` fn - createEmptyFile fPath $> fPath - Just filesFolder -> do - fPath <- liftIO $ filesFolder `uniqueCombine` fn - createEmptyFile fPath - pure $ takeFileName fPath - Just fPath -> - ifM - (doesDirectoryExist fPath) - (createInPassedDirectory fPath) - $ ifM - (doesFileExist fPath) - (throwChatError $ CEFileAlreadyExists fPath) - (createEmptyFile fPath $> fPath) - where - createInPassedDirectory :: FilePath -> CM FilePath - createInPassedDirectory fPathDir = do - fPath <- liftIO $ fPathDir `uniqueCombine` fn - createEmptyFile fPath $> fPath - createEmptyFile :: FilePath -> CM () - createEmptyFile fPath = emptyFile `catchThrow` (ChatError . CEFileWrite fPath . show) - where - emptyFile :: CM () - emptyFile - | keepHandle = do - h <- getFileHandle fileId fPath rcvFiles AppendMode - liftIO $ B.hPut h "" >> hFlush h - | otherwise = liftIO $ B.writeFile fPath "" - -acceptContactRequest :: User -> UserContactRequest -> IncognitoEnabled -> CM (Contact, Connection, SndQueueSecured) -acceptContactRequest user@User {userId} UserContactRequest {agentInvitationId = AgentInvId invId, contactId_, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId, xContactId, pqSupport} incognito = do - subMode <- chatReadVar subscriptionMode - let pqSup = PQSupportOn - pqSup' = pqSup `CR.pqSupportAnd` pqSupport - vr <- chatVersionRange - let chatV = vr `peerConnChatVersion` cReqChatVRange - (ct, conn, incognitoProfile) <- case contactId_ of - Nothing -> do - incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing - connId <- withAgent $ \a -> prepareConnectionToAccept a True invId pqSup' - (ct, conn) <- withStore' $ \db -> createAcceptedContact db user connId chatV cReqChatVRange cName profileId cp userContactLinkId xContactId incognitoProfile subMode pqSup' False - pure (ct, conn, incognitoProfile) - Just contactId -> do - ct <- withFastStore $ \db -> getContact db vr user contactId - case contactConn ct of - Nothing -> throwChatError $ CECommandError "contact has no connection" - Just conn@Connection {customUserProfileId} -> do - incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId - pure (ct, conn, ExistingIncognito <$> incognitoProfile) - let profileToSend = profileToSendOnAccept user incognitoProfile False - dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend - (ct,conn,) <$> withAgent (\a -> acceptContact a (aConnId conn) True invId dm pqSup' subMode) - -acceptContactRequestAsync :: User -> UserContactRequest -> Maybe IncognitoProfile -> Bool -> PQSupport -> CM Contact -acceptContactRequestAsync user cReq@UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} incognitoProfile contactUsed pqSup = do - subMode <- chatReadVar subscriptionMode - let profileToSend = profileToSendOnAccept user incognitoProfile False - vr <- chatVersionRange - let chatV = vr `peerConnChatVersion` cReqChatVRange - (cmdId, acId) <- agentAcceptContactAsync user True invId (XInfo profileToSend) subMode pqSup chatV - withStore' $ \db -> do - (ct, Connection {connId}) <- createAcceptedContact db user acId chatV cReqChatVRange cName profileId p userContactLinkId xContactId incognitoProfile subMode pqSup contactUsed - deleteContactRequestRec db user cReq - setCommandConnId db user cmdId connId - pure ct - -acceptGroupJoinRequestAsync :: User -> GroupInfo -> UserContactRequest -> GroupMemberRole -> Maybe IncognitoProfile -> CM GroupMember -acceptGroupJoinRequestAsync - user - gInfo@GroupInfo {groupProfile, membership, businessChat} - ucr@UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange} - gLinkMemRole - incognitoProfile = do - gVar <- asks random - (groupMemberId, memberId) <- withStore $ \db -> do - liftIO $ deleteContactRequestRec db user ucr - createAcceptedMember db gVar user gInfo ucr gLinkMemRole - currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo - let Profile {displayName} = profileToSendOnAccept user incognitoProfile True - GroupMember {memberRole = userRole, memberId = userMemberId} = membership - msg = - XGrpLinkInv $ - GroupLinkInvitation - { fromMember = MemberIdRole userMemberId userRole, - fromMemberName = displayName, - invitedMember = MemberIdRole memberId gLinkMemRole, - groupProfile, - business = businessChat, - groupSize = Just currentMemCount - } - subMode <- chatReadVar subscriptionMode - vr <- chatVersionRange - let chatV = vr `peerConnChatVersion` cReqChatVRange - connIds <- agentAcceptContactAsync user True invId msg subMode PQSupportOff chatV - withStore $ \db -> do - liftIO $ createAcceptedMemberConnection db user connIds chatV ucr groupMemberId subMode - getGroupMemberById db vr user groupMemberId - -acceptBusinessJoinRequestAsync :: User -> UserContactRequest -> CM GroupInfo -acceptBusinessJoinRequestAsync - user - ucr@UserContactRequest {contactRequestId, agentInvitationId = AgentInvId invId, cReqChatVRange} = do - vr <- chatVersionRange - gVar <- asks random - let userProfile@Profile {displayName, preferences} = profileToSendOnAccept user Nothing True - groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs preferences - (gInfo, clientMember) <- withStore $ \db -> do - liftIO $ deleteContactRequest db user contactRequestId - createBusinessRequestGroup db vr gVar user ucr groupPreferences - let GroupInfo {membership} = gInfo - GroupMember {memberRole = userRole, memberId = userMemberId} = membership - GroupMember {groupMemberId, memberId} = clientMember - msg = - XGrpLinkInv $ - GroupLinkInvitation - { fromMember = MemberIdRole userMemberId userRole, - fromMemberName = displayName, - invitedMember = MemberIdRole memberId GRMember, - groupProfile = businessGroupProfile userProfile groupPreferences, - -- This refers to the "title member" that defines the group name and profile. - -- This coincides with fromMember to be current user when accepting the connecting user, - -- but it will be different when inviting somebody else. - business = Just $ BusinessChatInfo {chatType = BCBusiness, businessId = userMemberId, customerId = memberId}, - groupSize = Just 1 - } - subMode <- chatReadVar subscriptionMode - let chatV = vr `peerConnChatVersion` cReqChatVRange - connIds <- agentAcceptContactAsync user True invId msg subMode PQSupportOff chatV - withStore' $ \db -> createAcceptedMemberConnection db user connIds chatV ucr groupMemberId subMode - let cd = CDGroupSnd gInfo - createInternalChatItem user cd (CISndGroupE2EEInfo E2EInfo {pqEnabled = PQEncOff}) Nothing - createGroupFeatureItems user cd CISndGroupFeature gInfo - pure gInfo - where - businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile - businessGroupProfile Profile {displayName, fullName, image} groupPreferences = - GroupProfile {displayName, fullName, description = Nothing, image, groupPreferences = Just groupPreferences} - -profileToSendOnAccept :: User -> Maybe IncognitoProfile -> Bool -> Profile -profileToSendOnAccept user ip = userProfileToSend user (getIncognitoProfile <$> ip) Nothing - where - getIncognitoProfile = \case - NewIncognito p -> p - ExistingIncognito lp -> fromLocalProfile lp - -deleteGroupLink' :: User -> GroupInfo -> CM () -deleteGroupLink' user gInfo = do - vr <- chatVersionRange - conn <- withStore $ \db -> getGroupLinkConnection db vr user gInfo - deleteGroupLink_ user gInfo conn - -deleteGroupLinkIfExists :: User -> GroupInfo -> CM () -deleteGroupLinkIfExists user gInfo = do - vr <- chatVersionRange - conn_ <- eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupLinkConnection db vr user gInfo) - mapM_ (deleteGroupLink_ user gInfo) conn_ - -deleteGroupLink_ :: User -> GroupInfo -> Connection -> CM () -deleteGroupLink_ user gInfo conn = do - deleteAgentConnectionAsync user $ aConnId conn - withStore' $ \db -> deleteGroupLink db user gInfo - -agentSubscriber :: CM' () -agentSubscriber = do - q <- asks $ subQ . smpAgent - forever (atomically (readTBQueue q) >>= process) - `E.catchAny` \e -> do - toView' $ CRChatError Nothing $ ChatErrorAgent (CRITICAL True $ "Message reception stopped: " <> show e) Nothing - E.throwIO e - where - process :: (ACorrId, AEntityId, AEvt) -> CM' () - process (corrId, entId, AEvt e msg) = run $ case e of - SAENone -> processAgentMessageNoConn msg - SAEConn -> processAgentMessage corrId entId msg - SAERcvFile -> processAgentMsgRcvFile corrId entId msg - SAESndFile -> processAgentMsgSndFile corrId entId msg - where - run action = action `catchChatError'` (toView' . CRChatError Nothing) - -type AgentBatchSubscribe = AgentClient -> [ConnId] -> ExceptT AgentErrorType IO (Map ConnId (Either AgentErrorType ())) - -subscribeUserConnections :: VersionRangeChat -> Bool -> AgentBatchSubscribe -> User -> CM () -subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do - -- get user connections - ce <- asks $ subscriptionEvents . config - (conns, cts, ucs, gs, ms, sfts, rfts, pcs) <- - if onlyNeeded - then do - (conns, entities) <- withStore' (`getConnectionsToSubscribe` vr) - let (cts, ucs, ms, sfts, rfts, pcs) = foldl' addEntity (M.empty, M.empty, M.empty, M.empty, M.empty, M.empty) entities - pure (conns, cts, ucs, [], ms, sfts, rfts, pcs) - else do - withStore' unsetConnectionToSubscribe - (ctConns, cts) <- getContactConns - (ucConns, ucs) <- getUserContactLinkConns - (gs, mConns, ms) <- getGroupMemberConns - (sftConns, sfts) <- getSndFileTransferConns - (rftConns, rfts) <- getRcvFileTransferConns - (pcConns, pcs) <- getPendingContactConns - let conns = concat ([ctConns, ucConns, mConns, sftConns, rftConns, pcConns] :: [[ConnId]]) - pure (conns, cts, ucs, gs, ms, sfts, rfts, pcs) - -- subscribe using batched commands - rs <- withAgent $ \a -> agentBatchSubscribe a conns - -- send connection events to view - contactSubsToView rs cts ce - -- TODO possibly, we could either disable these events or replace with less noisy for API - contactLinkSubsToView rs ucs - groupSubsToView rs gs ms ce - sndFileSubsToView rs sfts - rcvFileSubsToView rs rfts - pendingConnSubsToView rs pcs - where - addEntity (cts, ucs, ms, sfts, rfts, pcs) = \case - RcvDirectMsgConnection c (Just ct) -> let cts' = addConn c ct cts in (cts', ucs, ms, sfts, rfts, pcs) - RcvDirectMsgConnection c Nothing -> let pcs' = addConn c (toPCC c) pcs in (cts, ucs, ms, sfts, rfts, pcs') - RcvGroupMsgConnection c _g m -> let ms' = addConn c m ms in (cts, ucs, ms', sfts, rfts, pcs) - SndFileConnection c sft -> let sfts' = addConn c sft sfts in (cts, ucs, ms, sfts', rfts, pcs) - RcvFileConnection c rft -> let rfts' = addConn c rft rfts in (cts, ucs, ms, sfts, rfts', pcs) - UserContactConnection c uc -> let ucs' = addConn c uc ucs in (cts, ucs', ms, sfts, rfts, pcs) - addConn :: Connection -> a -> Map ConnId a -> Map ConnId a - addConn = M.insert . aConnId - toPCC Connection {connId, agentConnId, connStatus, viaUserContactLink, groupLinkId, customUserProfileId, localAlias, createdAt} = - PendingContactConnection - { pccConnId = connId, - pccAgentConnId = agentConnId, - pccConnStatus = connStatus, - viaContactUri = False, - viaUserContactLink, - groupLinkId, - customUserProfileId, - connReqInv = Nothing, - localAlias, - createdAt, - updatedAt = createdAt - } - getContactConns :: CM ([ConnId], Map ConnId Contact) - getContactConns = do - cts <- withStore_ (`getUserContacts` vr) - let cts' = mapMaybe (\ct -> (,ct) <$> contactConnId ct) $ filter contactActive cts - pure (map fst cts', M.fromList cts') - getUserContactLinkConns :: CM ([ConnId], Map ConnId UserContact) - getUserContactLinkConns = do - (cs, ucs) <- unzip <$> withStore_ (`getUserContactLinks` vr) - let connIds = map aConnId cs - pure (connIds, M.fromList $ zip connIds ucs) - getGroupMemberConns :: CM ([Group], [ConnId], Map ConnId GroupMember) - getGroupMemberConns = do - gs <- withStore_ (`getUserGroups` vr) - let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) (filter (not . memberRemoved) ms)) gs - pure (gs, map fst mPairs, M.fromList mPairs) - getSndFileTransferConns :: CM ([ConnId], Map ConnId SndFileTransfer) - getSndFileTransferConns = do - sfts <- withStore_ getLiveSndFileTransfers - let connIds = map sndFileTransferConnId sfts - pure (connIds, M.fromList $ zip connIds sfts) - getRcvFileTransferConns :: CM ([ConnId], Map ConnId RcvFileTransfer) - getRcvFileTransferConns = do - rfts <- withStore_ getLiveRcvFileTransfers - let rftPairs = mapMaybe (\ft -> (,ft) <$> liveRcvFileTransferConnId ft) rfts - pure (map fst rftPairs, M.fromList rftPairs) - getPendingContactConns :: CM ([ConnId], Map ConnId PendingContactConnection) - getPendingContactConns = do - pcs <- withStore_ getPendingContactConnections - let connIds = map aConnId' pcs - pure (connIds, M.fromList $ zip connIds pcs) - contactSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId Contact -> Bool -> CM () - contactSubsToView rs cts ce = do - chatModifyVar connNetworkStatuses $ M.union (M.fromList statuses) - ifM (asks $ coreApi . config) (notifyAPI statuses) notifyCLI - where - notifyCLI = do - let cRs = resultsFor rs cts - cErrors = sortOn (\(Contact {localDisplayName = n}, _) -> n) $ filterErrors cRs - toView . CRContactSubSummary user $ map (uncurry ContactSubStatus) cRs - when ce $ mapM_ (toView . uncurry (CRContactSubError user)) cErrors - notifyAPI = toView . CRNetworkStatuses (Just user) . map (uncurry ConnNetworkStatus) - statuses = M.foldrWithKey' addStatus [] cts - where - addStatus :: ConnId -> Contact -> [(AgentConnId, NetworkStatus)] -> [(AgentConnId, NetworkStatus)] - addStatus _ Contact {activeConn = Nothing} nss = nss - addStatus connId Contact {activeConn = Just Connection {agentConnId}} nss = - let ns = (agentConnId, netStatus $ resultErr connId rs) - in ns : nss - netStatus :: Maybe ChatError -> NetworkStatus - netStatus = maybe NSConnected $ NSError . errorNetworkStatus - errorNetworkStatus :: ChatError -> String - errorNetworkStatus = \case - ChatErrorAgent (BROKER _ NETWORK) _ -> "network" - ChatErrorAgent (SMP _ SMP.AUTH) _ -> "contact deleted" - e -> show e - -- TODO possibly below could be replaced with less noisy events for API - contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> CM () - contactLinkSubsToView rs = toView . CRUserContactSubSummary user . map (uncurry UserContactSubStatus) . resultsFor rs - groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> CM () - groupSubsToView rs gs ms ce = do - mapM_ groupSub $ - sortOn (\(Group GroupInfo {localDisplayName = g} _) -> g) gs - toView . CRMemberSubSummary user $ map (uncurry MemberSubStatus) mRs - where - mRs = resultsFor rs ms - groupSub :: Group -> CM () - groupSub (Group g@GroupInfo {membership, groupId = gId} members) = do - when ce $ mapM_ (toView . uncurry (CRMemberSubError user g)) mErrors - toView groupEvent - where - mErrors :: [(GroupMember, ChatError)] - mErrors = - sortOn (\(GroupMember {localDisplayName = n}, _) -> n) - . filterErrors - $ filter (\(GroupMember {groupId}, _) -> groupId == gId) mRs - groupEvent :: ChatResponse - groupEvent - | memberStatus membership == GSMemInvited = CRGroupInvitation user g - | all (\GroupMember {activeConn} -> isNothing activeConn) members = - if memberActive membership - then CRGroupEmpty user g - else CRGroupRemoved user g - | otherwise = CRGroupSubscribed user g - sndFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId SndFileTransfer -> CM () - sndFileSubsToView rs sfts = do - let sftRs = resultsFor rs sfts - forM_ sftRs $ \(ft@SndFileTransfer {fileId, fileStatus}, err_) -> do - forM_ err_ $ toView . CRSndFileSubError user ft - void . forkIO $ do - threadDelay 1000000 - when (fileStatus == FSConnected) . unlessM (isFileActive fileId sndFiles) . withChatLock "subscribe sendFileChunk" $ - sendFileChunk user ft - rcvFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId RcvFileTransfer -> CM () - rcvFileSubsToView rs = mapM_ (toView . uncurry (CRRcvFileSubError user)) . filterErrors . resultsFor rs - pendingConnSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId PendingContactConnection -> CM () - pendingConnSubsToView rs = toView . CRPendingSubSummary user . map (uncurry PendingSubStatus) . resultsFor rs - withStore_ :: (DB.Connection -> User -> IO [a]) -> CM [a] - withStore_ a = withStore' (`a` user) `catchChatError` \e -> toView (CRChatError (Just user) e) $> [] - filterErrors :: [(a, Maybe ChatError)] -> [(a, ChatError)] - filterErrors = mapMaybe (\(a, e_) -> (a,) <$> e_) - resultsFor :: Map ConnId (Either AgentErrorType ()) -> Map ConnId a -> [(a, Maybe ChatError)] - resultsFor rs = M.foldrWithKey' addResult [] - where - addResult :: ConnId -> a -> [(a, Maybe ChatError)] -> [(a, Maybe ChatError)] - addResult connId = (:) . (,resultErr connId rs) - resultErr :: ConnId -> Map ConnId (Either AgentErrorType ()) -> Maybe ChatError - resultErr connId rs = case M.lookup connId rs of - Just (Left e) -> Just $ ChatErrorAgent e Nothing - Just _ -> Nothing - _ -> Just . ChatError . CEAgentNoSubResult $ AgentConnId connId - -cleanupManager :: CM () -cleanupManager = do - interval <- asks (cleanupManagerInterval . config) - runWithoutInitialDelay interval - initialDelay <- asks (initialCleanupManagerDelay . config) - liftIO $ threadDelay' initialDelay - stepDelay <- asks (cleanupManagerStepDelay . config) - forever $ do - flip catchChatError (toView . CRChatError Nothing) $ do - lift waitChatStartedAndActivated - users <- withStore' getUsers - let (us, us') = partition activeUser users - forM_ us $ cleanupUser interval stepDelay - forM_ us' $ cleanupUser interval stepDelay - cleanupMessages `catchChatError` (toView . CRChatError Nothing) - -- TODO possibly, also cleanup async commands - cleanupProbes `catchChatError` (toView . CRChatError Nothing) - liftIO $ threadDelay' $ diffToMicroseconds interval - where - runWithoutInitialDelay cleanupInterval = flip catchChatError (toView . CRChatError Nothing) $ do - lift waitChatStartedAndActivated - users <- withStore' getUsers - let (us, us') = partition activeUser users - forM_ us $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` (toView . CRChatError (Just u)) - forM_ us' $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` (toView . CRChatError (Just u)) - cleanupUser cleanupInterval stepDelay user = do - cleanupTimedItems cleanupInterval user `catchChatError` (toView . CRChatError (Just user)) - liftIO $ threadDelay' stepDelay - cleanupDeletedContacts user `catchChatError` (toView . CRChatError (Just user)) - liftIO $ threadDelay' stepDelay - cleanupTimedItems cleanupInterval user = do - ts <- liftIO getCurrentTime - let startTimedThreadCutoff = addUTCTime cleanupInterval ts - timedItems <- withStore' $ \db -> getTimedItems db user startTimedThreadCutoff - forM_ timedItems $ \(itemRef, deleteAt) -> startTimedItemThread user itemRef deleteAt `catchChatError` const (pure ()) - cleanupDeletedContacts user = do - vr <- chatVersionRange - contacts <- withStore' $ \db -> getDeletedContacts db vr user - forM_ contacts $ \ct -> - withStore (\db -> deleteContactWithoutGroups db user ct) - `catchChatError` (toView . CRChatError (Just user)) - cleanupMessages = do - ts <- liftIO getCurrentTime - let cutoffTs = addUTCTime (-(30 * nominalDay)) ts - withStore' (`deleteOldMessages` cutoffTs) - cleanupProbes = do - ts <- liftIO getCurrentTime - let cutoffTs = addUTCTime (-(14 * nominalDay)) ts - withStore' (`deleteOldProbes` cutoffTs) - -startProximateTimedItemThread :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM () -startProximateTimedItemThread user itemRef deleteAt = do - interval <- asks (cleanupManagerInterval . config) - ts <- liftIO getCurrentTime - when (diffUTCTime deleteAt ts <= interval) $ - startTimedItemThread user itemRef deleteAt - -startTimedItemThread :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM () -startTimedItemThread user itemRef deleteAt = do - itemThreads <- asks timedItemThreads - threadTVar_ <- atomically $ do - exists <- TM.member itemRef itemThreads - if not exists - then do - threadTVar <- newTVar Nothing - TM.insert itemRef threadTVar itemThreads - pure $ Just threadTVar - else pure Nothing - forM_ threadTVar_ $ \threadTVar -> do - tId <- mkWeakThreadId =<< deleteTimedItem user itemRef deleteAt `forkFinally` const (atomically $ TM.delete itemRef itemThreads) - atomically $ writeTVar threadTVar (Just tId) - -deleteTimedItem :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM () -deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do - ts <- liftIO getCurrentTime - liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts - lift waitChatStartedAndActivated - vr <- chatVersionRange - case cType of - CTDirect -> do - (ct, ci) <- withStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId - deleteDirectCIs user ct [ci] True True >>= toView - CTGroup -> do - (gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId - deletedTs <- liftIO getCurrentTime - deleteGroupCIs user gInfo [ci] True True Nothing deletedTs >>= toView - _ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType" - -startUpdatedTimedItemThread :: User -> ChatRef -> ChatItem c d -> ChatItem c d -> CM () -startUpdatedTimedItemThread user chatRef ci ci' = - case (chatItemTimed ci >>= timedDeleteAt', chatItemTimed ci' >>= timedDeleteAt') of - (Nothing, Just deleteAt') -> - startProximateTimedItemThread user (chatRef, chatItemId' ci') deleteAt' - _ -> pure () - -expireChatItems :: User -> Int64 -> Bool -> CM () -expireChatItems user@User {userId} ttl sync = do - currentTs <- liftIO getCurrentTime - vr <- chatVersionRange - let expirationDate = addUTCTime (-1 * fromIntegral ttl) currentTs - -- this is to keep group messages created during last 12 hours even if they're expired according to item_ts - createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs - lift waitChatStartedAndActivated - contacts <- withStore' $ \db -> getUserContacts db vr user - loop contacts $ processContact expirationDate - lift waitChatStartedAndActivated - groups <- withStore' $ \db -> getUserGroupDetails db vr user Nothing Nothing - loop groups $ processGroup vr expirationDate createdAtCutoff - where - loop :: [a] -> (a -> CM ()) -> CM () - loop [] _ = pure () - loop (a : as) process = continue $ do - process a `catchChatError` (toView . CRChatError (Just user)) - loop as process - continue :: CM () -> CM () - continue a = - if sync - then a - else do - expireFlags <- asks expireCIFlags - expire <- atomically $ TM.lookup userId expireFlags - when (expire == Just True) $ threadDelay 100000 >> a - processContact :: UTCTime -> Contact -> CM () - processContact expirationDate ct = do - lift waitChatStartedAndActivated - filesInfo <- withStore' $ \db -> getContactExpiredFileInfo db user ct expirationDate - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo - withStore' $ \db -> deleteContactExpiredCIs db user ct expirationDate - processGroup :: VersionRangeChat -> UTCTime -> UTCTime -> GroupInfo -> CM () - processGroup vr expirationDate createdAtCutoff gInfo = do - lift waitChatStartedAndActivated - filesInfo <- withStore' $ \db -> getGroupExpiredFileInfo db user gInfo expirationDate createdAtCutoff - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo - withStore' $ \db -> deleteGroupExpiredCIs db user gInfo expirationDate createdAtCutoff - membersToDelete <- withStore' $ \db -> getGroupMembersForExpiration db vr user gInfo - forM_ membersToDelete $ \m -> withStore' $ \db -> deleteGroupMember db user m - -processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM () -processAgentMessage _ connId (DEL_RCVQ srv qId err_) = - toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_ -processAgentMessage _ connId DEL_CONN = - toView $ CRAgentConnDeleted (AgentConnId connId) -processAgentMessage _ "" (ERR e) = - toView $ CRChatError Nothing $ ChatErrorAgent e Nothing -processAgentMessage corrId connId msg = do - lockEntity <- critical (withStore (`getChatLockEntity` AgentConnId connId)) - withEntityLock "processAgentMessage" lockEntity $ do - vr <- chatVersionRange - -- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here - critical (withStore' (`getUserByAConnId` AgentConnId connId)) >>= \case - Just user -> processAgentMessageConn vr user corrId connId msg `catchChatError` (toView . CRChatError (Just user)) - _ -> throwChatError $ CENoConnectionUser (AgentConnId connId) - --- CRITICAL error will be shown to the user as alert with restart button in Android/desktop apps. --- SEDBBusyError will only be thrown on IO exceptions or SQLError during DB queries, --- e.g. when database is locked or busy for longer than 3s. --- In this case there is no better mitigation than showing alert: --- - without ACK the message delivery will be stuck, --- - with ACK message will be lost, as it failed to be saved. --- Full app restart is likely to resolve database condition and the message will be received and processed again. -critical :: CM a -> CM a -critical a = - a `catchChatError` \case - ChatErrorStore SEDBBusyError {message} -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing - e -> throwError e - -processAgentMessageNoConn :: AEvent 'AENone -> CM () -processAgentMessageNoConn = \case - CONNECT p h -> hostEvent $ CRHostConnected p h - DISCONNECT p h -> hostEvent $ CRHostDisconnected p h - DOWN srv conns -> serverEvent srv conns NSDisconnected CRContactsDisconnected - UP srv conns -> serverEvent srv conns NSConnected CRContactsSubscribed - SUSPENDED -> toView CRChatSuspended - DEL_USER agentUserId -> toView $ CRAgentUserDeleted agentUserId - ERRS cErrs -> errsEvent cErrs - where - hostEvent :: ChatResponse -> CM () - hostEvent = whenM (asks $ hostEvents . config) . toView - serverEvent srv conns nsStatus event = do - chatModifyVar connNetworkStatuses $ \m -> foldl' (\m' cId -> M.insert cId nsStatus m') m connIds - ifM (asks $ coreApi . config) (notifyAPI connIds) notifyCLI - where - connIds = map AgentConnId conns - notifyAPI = toView . CRNetworkStatus nsStatus - notifyCLI = do - cs <- withStore' (`getConnectionsContacts` conns) - toView $ event srv cs - errsEvent :: [(ConnId, AgentErrorType)] -> CM () - errsEvent cErrs = do - vr <- chatVersionRange - errs <- lift $ rights <$> withStoreBatch' (\db -> map (getChatErr vr db) cErrs) - toView $ CRChatErrors Nothing errs - where - getChatErr :: VersionRangeChat -> DB.Connection -> (ConnId, AgentErrorType) -> IO ChatError - getChatErr vr db (connId, err) = - let acId = AgentConnId connId - in ChatErrorAgent err <$> (getUserByAConnId db acId $>>= \user -> eitherToMaybe <$> runExceptT (getConnectionEntity db vr user acId)) - -processAgentMsgSndFile :: ACorrId -> SndFileId -> AEvent 'AESndFile -> CM () -processAgentMsgSndFile _corrId aFileId msg = do - (cRef_, fileId) <- withStore (`getXFTPSndFileDBIds` AgentSndFileId aFileId) - withEntityLock_ cRef_ . withFileLock "processAgentMsgSndFile" fileId $ - withStore' (`getUserByASndFileId` AgentSndFileId aFileId) >>= \case - Just user -> process user fileId `catchChatError` (toView . CRChatError (Just user)) - _ -> do - lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) - throwChatError $ CENoSndFileUser $ AgentSndFileId aFileId - where - withEntityLock_ :: Maybe ChatRef -> CM a -> CM a - withEntityLock_ cRef_ = case cRef_ of - Just (ChatRef CTDirect contactId) -> withContactLock "processAgentMsgSndFile" contactId - Just (ChatRef CTGroup groupId) -> withGroupLock "processAgentMsgSndFile" groupId - _ -> id - process :: User -> FileTransferId -> CM () - process user fileId = do - (ft@FileTransferMeta {xftpRedirectFor, cancelled}, sfts) <- withStore $ \db -> getSndFileTransfer db user fileId - vr <- chatVersionRange - unless cancelled $ case msg of - SFPROG sndProgress sndTotal -> do - let status = CIFSSndTransfer {sndProgress, sndTotal} - ci <- withStore $ \db -> do - liftIO $ updateCIFileStatus db user fileId status - lookupChatItemByFileId db vr user fileId - toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal - SFDONE sndDescr rfds -> do - withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr) - ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId - case ci of - Nothing -> do - lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) - withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText rfds) - case rfds of - [] -> sendFileError (FileErrOther "no receiver descriptions") "no receiver descriptions" vr ft - rfd : _ -> case [fd | fd@(FD.ValidFileDescription FD.FileDescription {chunks = [_]}) <- rfds] of - [] -> case xftpRedirectFor of - Nothing -> xftpSndFileRedirect user fileId rfd >>= toView . CRSndFileRedirectStartXFTP user ft - Just _ -> sendFileError (FileErrOther "chaining redirects") "Prohibit chaining redirects" vr ft - rfds' -> do - -- we have 1 chunk - use it as URI whether it is redirect or not - ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor - toView $ CRSndStandaloneFileComplete user ft' $ map (decodeLatin1 . strEncode . FD.fileDescriptionURI) rfds' - Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) -> - case (msgId_, itemDeleted) of - (Just sharedMsgId, Nothing) -> do - when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send" - -- TODO either update database status or move to SFPROG - toView $ CRSndFileProgressXFTP user ci ft 1 1 - case (rfds, sfts, d, cInfo) of - (rfd : extraRFDs, sft : _, SMDSnd, DirectChat ct) -> do - withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) - conn@Connection {connId} <- liftEither $ contactSendConn_ ct - sendFileDescriptions (ConnectionId connId) ((conn, sft, fileDescrText rfd) :| []) sharedMsgId >>= \case - Just rs -> case L.last rs of - Right ([msgDeliveryId], _) -> - withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId - Right (deliveryIds, _) -> toView $ CRChatError (Just user) $ ChatError $ CEInternalError $ "SFDONE, sendFileDescriptions: expected 1 delivery id, got " <> show (length deliveryIds) - Left e -> toView $ CRChatError (Just user) e - Nothing -> toView $ CRChatError (Just user) $ ChatError $ CEInternalError "SFDONE, sendFileDescriptions: expected at least 1 result" - lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) - (_, _, SMDSnd, GroupChat g@GroupInfo {groupId}) -> do - ms <- withStore' $ \db -> getGroupMembers db vr user g - let rfdsMemberFTs = zipWith (\rfd (conn, sft) -> (conn, sft, fileDescrText rfd)) rfds (memberFTs ms) - extraRFDs = drop (length rfdsMemberFTs) rfds - withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) - forM_ (L.nonEmpty rfdsMemberFTs) $ \rfdsMemberFTs' -> - sendFileDescriptions (GroupId groupId) rfdsMemberFTs' sharedMsgId - ci' <- withStore $ \db -> do - liftIO $ updateCIFileStatus db user fileId CIFSSndComplete - getChatItemByFileId db vr user fileId - lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) - toView $ CRSndFileCompleteXFTP user ci' ft - where - memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)] - memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts') - where - mConns' = mapMaybe useMember ms - sfts' = mapMaybe (\sft@SndFileTransfer {groupMemberId} -> (,sft) <$> groupMemberId) sfts - -- Should match memberSendAction logic - useMember GroupMember {groupMemberId, activeConn = Just conn@Connection {connStatus}} - | (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) && not (connInactive conn) = - Just (groupMemberId, conn) - | otherwise = Nothing - useMember _ = Nothing - _ -> pure () - _ -> pure () -- TODO error? - SFWARN e -> do - let err = tshow e - logWarn $ "Sent file warning: " <> err - ci <- withStore $ \db -> do - liftIO $ updateCIFileStatus db user fileId (CIFSSndWarning $ agentFileError e) - lookupChatItemByFileId db vr user fileId - toView $ CRSndFileWarning user ci ft err - SFERR e -> - sendFileError (agentFileError e) (tshow e) vr ft - where - fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text - fileDescrText = safeDecodeUtf8 . strEncode - sendFileDescriptions :: ConnOrGroupId -> NonEmpty (Connection, SndFileTransfer, RcvFileDescrText) -> SharedMsgId -> CM (Maybe (NonEmpty (Either ChatError ([Int64], PQEncryption)))) - sendFileDescriptions connOrGroupId connsTransfersDescrs sharedMsgId = do - lift . void . withStoreBatch' $ \db -> L.map (\(_, sft, rfdText) -> updateSndFTDescrXFTP db user sft rfdText) connsTransfersDescrs - partSize <- asks $ xftpDescrPartSize . config - let connsIdsEvts = connDescrEvents partSize - sndMsgs_ <- lift $ createSndMessages $ L.map snd connsIdsEvts - let (errs, msgReqs) = partitionEithers . L.toList $ L.zipWith (fmap . toMsgReq) connsIdsEvts sndMsgs_ - delivered <- mapM deliverMessages (L.nonEmpty msgReqs) - let errs' = errs <> maybe [] (lefts . L.toList) delivered - unless (null errs') $ toView $ CRChatErrors (Just user) errs' - pure delivered - where - connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)) - connDescrEvents partSize = L.fromList $ concatMap splitText (L.toList connsTransfersDescrs) - where - splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))] - splitText (conn, _, rfdText) = - map (\fileDescr -> (conn, (connOrGroupId, XMsgFileDescr {msgId = sharedMsgId, fileDescr}))) (L.toList $ splitFileDescr partSize rfdText) - toMsgReq :: (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq - toMsgReq (conn, _) SndMessage {msgId, msgBody} = - (conn, MsgFlags {notification = hasNotification XMsgFileDescr_}, msgBody, [msgId]) - sendFileError :: FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM () - sendFileError ferr err vr ft = do - logError $ "Sent file error: " <> err - ci <- withStore $ \db -> do - liftIO $ updateFileCancelled db user fileId (CIFSSndError ferr) - lookupChatItemByFileId db vr user fileId - lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) - toView $ CRSndFileError user ci ft err - -agentFileError :: AgentErrorType -> FileError -agentFileError = \case - XFTP _ XFTP.AUTH -> FileErrAuth - FILE NO_FILE -> FileErrNoFile - BROKER _ e -> brokerError FileErrRelay e - e -> FileErrOther $ tshow e - where - brokerError srvErr = \case - HOST -> srvErr SrvErrHost - SMP.TRANSPORT TEVersion -> srvErr SrvErrVersion - e -> srvErr . SrvErrOther $ tshow e - -splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr -splitFileDescr partSize rfdText = splitParts 1 rfdText - where - splitParts partNo remText = - let (part, rest) = T.splitAt partSize remText - complete = T.null rest - fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete} - in if complete - then fileDescr :| [] - else fileDescr <| splitParts (partNo + 1) rest - -processAgentMsgRcvFile :: ACorrId -> RcvFileId -> AEvent 'AERcvFile -> CM () -processAgentMsgRcvFile _corrId aFileId msg = do - (cRef_, fileId) <- withStore (`getXFTPRcvFileDBIds` AgentRcvFileId aFileId) - withEntityLock_ cRef_ . withFileLock "processAgentMsgRcvFile" fileId $ - withStore' (`getUserByARcvFileId` AgentRcvFileId aFileId) >>= \case - Just user -> process user fileId `catchChatError` (toView . CRChatError (Just user)) - _ -> do - lift $ withAgent' (`xftpDeleteRcvFile` aFileId) - throwChatError $ CENoRcvFileUser $ AgentRcvFileId aFileId - where - withEntityLock_ :: Maybe ChatRef -> CM a -> CM a - withEntityLock_ cRef_ = case cRef_ of - Just (ChatRef CTDirect contactId) -> withContactLock "processAgentMsgRcvFile" contactId - Just (ChatRef CTGroup groupId) -> withGroupLock "processAgentMsgRcvFile" groupId - _ -> id - process :: User -> FileTransferId -> CM () - process user fileId = do - ft <- withStore $ \db -> getRcvFileTransfer db user fileId - vr <- chatVersionRange - unless (rcvFileCompleteOrCancelled ft) $ case msg of - RFPROG rcvProgress rcvTotal -> do - let status = CIFSRcvTransfer {rcvProgress, rcvTotal} - ci <- withStore $ \db -> do - liftIO $ updateCIFileStatus db user fileId status - lookupChatItemByFileId db vr user fileId - toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal ft - RFDONE xftpPath -> - case liveRcvFileTransferPath ft of - Nothing -> throwChatError $ CEInternalError "no target path for received XFTP file" - Just targetPath -> do - fsTargetPath <- lift $ toFSFilePath targetPath - renameFile xftpPath fsTargetPath - ci_ <- withStore $ \db -> do - liftIO $ do - updateRcvFileStatus db fileId FSComplete - updateCIFileStatus db user fileId CIFSRcvComplete - lookupChatItemByFileId db vr user fileId - agentXFTPDeleteRcvFile aFileId fileId - toView $ maybe (CRRcvStandaloneFileComplete user fsTargetPath ft) (CRRcvFileComplete user) ci_ - RFWARN e -> do - ci <- withStore $ \db -> do - liftIO $ updateCIFileStatus db user fileId (CIFSRcvWarning $ agentFileError e) - lookupChatItemByFileId db vr user fileId - toView $ CRRcvFileWarning user ci e ft - RFERR e - | e == FILE NOT_APPROVED -> do - aci_ <- resetRcvCIFileStatus user fileId CIFSRcvAborted - forM_ aci_ cleanupACIFile - agentXFTPDeleteRcvFile aFileId fileId - forM_ aci_ $ \aci -> toView $ CRChatItemUpdated user aci - | otherwise -> do - aci_ <- withStore $ \db -> do - liftIO $ updateFileCancelled db user fileId (CIFSRcvError $ agentFileError e) - lookupChatItemByFileId db vr user fileId - forM_ aci_ cleanupACIFile - agentXFTPDeleteRcvFile aFileId fileId - toView $ CRRcvFileError user aci_ e ft - -cleanupACIFile :: AChatItem -> CM () -cleanupACIFile (AChatItem _ _ _ ChatItem {file = Just CIFile {fileSource = Just CryptoFile {filePath}}}) = do - fsFilePath <- lift $ toFSFilePath filePath - removeFile fsFilePath `catchChatError` \_ -> pure () -cleanupACIFile _ = pure () - -processAgentMessageConn :: VersionRangeChat -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM () -processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do - -- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert, - -- as in this case no need to ACK message - we can't process messages for this connection anyway. - -- SEDBException will be re-trown as CRITICAL as it is likely to indicate a temporary database condition - -- that will be resolved with app restart. - entity <- critical $ withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus - case agentMessage of - END -> case entity of - RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct - _ -> toView $ CRSubscriptionEnd user entity - MSGNTF msgId msgTs_ -> toView $ CRNtfMessage user entity $ ntfMsgAckInfo msgId msgTs_ - _ -> case entity of - RcvDirectMsgConnection conn contact_ -> - processDirectMessage agentMessage entity conn contact_ - RcvGroupMsgConnection conn gInfo m -> - processGroupMessage agentMessage entity conn gInfo m - RcvFileConnection conn ft -> - processRcvFileConn agentMessage entity conn ft - SndFileConnection conn ft -> - processSndFileConn agentMessage entity conn ft - UserContactConnection conn uc -> - processUserContactRequest agentMessage entity conn uc - where - updateConnStatus :: ConnectionEntity -> CM ConnectionEntity - updateConnStatus acEntity = case agentMsgConnStatus agentMessage of - Just connStatus -> do - let conn = (entityConnection acEntity) {connStatus} - withStore' $ \db -> updateConnectionStatus db conn connStatus - pure $ updateEntityConnStatus acEntity connStatus - Nothing -> pure acEntity - - agentMsgConnStatus :: AEvent e -> Maybe ConnStatus - agentMsgConnStatus = \case - JOINED True -> Just ConnSndReady - CONF {} -> Just ConnRequested - INFO {} -> Just ConnSndReady - CON _ -> Just ConnReady - _ -> Nothing - - processCONFpqSupport :: Connection -> PQSupport -> CM Connection - processCONFpqSupport conn@Connection {connId, pqSupport = pq} pq' - | pq == PQSupportOn && pq' == PQSupportOff = do - let pqEnc' = CR.pqSupportToEnc pq' - withStore' $ \db -> updateConnSupportPQ db connId pq' pqEnc' - pure (conn {pqSupport = pq', pqEncryption = pqEnc'} :: Connection) - | pq /= pq' = do - messageWarning "processCONFpqSupport: unexpected pqSupport change" - pure conn - | otherwise = pure conn - - processINFOpqSupport :: Connection -> PQSupport -> CM () - processINFOpqSupport Connection {pqSupport = pq} pq' = - when (pq /= pq') $ messageWarning "processINFOpqSupport: unexpected pqSupport change" - - processDirectMessage :: AEvent e -> ConnectionEntity -> Connection -> Maybe Contact -> CM () - processDirectMessage agentMsg connEntity conn@Connection {connId, connChatVersion, peerChatVRange, viaUserContactLink, customUserProfileId, connectionCode} = \case - Nothing -> case agentMsg of - CONF confId pqSupport _ connInfo -> do - conn' <- processCONFpqSupport conn pqSupport - -- [incognito] send saved profile - (conn'', inGroup) <- saveConnInfo conn' connInfo - incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) - let profileToSend = userProfileToSend user (fromLocalProfile <$> incognitoProfile) Nothing inGroup - -- [async agent commands] no continuation needed, but command should be asynchronous for stability - allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend - INFO pqSupport connInfo -> do - processINFOpqSupport conn pqSupport - void $ saveConnInfo conn connInfo - MSG meta _msgFlags _msgBody -> - -- We are not saving message (saveDirectRcvMSG) as contact hasn't been created yet, - -- chat item is also not created here - withAckMessage' "new contact msg" agentConnId meta $ pure () - SENT msgId _proxy -> do - void $ continueSending connEntity conn - sentMsgDeliveryEvent conn msgId - OK -> - -- [async agent commands] continuation on receiving OK - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - JOINED _ -> - -- [async agent commands] continuation on receiving JOINED - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - QCONT -> - void $ continueSending connEntity conn - MWARN _ err -> - processConnMWARN connEntity conn err - MERR _ err -> do - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - processConnMERR connEntity conn err - MERRS _ err -> do - -- error cannot be AUTH error here - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - ERR err -> do - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - -- TODO add debugging output - _ -> pure () - Just ct@Contact {contactId} -> case agentMsg of - INV (ACR _ cReq) -> - -- [async agent commands] XGrpMemIntro continuation on receiving INV - withCompletedCommand conn agentMsg $ \_ -> - case cReq of - directConnReq@(CRInvitationUri _ _) -> do - contData <- withStore' $ \db -> do - setConnConnReqInv db user connId cReq - getXGrpMemIntroContDirect db user ct - forM_ contData $ \(hostConnId, xGrpMemIntroCont) -> - sendXGrpMemInv hostConnId (Just directConnReq) xGrpMemIntroCont - CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" - MSG msgMeta _msgFlags msgBody -> do - tags <- newTVarIO [] - withAckMessage "contact msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do - let MsgMeta {pqEncryption} = msgMeta - (ct', conn') <- updateContactPQRcv user ct conn pqEncryption - checkIntegrityCreateItem (CDDirectRcv ct') msgMeta `catchChatError` \_ -> pure () - forM_ aChatMsgs $ \case - Right (ACMsg _ chatMsg) -> - processEvent ct' conn' tags eInfo chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e - Left e -> do - atomically $ modifyTVar' tags ("error" :) - logInfo $ "contact msg=error " <> eInfo <> " " <> tshow e - toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e) - checkSendRcpt ct' $ rights aChatMsgs -- not crucial to use ct'' from processEvent - where - aChatMsgs = parseChatMessages msgBody - processEvent :: Contact -> Connection -> TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM () - processEvent ct' conn' tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do - let tag = toCMEventTag chatMsgEvent - atomically $ modifyTVar' tags (tshow tag :) - logInfo $ "contact msg=" <> tshow tag <> " " <> eInfo - (conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta msgBody chatMsg - let ct'' = ct' {activeConn = Just conn''} :: Contact - case event of - XMsgNew mc -> newContentMessage ct'' mc msg msgMeta - XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live - XMsgDel sharedMsgId _ -> messageDelete ct'' sharedMsgId msg msgMeta - XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta - -- TODO discontinue XFile - XFile fInv -> processFileInvitation' ct'' fInv msg msgMeta - XFileCancel sharedMsgId -> xFileCancel ct'' sharedMsgId - XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct'' sharedMsgId fileConnReq_ fName - XInfo p -> xInfo ct'' p - XDirectDel -> xDirectDel ct'' msg msgMeta - XGrpInv gInv -> processGroupInvitation ct'' gInv msg msgMeta - XInfoProbe probe -> xInfoProbe (COMContact ct'') probe - XInfoProbeCheck probeHash -> xInfoProbeCheck (COMContact ct'') probeHash - XInfoProbeOk probe -> xInfoProbeOk (COMContact ct'') probe - XCallInv callId invitation -> xCallInv ct'' callId invitation msg msgMeta - XCallOffer callId offer -> xCallOffer ct'' callId offer msg - XCallAnswer callId answer -> xCallAnswer ct'' callId answer msg - XCallExtra callId extraInfo -> xCallExtra ct'' callId extraInfo msg - XCallEnd callId -> xCallEnd ct'' callId msg - BFileChunk sharedMsgId chunk -> bFileChunk ct'' sharedMsgId chunk msgMeta - _ -> messageError $ "unsupported message: " <> T.pack (show event) - checkSendRcpt :: Contact -> [AChatMessage] -> CM Bool - checkSendRcpt ct' aMsgs = do - let Contact {chatSettings = ChatSettings {sendRcpts}} = ct' - pure $ fromMaybe (sendRcptsContacts user) sendRcpts && any aChatMsgHasReceipt aMsgs - where - aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) = - hasDeliveryReceipt (toCMEventTag chatMsgEvent) - RCVD msgMeta msgRcpt -> - withAckMessage' "contact rcvd" agentConnId msgMeta $ - directMsgReceived ct conn msgMeta msgRcpt - CONF confId pqSupport _ connInfo -> do - conn' <- processCONFpqSupport conn pqSupport - ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn' connInfo - conn'' <- updatePeerChatVRange conn' chatVRange - case chatMsgEvent of - -- confirming direct connection with a member - XGrpMemInfo _memId _memProfile -> do - -- TODO check member ID - -- TODO update member profile - -- [async agent commands] no continuation needed, but command should be asynchronous for stability - allowAgentConnectionAsync user conn'' confId XOk - XInfo profile -> do - ct' <- processContactProfileUpdate ct profile False `catchChatError` const (pure ct) - -- [incognito] send incognito profile - incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId - let p = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct') False - allowAgentConnectionAsync user conn'' confId $ XInfo p - void $ withStore' $ \db -> resetMemberContactFields db ct' - XGrpLinkInv glInv -> do - -- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group - (gInfo, host) <- withStore $ \db -> do - liftIO $ deleteContactCardKeepConn db connId ct - createGroupInvitedViaLink db vr user conn'' glInv - -- [incognito] send saved profile - incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId) - let profileToSend = userProfileToSend user (fromLocalProfile <$> incognitoProfile) Nothing True - allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend - toView $ CRBusinessLinkConnecting user gInfo host ct - _ -> messageError "CONF for existing contact must have x.grp.mem.info or x.info" - INFO pqSupport connInfo -> do - processINFOpqSupport conn pqSupport - ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo - _conn' <- updatePeerChatVRange conn chatVRange - case chatMsgEvent of - XGrpMemInfo _memId _memProfile -> do - -- TODO check member ID - -- TODO update member profile - pure () - XInfo profile -> - void $ processContactProfileUpdate ct profile False - XOk -> pure () - _ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok" - CON pqEnc -> - withStore' (\db -> getViaGroupMember db vr user ct) >>= \case - Nothing -> do - when (pqEnc == PQEncOn) $ withStore' $ \db -> updateConnPQEnabledCON db connId pqEnc - let conn' = conn {pqSndEnabled = Just pqEnc, pqRcvEnabled = Just pqEnc} :: Connection - ct' = ct {activeConn = Just conn'} :: Contact - -- [incognito] print incognito profile used for this contact - incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) - lift $ setContactNetworkStatus ct' NSConnected - toView $ CRContactConnected user ct' (fmap fromLocalProfile incognitoProfile) - when (directOrUsed ct') $ do - unless (contactUsed ct') $ withFastStore' $ \db -> updateContactUsed db user ct' - createInternalChatItem user (CDDirectRcv ct') (CIRcvDirectE2EEInfo $ E2EInfo pqEnc) Nothing - createFeatureEnabledItems ct' - when (contactConnInitiated conn') $ do - let Connection {groupLinkId} = conn' - doProbeContacts = isJust groupLinkId - probeMatchingContactsAndMembers ct' (contactConnIncognito ct') doProbeContacts - withStore' $ \db -> resetContactConnInitiated db user conn' - forM_ viaUserContactLink $ \userContactLinkId -> do - ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId - let (UserContactLink {autoAccept}, groupId_, gLinkMemRole) = ucl - when (connChatVersion < batchSend2Version) $ sendAutoReply ct' autoAccept - forM_ groupId_ $ \groupId -> do - groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId - subMode <- chatReadVar subscriptionMode - groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode - gVar <- asks random - withStore $ \db -> createNewContactMemberAsync db gVar user groupInfo ct' gLinkMemRole groupConnIds connChatVersion peerChatVRange subMode - Just (gInfo, m@GroupMember {activeConn}) -> - when (maybe False ((== ConnReady) . connStatus) activeConn) $ do - notifyMemberConnected gInfo m $ Just ct - let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo - when (memberCategory m == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True - SENT msgId proxy -> do - void $ continueSending connEntity conn - sentMsgDeliveryEvent conn msgId - checkSndInlineFTComplete conn msgId - cis <- withStore $ \db -> do - cis <- updateDirectItemsStatus' db ct conn msgId (CISSndSent SSPComplete) - liftIO $ forM cis $ \ci -> setDirectSndChatItemViaProxy db user ct ci (isJust proxy) - let acis = map ctItem cis - unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis - where - ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct) - SWITCH qd phase cStats -> do - toView $ CRContactSwitch user ct (SwitchProgress qd phase cStats) - when (phase == SPStarted || phase == SPCompleted) $ case qd of - QDRcv -> createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCESwitchQueue phase Nothing) Nothing - QDSnd -> createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing - RSYNC rss cryptoErr_ cStats -> - case (rss, connectionCode, cryptoErr_) of - (RSRequired, _, Just cryptoErr) -> processErr cryptoErr - (RSAllowed, _, Just cryptoErr) -> processErr cryptoErr - (RSAgreed, Just _, _) -> do - withStore' $ \db -> setConnectionVerified db user connId Nothing - let ct' = ct {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} :: Contact - ratchetSyncEventItem ct' - securityCodeChanged ct' - _ -> ratchetSyncEventItem ct - where - processErr cryptoErr = do - let e@(mde, n) = agentMsgDecryptError cryptoErr - ci_ <- withStore $ \db -> - getDirectChatItemLast db user contactId - >>= liftIO - . mapM (\(ci, content') -> updateDirectChatItem' db user contactId ci content' False False Nothing Nothing) - . mdeUpdatedCI e - case ci_ of - Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) - _ -> do - toView $ CRContactRatchetSync user ct (RatchetSyncProgress rss cStats) - createInternalChatItem user (CDDirectRcv ct) (CIRcvDecryptionError mde n) Nothing - ratchetSyncEventItem ct' = do - toView $ CRContactRatchetSync user ct' (RatchetSyncProgress rss cStats) - createInternalChatItem user (CDDirectRcv ct') (CIRcvConnEvent $ RCERatchetSync rss) Nothing - OK -> - -- [async agent commands] continuation on receiving OK - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - JOINED sqSecured -> - -- [async agent commands] continuation on receiving JOINED - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> - when (directOrUsed ct && sqSecured) $ do - lift $ setContactNetworkStatus ct NSConnected - toView $ CRContactSndReady user ct - forM_ viaUserContactLink $ \userContactLinkId -> do - ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId - let (UserContactLink {autoAccept}, _, _) = ucl - when (connChatVersion >= batchSend2Version) $ sendAutoReply ct autoAccept - QCONT -> - void $ continueSending connEntity conn - MWARN msgId err -> do - updateDirectItemStatus ct conn msgId (CISSndWarning $ agentSndError err) - processConnMWARN connEntity conn err - MERR msgId err -> do - updateDirectItemStatus ct conn msgId (CISSndError $ agentSndError err) - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - processConnMERR connEntity conn err - MERRS msgIds err -> do - -- error cannot be AUTH error here - updateDirectItemsStatusMsgs ct conn (L.toList msgIds) (CISSndError $ agentSndError err) - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - ERR err -> do - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - -- TODO add debugging output - _ -> pure () - where - sendAutoReply ct = \case - Just AutoAccept {autoReply = Just mc} -> do - (msg, _) <- sendDirectContactMessage user ct (XMsgNew $ MCSimple (extMsgContent mc Nothing)) - ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) - toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] - _ -> pure () - - processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> CM () - processGroupMessage agentMsg connEntity conn@Connection {connId, connChatVersion, connectionCode} gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} m = case agentMsg of - INV (ACR _ cReq) -> - withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} -> - case cReq of - groupConnReq@(CRInvitationUri _ _) -> case cmdFunction of - -- [async agent commands] XGrpMemIntro continuation on receiving INV - CFCreateConnGrpMemInv - | maxVersion (peerChatVRange conn) >= groupDirectInvVersion -> sendWithoutDirectCReq - | otherwise -> sendWithDirectCReq - where - sendWithoutDirectCReq = do - let GroupMember {groupMemberId, memberId} = m - hostConnId <- withStore $ \db -> do - liftIO $ setConnConnReqInv db user connId cReq - getHostConnId db user groupId - sendXGrpMemInv hostConnId Nothing XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} - sendWithDirectCReq = do - let GroupMember {groupMemberId, memberId} = m - contData <- withStore' $ \db -> do - setConnConnReqInv db user connId cReq - getXGrpMemIntroContGroup db user m - forM_ contData $ \(hostConnId, directConnReq) -> - sendXGrpMemInv hostConnId (Just directConnReq) XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} - -- [async agent commands] group link auto-accept continuation on receiving INV - CFCreateConnGrpInv -> do - ct <- withStore $ \db -> getContactViaMember db vr user m - withStore' $ \db -> setNewContactMemberConnRequest db user m cReq - groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo - sendGrpInvitation ct m groupLinkId - toView $ CRSentGroupInvitation user gInfo ct m - where - sendGrpInvitation :: Contact -> GroupMember -> Maybe GroupLinkId -> CM () - sendGrpInvitation ct GroupMember {memberId, memberRole = memRole} groupLinkId = do - currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo - let GroupMember {memberRole = userRole, memberId = userMemberId} = membership - groupInv = - GroupInvitation - { fromMember = MemberIdRole userMemberId userRole, - invitedMember = MemberIdRole memberId memRole, - connRequest = cReq, - groupProfile, - business = Nothing, - groupLinkId = groupLinkId, - groupSize = Just currentMemCount - } - (_msg, _) <- sendDirectContactMessage user ct $ XGrpInv groupInv - -- we could link chat item with sent group invitation message (_msg) - createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing - _ -> throwChatError $ CECommandError "unexpected cmdFunction" - CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" - CONF confId _pqSupport _ connInfo -> do - ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo - conn' <- updatePeerChatVRange conn chatVRange - case memberCategory m of - GCInviteeMember -> - case chatMsgEvent of - XGrpAcpt memId - | sameMemberId memId m -> do - withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted - -- [async agent commands] no continuation needed, but command should be asynchronous for stability - allowAgentConnectionAsync user conn' confId XOk - | otherwise -> messageError "x.grp.acpt: memberId is different from expected" - _ -> messageError "CONF from invited member must have x.grp.acpt" - _ -> - case chatMsgEvent of - XGrpMemInfo memId _memProfile - | sameMemberId memId m -> do - let GroupMember {memberId = membershipMemId} = membership - membershipProfile = redactedMemberProfile $ fromLocalProfile $ memberProfile membership - -- TODO update member profile - -- [async agent commands] no continuation needed, but command should be asynchronous for stability - allowAgentConnectionAsync user conn' confId $ XGrpMemInfo membershipMemId membershipProfile - | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" - _ -> messageError "CONF from member must have x.grp.mem.info" - INFO _pqSupport connInfo -> do - ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo - _conn' <- updatePeerChatVRange conn chatVRange - case chatMsgEvent of - XGrpMemInfo memId _memProfile - | sameMemberId memId m -> do - -- TODO update member profile - pure () - | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" - XInfo _ -> pure () -- sent when connecting via group link - XOk -> pure () - _ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok" - pure () - CON _pqEnc -> do - withStore' $ \db -> do - updateGroupMemberStatus db userId m GSMemConnected - unless (memberActive membership) $ - 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) $ chatHasNtfs chatSettings - case memberCategory m of - GCHostMember -> do - toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected} - let cd = CDGroupRcv gInfo m - createInternalChatItem user cd (CIRcvGroupE2EEInfo E2EInfo {pqEnabled = PQEncOff}) Nothing - createGroupFeatureItems user cd CIRcvGroupFeature gInfo - let GroupInfo {groupProfile = GroupProfile {description}} = gInfo - memberConnectedChatItem gInfo m - unless expectHistory $ forM_ description $ groupDescriptionChatItem gInfo m - where - expectHistory = groupFeatureAllowed SGFHistory gInfo && m `supportsVersion` groupHistoryIncludeWelcomeVersion - GCInviteeMember -> do - memberConnectedChatItem gInfo m - toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected} - let Connection {viaUserContactLink} = conn - when (isJust viaUserContactLink && isNothing (memberContactId m)) sendXGrpLinkMem - members <- withStore' $ \db -> getGroupMembers db vr user gInfo - void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m - sendIntroductions members - when (groupFeatureAllowed SGFHistory gInfo) sendHistory - when (connChatVersion < batchSend2Version) sendGroupAutoReply - where - sendXGrpLinkMem = do - let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo - profileToSend = profileToSendOnAccept user profileMode True - void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId - sendIntroductions members = do - intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m - shuffledIntros <- liftIO $ shuffleIntros intros - if m `supportsVersion` batchSendVersion - then do - let events = map (memberIntro . reMember) shuffledIntros - forM_ (L.nonEmpty events) $ \events' -> - sendGroupMemberMessages user conn events' groupId - else forM_ shuffledIntros $ \intro -> - processIntro intro `catchChatError` (toView . CRChatError (Just user)) - memberIntro :: GroupMember -> ChatMsgEvent 'Json - memberIntro reMember = - let mInfo = memberInfo reMember - mRestrictions = memberRestrictions reMember - in XGrpMemIntro mInfo mRestrictions - shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro] - shuffleIntros intros = do - let (admins, others) = partition isAdmin intros - (admPics, admNoPics) = partition hasPicture admins - (othPics, othNoPics) = partition hasPicture others - mconcat <$> mapM shuffle [admPics, admNoPics, othPics, othNoPics] - where - isAdmin GroupMemberIntro {reMember = GroupMember {memberRole}} = memberRole >= GRAdmin - hasPicture GroupMemberIntro {reMember = GroupMember {memberProfile = LocalProfile {image}}} = isJust image - processIntro intro@GroupMemberIntro {introId} = do - void $ sendDirectMemberMessage conn (memberIntro $ reMember intro) groupId - withStore' $ \db -> updateIntroStatus db introId GMIntroSent - sendHistory = - when (m `supportsVersion` batchSendVersion) $ do - (errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100) - (errs', events) <- partitionEithers <$> mapM (tryChatError . itemForwardEvents) items - let errors = map ChatErrorStore errs <> errs' - unless (null errors) $ toView $ CRChatErrors (Just user) errors - let events' = maybe (concat events) (\x -> concat events <> [x]) descrEvent_ - forM_ (L.nonEmpty events') $ \events'' -> - sendGroupMemberMessages user conn events'' groupId - descrEvent_ :: Maybe (ChatMsgEvent 'Json) - descrEvent_ - | m `supportsVersion` groupHistoryIncludeWelcomeVersion = do - let GroupInfo {groupProfile = GroupProfile {description}} = gInfo - fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description - | otherwise = Nothing - itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json] - itemForwardEvents cci = case cci of - (CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) - | not (blockedByAdmin sender) -> do - fInvDescr_ <- join <$> forM file getRcvFileInvDescr - processContentItem sender ci mc fInvDescr_ - (CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do - fInvDescr_ <- join <$> forM file getSndFileInvDescr - processContentItem membership ci mc fInvDescr_ - _ -> pure [] - where - getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText)) - getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do - expired <- fileExpired - if fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled || expired - then pure Nothing - else do - rfd <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId - pure $ invCompleteDescr ciFile rfd - getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe (FileInvitation, RcvFileDescrText)) - getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do - expired <- fileExpired - if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired - then pure Nothing - else do - -- can also lookup in extra_xftp_file_descriptions, though it can be empty; - -- would be best if snd file had a single rcv description for all members saved in files table - rfd <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId - pure $ invCompleteDescr ciFile rfd - fileExpired :: CM Bool - fileExpired = do - ttl <- asks $ rcvFilesTTL . agentConfig . config - cutoffTs <- addUTCTime (-ttl) <$> liftIO getCurrentTime - pure $ chatItemTs cci < cutoffTs - invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText) - invCompleteDescr CIFile {fileName, fileSize} RcvFileDescr {fileDescrText, fileDescrComplete} - | fileDescrComplete = - let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} - fInv = xftpFileInvitation fileName fileSize fInvDescr - in Just (fInv, fileDescrText) - | otherwise = Nothing - processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json] - processContentItem sender ChatItem {meta, quotedItem} mc fInvDescr_ = - if isNothing fInvDescr_ && not (msgContentHasText mc) - then pure [] - else do - let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta - quotedItemId_ = quoteItemId =<< quotedItem - fInv_ = fst <$> fInvDescr_ - (msgContainer, _) <- prepareGroupMsg user gInfo mc quotedItemId_ Nothing fInv_ itemTimed False - let senderVRange = memberChatVRange' sender - xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer} - fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of - (Just fileDescrText, Just msgId) -> do - partSize <- asks $ xftpDescrPartSize . config - let parts = splitFileDescr partSize fileDescrText - pure . L.toList $ L.map (XMsgFileDescr msgId) parts - _ -> pure [] - let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents - GroupMember {memberId} = sender - msgForwardEvents = map (\cm -> XGrpMsgForward memberId cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) - pure msgForwardEvents - _ -> do - let memCategory = memberCategory m - withStore' (\db -> getViaGroupContact db vr user m) >>= \case - Nothing -> do - notifyMemberConnected gInfo m Nothing - let connectedIncognito = memberIncognito membership - when (memCategory == GCPreMember) $ probeMatchingMemberContact m connectedIncognito - Just ct@Contact {activeConn} -> - forM_ activeConn $ \Connection {connStatus} -> - when (connStatus == ConnReady) $ do - notifyMemberConnected gInfo m $ Just ct - let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo - when (memCategory == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True - sendXGrpMemCon memCategory - where - GroupMember {memberId} = m - sendXGrpMemCon = \case - GCPreMember -> - forM_ (invitedByGroupMemberId membership) $ \hostId -> do - host <- withStore $ \db -> getGroupMember db vr user groupId hostId - forM_ (memberConn host) $ \hostConn -> - void $ sendDirectMemberMessage hostConn (XGrpMemCon memberId) groupId - GCPostMember -> - forM_ (invitedByGroupMemberId m) $ \invitingMemberId -> do - im <- withStore $ \db -> getGroupMember db vr user groupId invitingMemberId - forM_ (memberConn im) $ \imConn -> - void $ sendDirectMemberMessage imConn (XGrpMemCon memberId) groupId - _ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected" - MSG msgMeta _msgFlags msgBody -> do - tags <- newTVarIO [] - withAckMessage "group msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do - checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure () - forM_ aChatMsgs $ \case - Right (ACMsg _ chatMsg) -> - processEvent tags eInfo chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e - Left e -> do - atomically $ modifyTVar' tags ("error" :) - logInfo $ "group msg=error " <> eInfo <> " " <> tshow e - toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e) - forwardMsgs (rights aChatMsgs) `catchChatError` (toView . CRChatError (Just user)) - checkSendRcpt $ rights aChatMsgs - where - aChatMsgs = parseChatMessages msgBody - brokerTs = metaBrokerTs msgMeta - processEvent :: TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM () - processEvent tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do - let tag = toCMEventTag chatMsgEvent - atomically $ modifyTVar' tags (tshow tag :) - logInfo $ "group msg=" <> tshow tag <> " " <> eInfo - (m', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m conn msgMeta msgBody chatMsg - case event of - XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs False - XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg brokerTs ttl live - XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs - XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs - -- TODO discontinue XFile - XFile fInv -> processGroupFileInvitation' gInfo m' fInv msg brokerTs - XFileCancel sharedMsgId -> xFileCancelGroup gInfo m' sharedMsgId - XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m' sharedMsgId fileConnReq_ fName - XInfo p -> xInfoMember gInfo m' p brokerTs - XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p - XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg brokerTs - XGrpMemIntro memInfo memRestrictions_ -> xGrpMemIntro gInfo m' memInfo memRestrictions_ - XGrpMemInv memId introInv -> xGrpMemInv gInfo m' memId introInv - XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo m' memInfo introInv - XGrpMemRole memId memRole -> xGrpMemRole gInfo m' memId memRole msg brokerTs - XGrpMemRestrict memId memRestrictions -> xGrpMemRestrict gInfo m' memId memRestrictions msg brokerTs - XGrpMemCon memId -> xGrpMemCon gInfo m' memId - XGrpMemDel memId -> xGrpMemDel gInfo m' memId msg brokerTs - XGrpLeave -> xGrpLeave gInfo m' msg brokerTs - XGrpDel -> xGrpDel gInfo m' msg brokerTs - XGrpInfo p' -> xGrpInfo gInfo m' p' msg brokerTs - XGrpPrefs ps' -> xGrpPrefs gInfo m' ps' - XGrpDirectInv connReq mContent_ -> memberCanSend m' $ xGrpDirectInv gInfo m' conn' connReq mContent_ msg brokerTs - XGrpMsgForward memberId msg' msgTs -> xGrpMsgForward gInfo m' memberId msg' msgTs - XInfoProbe probe -> xInfoProbe (COMGroupMember m') probe - XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m') probeHash - XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m') probe - BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta - _ -> messageError $ "unsupported message: " <> tshow event - checkSendRcpt :: [AChatMessage] -> CM Bool - checkSendRcpt aMsgs = do - currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo - let GroupInfo {chatSettings = ChatSettings {sendRcpts}} = gInfo - pure $ - fromMaybe (sendRcptsSmallGroups user) sendRcpts - && any aChatMsgHasReceipt aMsgs - && currentMemCount <= smallGroupsRcptsMemLimit - where - aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) = - hasDeliveryReceipt (toCMEventTag chatMsgEvent) - forwardMsgs :: [AChatMessage] -> CM () - forwardMsgs aMsgs = do - let GroupMember {memberRole = membershipMemRole} = membership - when (membershipMemRole >= GRAdmin && not (blockedByAdmin m)) $ do - let forwardedMsgs = mapMaybe (\(ACMsg _ chatMsg) -> forwardedGroupMsg chatMsg) aMsgs - forM_ (L.nonEmpty forwardedMsgs) $ \forwardedMsgs' -> do - ChatConfig {highlyAvailable} <- asks config - -- members introduced to this invited member - introducedMembers <- - if memberCategory m == GCInviteeMember - then withStore' $ \db -> getForwardIntroducedMembers db vr user m highlyAvailable - else pure [] - -- invited members to which this member was introduced - invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db vr user m highlyAvailable - let GroupMember {memberId} = m - ms = forwardedToGroupMembers (introducedMembers <> invitedMembers) forwardedMsgs' - events = L.map (\cm -> XGrpMsgForward memberId cm brokerTs) forwardedMsgs' - unless (null ms) $ void $ sendGroupMessages user gInfo ms events - RCVD msgMeta msgRcpt -> - withAckMessage' "group rcvd" agentConnId msgMeta $ - groupMsgReceived gInfo m conn msgMeta msgRcpt - SENT msgId proxy -> do - continued <- continueSending connEntity conn - sentMsgDeliveryEvent conn msgId - checkSndInlineFTComplete conn msgId - updateGroupItemsStatus gInfo m conn msgId GSSSent (Just $ isJust proxy) - when continued $ sendPendingGroupMessages user m conn - SWITCH qd phase cStats -> do - toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats) - when (phase == SPStarted || phase == SPCompleted) $ case qd of - QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing - QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing - RSYNC rss cryptoErr_ cStats -> - case (rss, connectionCode, cryptoErr_) of - (RSRequired, _, Just cryptoErr) -> processErr cryptoErr - (RSAllowed, _, Just cryptoErr) -> processErr cryptoErr - (RSAgreed, Just _, _) -> do - withStore' $ \db -> setConnectionVerified db user connId Nothing - let m' = m {activeConn = Just (conn {connectionCode = Nothing} :: Connection)} :: GroupMember - ratchetSyncEventItem m' - toView $ CRGroupMemberVerificationReset user gInfo m' - createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent RCEVerificationCodeReset) Nothing - _ -> ratchetSyncEventItem m - where - processErr cryptoErr = do - let e@(mde, n) = agentMsgDecryptError cryptoErr - ci_ <- withStore $ \db -> - getGroupMemberChatItemLast db user groupId (groupMemberId' m) - >>= liftIO - . mapM (\(ci, content') -> updateGroupChatItem db user groupId ci content' False False Nothing) - . mdeUpdatedCI e - case ci_ of - Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci) - _ -> do - toView $ CRGroupMemberRatchetSync user gInfo m (RatchetSyncProgress rss cStats) - createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvDecryptionError mde n) Nothing - ratchetSyncEventItem m' = do - toView $ CRGroupMemberRatchetSync user gInfo m' (RatchetSyncProgress rss cStats) - createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent $ RCERatchetSync rss) Nothing - OK -> - -- [async agent commands] continuation on receiving OK - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - JOINED sqSecured -> - -- [async agent commands] continuation on receiving JOINED - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> - when (sqSecured && connChatVersion >= batchSend2Version) sendGroupAutoReply - QCONT -> do - continued <- continueSending connEntity conn - when continued $ sendPendingGroupMessages user m conn - MWARN msgId err -> do - withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSWarning $ agentSndError err) - processConnMWARN connEntity conn err - MERR msgId err -> do - withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSError $ agentSndError err) - -- group errors are silenced to reduce load on UI event log - -- toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - processConnMERR connEntity conn err - MERRS msgIds err -> do - let newStatus = GSSError $ agentSndError err - -- error cannot be AUTH error here - withStore' $ \db -> forM_ msgIds $ \msgId -> - updateGroupItemsErrorStatus db msgId (groupMemberId' m) newStatus `catchAll_` pure () - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - ERR err -> do - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - -- TODO add debugging output - _ -> pure () - where - updateGroupItemsErrorStatus :: DB.Connection -> AgentMsgId -> GroupMemberId -> GroupSndStatus -> IO () - updateGroupItemsErrorStatus db msgId groupMemberId newStatus = do - itemIds <- getChatItemIdsByAgentMsgId db connId msgId - forM_ itemIds $ \itemId -> updateGroupMemSndStatus' db itemId groupMemberId newStatus - sendGroupAutoReply = autoReplyMC >>= mapM_ send - where - autoReplyMC = do - let GroupInfo {businessChat} = gInfo - GroupMember {memberId = joiningMemberId} = m - case businessChat of - Just BusinessChatInfo {customerId, chatType = BCCustomer} - | joiningMemberId == customerId -> useReply <$> withStore (`getUserAddress` user) - where - useReply UserContactLink {autoAccept} = case autoAccept of - Just AutoAccept {businessAddress, autoReply} | businessAddress -> autoReply - _ -> Nothing - _ -> pure Nothing - send mc = do - msg <- sendGroupMessage' user gInfo [m] (XMsgNew $ MCSimple (extMsgContent mc Nothing)) - ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndMsgContent mc) - withStore' $ \db -> createGroupSndStatus db (chatItemId' ci) (groupMemberId' m) GSSNew - toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] - - agentMsgDecryptError :: AgentCryptoError -> (MsgDecryptError, Word32) - agentMsgDecryptError = \case - DECRYPT_AES -> (MDEOther, 1) - DECRYPT_CB -> (MDEOther, 1) - RATCHET_HEADER -> (MDERatchetHeader, 1) - RATCHET_EARLIER _ -> (MDERatchetEarlier, 1) - RATCHET_SKIPPED n -> (MDETooManySkipped, n) - RATCHET_SYNC -> (MDERatchetSync, 0) - - mdeUpdatedCI :: (MsgDecryptError, Word32) -> CChatItem c -> Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv) - mdeUpdatedCI (mde', n') (CChatItem _ ci@ChatItem {content = CIRcvDecryptionError mde n}) - | mde == mde' = case mde of - MDERatchetHeader -> r (n + n') - MDETooManySkipped -> r n' -- the numbers are not added as sequential MDETooManySkipped will have it incremented by 1 - MDERatchetEarlier -> r (n + n') - MDEOther -> r (n + n') - MDERatchetSync -> r 0 - | otherwise = Nothing - where - r n'' = Just (ci, CIRcvDecryptionError mde n'') - mdeUpdatedCI _ _ = Nothing - - processSndFileConn :: AEvent e -> ConnectionEntity -> Connection -> SndFileTransfer -> CM () - processSndFileConn agentMsg connEntity conn ft@SndFileTransfer {fileId, fileName, fileStatus} = - case agentMsg of - -- SMP CONF for SndFileConnection happens for direct file protocol - -- when recipient of the file "joins" connection created by the sender - CONF confId _pqSupport _ connInfo -> do - ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo - conn' <- updatePeerChatVRange conn chatVRange - case chatMsgEvent of - -- TODO save XFileAcpt message - XFileAcpt name - | name == fileName -> do - withStore' $ \db -> updateSndFileStatus db ft FSAccepted - -- [async agent commands] no continuation needed, but command should be asynchronous for stability - allowAgentConnectionAsync user conn' confId XOk - | otherwise -> messageError "x.file.acpt: fileName is different from expected" - _ -> messageError "CONF from file connection must have x.file.acpt" - CON _ -> do - ci <- withStore $ \db -> do - liftIO $ updateSndFileStatus db ft FSConnected - updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1 - toView $ CRSndFileStart user ci ft - sendFileChunk user ft - SENT msgId _proxy -> do - withStore' $ \db -> updateSndFileChunkSent db ft msgId - unless (fileStatus == FSCancelled) $ sendFileChunk user ft - MERR _ err -> do - cancelSndFileTransfer user ft True >>= mapM_ (deleteAgentConnectionAsync user) - case err of - SMP _ SMP.AUTH -> unless (fileStatus == FSCancelled) $ do - ci <- withStore $ \db -> do - liftIO (lookupChatRefByFileId db user fileId) >>= \case - Just (ChatRef CTDirect _) -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled - _ -> pure () - lookupChatItemByFileId db vr user fileId - toView $ CRSndFileRcvCancelled user ci ft - _ -> throwChatError $ CEFileSend fileId err - MSG meta _ _ -> - withAckMessage' "file msg" agentConnId meta $ pure () - OK -> - -- [async agent commands] continuation on receiving OK - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - JOINED _ -> - -- [async agent commands] continuation on receiving JOINED - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - ERR err -> do - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - -- TODO add debugging output - _ -> pure () - - processRcvFileConn :: AEvent e -> ConnectionEntity -> Connection -> RcvFileTransfer -> CM () - processRcvFileConn agentMsg connEntity conn ft@RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}, grpMemberId} = - case agentMsg of - INV (ACR _ cReq) -> - withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} -> - case cReq of - fileInvConnReq@(CRInvitationUri _ _) -> case cmdFunction of - -- [async agent commands] direct XFileAcptInv continuation on receiving INV - CFCreateConnFileInvDirect -> do - ct <- withStore $ \db -> getContactByFileId db vr user fileId - sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId - void $ sendDirectContactMessage user ct (XFileAcptInv sharedMsgId (Just fileInvConnReq) fileName) - -- [async agent commands] group XFileAcptInv continuation on receiving INV - CFCreateConnFileInvGroup -> case grpMemberId of - Just gMemberId -> do - GroupMember {groupId, activeConn} <- withStore $ \db -> getGroupMemberById db vr user gMemberId - case activeConn of - Just gMemberConn -> do - sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId - void $ sendDirectMemberMessage gMemberConn (XFileAcptInv sharedMsgId (Just fileInvConnReq) fileName) groupId - _ -> throwChatError $ CECommandError "no GroupMember activeConn" - _ -> throwChatError $ CECommandError "no grpMemberId" - _ -> throwChatError $ CECommandError "unexpected cmdFunction" - CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" - -- SMP CONF for RcvFileConnection happens for group file protocol - -- when sender of the file "joins" connection created by the recipient - -- (sender doesn't create connections for all group members) - CONF confId _pqSupport _ connInfo -> do - ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo - conn' <- updatePeerChatVRange conn chatVRange - case chatMsgEvent of - XOk -> allowAgentConnectionAsync user conn' confId XOk -- [async agent commands] no continuation needed, but command should be asynchronous for stability - _ -> pure () - CON _ -> startReceivingFile user fileId - MSG meta _ msgBody -> do - -- XXX: not all branches do ACK - parseFileChunk msgBody >>= receiveFileChunk ft (Just conn) meta - OK -> - -- [async agent commands] continuation on receiving OK - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - JOINED _ -> - -- [async agent commands] continuation on receiving JOINED - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - MERR _ err -> do - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - processConnMERR connEntity conn err - ERR err -> do - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - -- TODO add debugging output - _ -> pure () - - receiveFileChunk :: RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> CM () - receiveFileChunk ft@RcvFileTransfer {fileId, chunkSize} conn_ meta@MsgMeta {recipient = (msgId, _), integrity} = \case - FileChunkCancel -> - unless (rcvFileCompleteOrCancelled ft) $ do - cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) - ci <- withStore $ \db -> getChatItemByFileId db vr user fileId - toView $ CRRcvFileSndCancelled user ci ft - FileChunk {chunkNo, chunkBytes = chunk} -> do - case integrity of - MsgOk -> pure () - MsgError MsgDuplicate -> pure () -- TODO remove once agent removes duplicates - MsgError e -> - badRcvFileChunk ft $ "invalid file chunk number " <> show chunkNo <> ": " <> show e - withStore' (\db -> createRcvFileChunk db ft chunkNo msgId) >>= \case - RcvChunkOk -> - if B.length chunk /= fromInteger chunkSize - then badRcvFileChunk ft "incorrect chunk size" - else withAckMessage' "file msg" agentConnId meta $ appendFileChunk ft chunkNo chunk False - RcvChunkFinal -> - if B.length chunk > fromInteger chunkSize - then badRcvFileChunk ft "incorrect chunk size" - else do - appendFileChunk ft chunkNo chunk True - ci <- withStore $ \db -> do - liftIO $ do - updateRcvFileStatus db fileId FSComplete - updateCIFileStatus db user fileId CIFSRcvComplete - deleteRcvFileChunks db ft - getChatItemByFileId db vr user fileId - toView $ CRRcvFileComplete user ci - forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn) - RcvChunkDuplicate -> withAckMessage' "file msg" agentConnId meta $ pure () - RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo - - processUserContactRequest :: AEvent e -> ConnectionEntity -> Connection -> UserContact -> CM () - processUserContactRequest agentMsg connEntity conn UserContact {userContactLinkId} = case agentMsg of - REQ invId pqSupport _ connInfo -> do - ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo - case chatMsgEvent of - XContact p xContactId_ -> profileContactRequest invId chatVRange p xContactId_ pqSupport - XInfo p -> profileContactRequest invId chatVRange p Nothing pqSupport - -- TODO show/log error, other events in contact request - _ -> pure () - MERR _ err -> do - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - processConnMERR connEntity conn err - ERR err -> do - toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - -- TODO add debugging output - _ -> pure () - where - profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> PQSupport -> CM () - profileContactRequest invId chatVRange p xContactId_ reqPQSup = do - withStore (\db -> createOrUpdateContactRequest db vr user userContactLinkId invId chatVRange p xContactId_ reqPQSup) >>= \case - CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact - CORGroup gInfo -> toView $ CRBusinessRequestAlreadyAccepted user gInfo - CORRequest cReq -> do - ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId - let (UserContactLink {connReqContact, autoAccept}, groupId_, gLinkMemRole) = ucl - isSimplexTeam = sameConnReqContact connReqContact adminContactReq - v = maxVersion chatVRange - case autoAccept of - Just AutoAccept {acceptIncognito, businessAddress} - | businessAddress -> - if v < groupFastLinkJoinVersion || (isSimplexTeam && v < businessChatsVersion) - then do - ct <- acceptContactRequestAsync user cReq Nothing True reqPQSup - toView $ CRAcceptingContactRequest user ct - else do - gInfo <- acceptBusinessJoinRequestAsync user cReq - toView $ CRAcceptingBusinessRequest user gInfo - | otherwise -> case groupId_ of - Nothing -> do - -- [incognito] generate profile to send, create connection with incognito profile - incognitoProfile <- if acceptIncognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing - ct <- acceptContactRequestAsync user cReq incognitoProfile True reqPQSup - toView $ CRAcceptingContactRequest user ct - Just groupId -> do - gInfo <- withStore $ \db -> getGroupInfo db vr user groupId - let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo - if v >= groupFastLinkJoinVersion - then do - mem <- acceptGroupJoinRequestAsync user gInfo cReq gLinkMemRole profileMode - createInternalChatItem user (CDGroupRcv gInfo mem) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing - toView $ CRAcceptingGroupJoinRequestMember user gInfo mem - else do - -- TODO v5.7 remove old API (or v6.0?) - ct <- acceptContactRequestAsync user cReq profileMode False PQSupportOff - toView $ CRAcceptingGroupJoinRequest user gInfo ct - _ -> toView $ CRReceivedContactRequest user cReq - - memberCanSend :: GroupMember -> CM () -> CM () - memberCanSend GroupMember {memberRole} a - | memberRole <= GRObserver = messageError "member is not allowed to send messages" - | otherwise = a - - processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM () - processConnMERR connEntity conn err = do - case err of - SMP _ SMP.AUTH -> do - authErrCounter' <- withStore' $ \db -> incAuthErrCounter db user conn - when (authErrCounter' >= authErrDisableCount) $ case connEntity of - RcvDirectMsgConnection ctConn (Just ct) -> do - toView $ CRContactDisabled user ct {activeConn = Just ctConn {authErrCounter = authErrCounter'}} - _ -> toView $ CRConnectionDisabled connEntity - SMP _ SMP.QUOTA -> - unless (connInactive conn) $ do - withStore' $ \db -> setQuotaErrCounter db user conn quotaErrSetOnMERR - toView $ CRConnectionInactive connEntity True - _ -> pure () - - processConnMWARN :: ConnectionEntity -> Connection -> AgentErrorType -> CM () - processConnMWARN connEntity conn err = do - case err of - SMP _ SMP.QUOTA -> - unless (connInactive conn) $ do - quotaErrCounter' <- withStore' $ \db -> incQuotaErrCounter db user conn - when (quotaErrCounter' >= quotaErrInactiveCount) $ - toView $ - CRConnectionInactive connEntity True - _ -> pure () - - continueSending :: ConnectionEntity -> Connection -> CM Bool - continueSending connEntity conn = - if connInactive conn - then do - withStore' $ \db -> setQuotaErrCounter db user conn 0 - toView $ CRConnectionInactive connEntity False - pure True - else pure False - - -- TODO v5.7 / v6.0 - together with deprecating old group protocol establishing direct connections? - -- we could save command records only for agent APIs we process continuations for (INV) - withCompletedCommand :: forall e. AEntityI e => Connection -> AEvent e -> (CommandData -> CM ()) -> CM () - withCompletedCommand Connection {connId} agentMsg action = do - let agentMsgTag = AEvtTag (sAEntity @e) $ aEventTag agentMsg - cmdData_ <- withStore' $ \db -> getCommandDataByCorrId db user corrId - case cmdData_ of - Just cmdData@CommandData {cmdId, cmdConnId = Just cmdConnId', cmdFunction} - | connId == cmdConnId' && (agentMsgTag == commandExpectedResponse cmdFunction || agentMsgTag == AEvtTag SAEConn ERR_) -> do - withStore' $ \db -> deleteCommand db user cmdId - action cmdData - | otherwise -> err cmdId $ "not matching connection id or unexpected response, corrId = " <> show corrId - Just CommandData {cmdId, cmdConnId = Nothing} -> err cmdId $ "no command connection id, corrId = " <> show corrId - Nothing -> throwChatError . CEAgentCommandError $ "command not found, corrId = " <> show corrId - where - err cmdId msg = do - withStore' $ \db -> updateCommandStatus db user cmdId CSError - throwChatError . CEAgentCommandError $ msg - - withAckMessage' :: Text -> ConnId -> MsgMeta -> CM () -> CM () - withAckMessage' label cId msgMeta action = do - withAckMessage label cId msgMeta False Nothing $ \_ -> action $> False - - withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe (TVar [Text]) -> (Text -> CM Bool) -> CM () - withAckMessage label cId msgMeta showCritical tags action = do - -- [async agent commands] command should be asynchronous - -- TODO catching error and sending ACK after an error, particularly if it is a database error, will result in the message not processed (and no notification to the user). - -- Possible solutions are: - -- 1) retry processing several times - -- 2) stabilize database - -- 3) show screen of death to the user asking to restart - eInfo <- eventInfo - logInfo $ label <> ": " <> eInfo - tryChatError (action eInfo) >>= \case - Right withRcpt -> - withLog (eInfo <> " ok") $ ackMsg msgMeta $ if withRcpt then Just "" else Nothing - -- If showCritical is True, then these errors don't result in ACK and show user visible alert - -- This prevents losing the message that failed to be processed. - Left (ChatErrorStore SEDBBusyError {message}) | showCritical -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing - Left e -> do - withLog (eInfo <> " error: " <> tshow e) $ ackMsg msgMeta Nothing - throwError e - where - eventInfo = do - v <- asks eventSeq - eId <- atomically $ stateTVar v $ \i -> (i + 1, i + 1) - pure $ "conn_id=" <> tshow cId <> " event_id=" <> tshow eId - withLog eInfo' ack = do - ts <- showTags - logInfo $ T.unwords [label, "ack:", ts, eInfo'] - ack - logInfo $ T.unwords [label, "ack=success:", ts, eInfo'] - showTags = do - ts <- maybe (pure []) readTVarIO tags - pure $ case ts of - [] -> "no_chat_messages" - [t] -> "chat_message=" <> t - _ -> "chat_message_batch=" <> T.intercalate "," (reverse ts) - ackMsg :: MsgMeta -> Maybe MsgReceiptInfo -> CM () - ackMsg MsgMeta {recipient = (msgId, _)} rcpt = withAgent $ \a -> ackMessageAsync a "" cId msgId rcpt - - sentMsgDeliveryEvent :: Connection -> AgentMsgId -> CM () - sentMsgDeliveryEvent Connection {connId} msgId = - withStore' $ \db -> updateSndMsgDeliveryStatus db connId msgId MDSSndSent - - agentSndError :: AgentErrorType -> SndError - agentSndError = \case - SMP _ AUTH -> SndErrAuth - SMP _ QUOTA -> SndErrQuota - BROKER _ e -> brokerError SndErrRelay e - SMP proxySrv (SMP.PROXY (SMP.BROKER e)) -> brokerError (SndErrProxy proxySrv) e - AP.PROXY proxySrv _ (ProxyProtocolError (SMP.PROXY (SMP.BROKER e))) -> brokerError (SndErrProxyRelay proxySrv) e - e -> SndErrOther $ tshow e - where - brokerError srvErr = \case - NETWORK -> SndErrExpired - TIMEOUT -> SndErrExpired - HOST -> srvErr SrvErrHost - SMP.TRANSPORT TEVersion -> srvErr SrvErrVersion - e -> srvErr . SrvErrOther $ tshow e - - badRcvFileChunk :: RcvFileTransfer -> String -> CM () - badRcvFileChunk ft err = - unless (rcvFileCompleteOrCancelled ft) $ do - cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) - throwChatError $ CEFileRcvChunk err - - memberConnectedChatItem :: GroupInfo -> GroupMember -> CM () - memberConnectedChatItem gInfo m = - -- ts should be broker ts but we don't have it for CON - createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEMemberConnected) Nothing - - groupDescriptionChatItem :: GroupInfo -> GroupMember -> Text -> CM () - groupDescriptionChatItem gInfo m descr = - createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvMsgContent $ MCText descr) Nothing - - notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> CM () - notifyMemberConnected gInfo m ct_ = do - memberConnectedChatItem gInfo m - lift $ mapM_ (`setContactNetworkStatus` NSConnected) ct_ - toView $ CRConnectedToGroupMember user gInfo m ct_ - - probeMatchingContactsAndMembers :: Contact -> IncognitoEnabled -> Bool -> CM () - probeMatchingContactsAndMembers ct connectedIncognito doProbeContacts = do - gVar <- asks random - contactMerge <- readTVarIO =<< asks contactMergeEnabled - if contactMerge && not connectedIncognito - then do - (probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId (COMContact ct) - -- ! when making changes to probe-and-merge mechanism, - -- ! test scenario in which recipient receives probe after probe hashes (not covered in tests): - -- sendProbe -> sendProbeHashes (currently) - -- sendProbeHashes -> sendProbe (reversed - change order in code, may add delay) - sendProbe probe - cs <- - if doProbeContacts - then map COMContact <$> withStore' (\db -> getMatchingContacts db vr user ct) - else pure [] - ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db vr user ct) - sendProbeHashes (cs <> ms) probe probeId - else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32) - where - sendProbe :: Probe -> CM () - sendProbe probe = void . sendDirectContactMessage user ct $ XInfoProbe probe - - probeMatchingMemberContact :: GroupMember -> IncognitoEnabled -> CM () - probeMatchingMemberContact GroupMember {activeConn = Nothing} _ = pure () - probeMatchingMemberContact m@GroupMember {groupId, activeConn = Just conn} connectedIncognito = do - gVar <- asks random - contactMerge <- readTVarIO =<< asks contactMergeEnabled - if contactMerge && not connectedIncognito - then do - (probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId $ COMGroupMember m - sendProbe probe - cs <- map COMContact <$> withStore' (\db -> getMatchingMemberContacts db vr user m) - sendProbeHashes cs probe probeId - else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32) - where - sendProbe :: Probe -> CM () - sendProbe probe = void $ sendDirectMemberMessage conn (XInfoProbe probe) groupId - - sendProbeHashes :: [ContactOrMember] -> Probe -> Int64 -> CM () - sendProbeHashes cgms probe probeId = - forM_ cgms $ \cgm -> sendProbeHash cgm `catchChatError` \_ -> pure () - where - probeHash = ProbeHash $ C.sha256Hash (unProbe probe) - sendProbeHash :: ContactOrMember -> CM () - sendProbeHash cgm@(COMContact c) = do - void . sendDirectContactMessage user c $ XInfoProbeCheck probeHash - withStore' $ \db -> createSentProbeHash db userId probeId cgm - sendProbeHash (COMGroupMember GroupMember {activeConn = Nothing}) = pure () - sendProbeHash cgm@(COMGroupMember m@GroupMember {groupId, activeConn = Just conn}) = - when (memberCurrent m) $ do - void $ sendDirectMemberMessage conn (XInfoProbeCheck probeHash) groupId - withStore' $ \db -> createSentProbeHash db userId probeId cgm - - messageWarning :: Text -> CM () - messageWarning = toView . CRMessageError user "warning" - - messageError :: Text -> CM () - messageError = toView . CRMessageError user "error" - - newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM () - newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do - unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct - let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc - -- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete - -- case content of - -- MCText "hello 111" -> - -- UE.throwIO $ userError "#####################" - -- -- throwChatError $ CECommandError "#####################" - -- _ -> pure () - if isVoice content && not (featureAllowed SCFVoice forContact ct) - then do - void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False - 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 - newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live - autoAcceptFile file_ - where - brokerTs = metaBrokerTs msgMeta - newChatItem ciContent ciFile_ timed_ live = do - ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live - reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_ - toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions}] - - autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM () - autoAcceptFile = mapM_ $ \(ft, CIFile {fileSize}) -> do - -- ! autoAcceptFileSize is only used in tests - ChatConfig {autoAcceptFileSize = sz} <- asks config - when (sz > fileSize) $ receiveFile' user ft False Nothing Nothing >>= toView - - messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> CM () - messageFileDescription ct@Contact {contactId} sharedMsgId fileDescr = do - fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId - processFDMessage (CDDirectRcv ct) sharedMsgId fileId fileDescr - - groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM () - groupMessageFileDescription g@GroupInfo {groupId} m sharedMsgId fileDescr = do - fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId - processFDMessage (CDGroupRcv g m) sharedMsgId fileId fileDescr - - processFDMessage :: ChatTypeQuotable c => ChatDirection c 'MDRcv -> SharedMsgId -> FileTransferId -> FileDescr -> CM () - processFDMessage cd sharedMsgId fileId fileDescr = do - ft <- withStore $ \db -> getRcvFileTransfer db user fileId - unless (rcvFileCompleteOrCancelled ft) $ do - (rfd@RcvFileDescr {fileDescrComplete}, ft'@RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs}) <- withStore $ \db -> do - rfd <- appendRcvFD db userId fileId fileDescr - -- reading second time in the same transaction as appending description - -- to prevent race condition with accept - ft' <- getRcvFileTransfer db user fileId - pure (rfd, ft') - when fileDescrComplete $ do - ci <- withStore $ \db -> getAChatItemBySharedMsgId db user cd sharedMsgId - toView $ CRRcvFileDescrReady user ci ft' rfd - case (fileStatus, xftpRcvFile) of - (RFSAccepted _, Just XFTPRcvFile {userApprovedRelays}) -> receiveViaCompleteFD user fileId rfd userApprovedRelays cryptoArgs - _ -> pure () - - processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv)) - processFileInvitation fInv_ mc createRcvFT = forM fInv_ $ \fInv' -> do - ChatConfig {fileChunkSize} <- asks config - let fInv@FileInvitation {fileName, fileSize} = mkValidFileInvitation fInv' - inline <- receiveInlineMode fInv (Just mc) fileChunkSize - ft@RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFT db fInv inline fileChunkSize - let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP - (filePath, fileStatus, ft') <- case inline of - Just IFMSent -> do - encrypt <- chatReadVar encryptLocalFiles - ft' <- (if encrypt then setFileToEncrypt else pure) ft - fPath <- getRcvFilePath fileId Nothing fileName True - withStore' $ \db -> startRcvInlineFT db user ft' fPath inline - pure (Just fPath, CIFSRcvAccepted, ft') - _ -> pure (Nothing, CIFSRcvInvitation, ft) - let RcvFileTransfer {cryptoArgs} = ft' - fileSource = (`CryptoFile` cryptoArgs) <$> filePath - pure (ft', CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol}) - - mkValidFileInvitation :: FileInvitation -> FileInvitation - mkValidFileInvitation fInv@FileInvitation {fileName} = fInv {fileName = FP.makeValid $ FP.takeFileName fileName} - - messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> CM () - messageUpdate ct@Contact {contactId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do - 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). - -- Chat item and update message which created it will have different sharedMsgId in this case... - let timed_ = rcvContactCITimed ct ttl - ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs content Nothing timed_ live - ci' <- withStore' $ \db -> do - createChatItemVersion db (chatItemId' ci) brokerTs mc - updateDirectChatItem' db user contactId ci content True live Nothing Nothing - toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci') - where - brokerTs = metaBrokerTs msgMeta - content = CIRcvMsgContent mc - live = fromMaybe False live_ - updateRcvChatItem = do - cci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId - case cci of - CChatItem SMDRcv ci@ChatItem {meta = CIMeta {itemForwarded, itemLive}, content = CIRcvMsgContent oldMC} - | isNothing itemForwarded -> do - let changed = mc /= oldMC - if changed || fromMaybe False itemLive - then do - ci' <- withStore' $ \db -> do - when changed $ - addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc) - reactions <- getDirectCIReactions db ct sharedMsgId - let edited = itemLive /= Just True - updateDirectChatItem' db user contactId ci {reactions} content edited live Nothing $ Just msgId - toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci') - startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci' - else toView $ CRChatItemNotChanged user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) - _ -> messageError "x.msg.update: contact attempted invalid message update" - - messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> CM () - messageDelete ct@Contact {contactId} sharedMsgId _rcvMessage msgMeta = do - deleteRcvChatItem `catchCINotFound` (toView . CRChatItemDeletedNotFound user ct) - where - brokerTs = metaBrokerTs msgMeta - deleteRcvChatItem = do - cci@(CChatItem msgDir ci) <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId - case msgDir of - SMDRcv - | rcvItemDeletable ci brokerTs -> - if featureAllowed SCFFullDelete forContact ct - then deleteDirectCIs user ct [cci] False False >>= toView - else markDirectCIsDeleted user ct [cci] False brokerTs >>= toView - | otherwise -> messageError "x.msg.del: contact attempted invalid message delete" - SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete" - - rcvItemDeletable :: ChatItem c d -> UTCTime -> Bool - rcvItemDeletable ChatItem {meta = CIMeta {itemTs, itemDeleted}} brokerTs = - -- 78 hours margin to account for possible sending delay - diffUTCTime brokerTs itemTs < (78 * 3600) && isNothing itemDeleted - - directMsgReaction :: Contact -> SharedMsgId -> MsgReaction -> Bool -> RcvMessage -> MsgMeta -> CM () - directMsgReaction ct sharedMsgId reaction add RcvMessage {msgId} MsgMeta {broker = (_, brokerTs)} = do - when (featureAllowed SCFReactions forContact ct) $ do - rs <- withStore' $ \db -> getDirectReactions db ct sharedMsgId False - when (reactionAllowed add reaction rs) $ do - updateChatItemReaction `catchCINotFound` \_ -> - withStore' $ \db -> setDirectReaction db ct sharedMsgId False reaction add msgId brokerTs - where - updateChatItemReaction = do - cr_ <- withStore $ \db -> do - CChatItem md ci <- getDirectChatItemBySharedMsgId db user (contactId' ct) sharedMsgId - if ciReactionAllowed ci - then liftIO $ do - setDirectReaction db ct sharedMsgId False reaction add msgId brokerTs - reactions <- getDirectCIReactions db ct sharedMsgId - let ci' = CChatItem md ci {reactions} - r = ACIReaction SCTDirect SMDRcv (DirectChat ct) $ CIReaction CIDirectRcv ci' brokerTs reaction - pure $ Just $ CRChatItemReaction user add r - else pure Nothing - mapM_ toView cr_ - - groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM () - groupMsgReaction g@GroupInfo {groupId} m sharedMsgId itemMemberId reaction add RcvMessage {msgId} brokerTs = do - when (groupFeatureAllowed SGFReactions g) $ do - rs <- withStore' $ \db -> getGroupReactions db g m itemMemberId sharedMsgId False - when (reactionAllowed add reaction rs) $ do - updateChatItemReaction `catchCINotFound` \_ -> - withStore' $ \db -> setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs - where - updateChatItemReaction = do - cr_ <- withStore $ \db -> do - CChatItem md ci <- getGroupMemberCIBySharedMsgId db user groupId itemMemberId sharedMsgId - if ciReactionAllowed ci - then liftIO $ do - setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs - reactions <- getGroupCIReactions db g itemMemberId sharedMsgId - let ci' = CChatItem md ci {reactions} - r = ACIReaction SCTGroup SMDRcv (GroupChat g) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction - pure $ Just $ CRChatItemReaction user add r - else pure Nothing - mapM_ toView cr_ - - reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool - reactionAllowed add reaction rs = (reaction `elem` rs) /= add && not (add && length rs >= maxMsgReactions) - - catchCINotFound :: CM a -> (SharedMsgId -> CM a) -> CM a - catchCINotFound f handle = - f `catchChatError` \case - ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId - e -> throwError e - - newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM () - newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded - | blockedByAdmin m = createBlockedByAdmin - | otherwise = case prohibitedGroupContent gInfo m content fInv_ of - Just f -> rejected f - Nothing -> - withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case - Just ciModeration -> do - applyModeration ciModeration - withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_ - Nothing -> createContentItem - where - rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False - timed' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo itemTTL - live' = fromMaybe False live_ - ExtMsgContent content fInv_ itemTTL live_ = mcExtMsgContent mc - createBlockedByAdmin - | groupFeatureAllowed SGFFullDelete gInfo = do - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvBlocked Nothing timed' False - ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo ci brokerTs - groupMsgToView gInfo ci' - | otherwise = do - file_ <- processFileInv - ci <- createNonLive file_ - ci' <- withStore' $ \db -> markGroupCIBlockedByAdmin db user gInfo ci - groupMsgToView gInfo ci' - applyModeration CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt} - | moderatorRole < GRAdmin || moderatorRole < memberRole = - createContentItem - | groupFeatureAllowed SGFFullDelete gInfo = do - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvModerated Nothing timed' False - ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt - groupMsgToView gInfo ci' - | otherwise = do - file_ <- processFileInv - ci <- createNonLive file_ - toView =<< markGroupCIsDeleted user gInfo [CChatItem SMDRcv ci] False (Just moderator) moderatedAt - createNonLive file_ = - saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed' False - createContentItem = do - file_ <- processFileInv - newChatItem (CIRcvMsgContent content) (snd <$> file_) timed' live' - when (showMessages $ memberSettings m) $ autoAcceptFile file_ - processFileInv = - processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m - newChatItem ciContent ciFile_ timed_ live = do - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs 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 ci' {reactions} - - groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM () - groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} brokerTs ttl_ live_ - | prohibitedSimplexLinks gInfo m mc = - messageWarning $ "x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks - | otherwise = do - 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). - -- Chat item and update message which created it will have different sharedMsgId in this case... - let timed_ = rcvGroupCITimed gInfo ttl_ - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs content Nothing timed_ live - ci' <- withStore' $ \db -> do - createChatItemVersion db (chatItemId' ci) brokerTs mc - ci' <- updateGroupChatItem db user groupId ci content True live Nothing - blockedMember m ci' $ markGroupChatItemBlocked db user gInfo ci' - toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci') - where - content = CIRcvMsgContent mc - live = fromMaybe False live_ - updateRcvChatItem = do - cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId - case cci of - CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} -> - if sameMemberId memberId m' - then do - let changed = mc /= oldMC - if changed || fromMaybe False itemLive - then do - ci' <- withStore' $ \db -> do - when changed $ - addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc) - reactions <- getGroupCIReactions db gInfo memberId sharedMsgId - let edited = itemLive /= Just True - updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId - toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci') - 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" - _ -> messageError "x.msg.update: group member attempted invalid message update" - - groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> UTCTime -> CM () - groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} brokerTs = do - let msgMemberId = fromMaybe memberId sndMemberId_ - withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case - Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of - CIGroupRcv mem -> case sndMemberId_ of - -- regular deletion - Nothing - | sameMemberId memberId mem && msgMemberId == memberId && rcvItemDeletable ci brokerTs -> - delete cci Nothing >>= toView - | otherwise -> - messageError "x.msg.del: member attempted invalid message delete" - -- moderation (not limited by time) - Just _ - | sameMemberId memberId mem && msgMemberId == memberId -> - delete cci (Just m) >>= toView - | otherwise -> - moderate mem cci - CIGroupSnd -> moderate membership cci - Left e - | msgMemberId == memberId -> messageError $ "x.msg.del: message not found, " <> tshow e - | 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 - moderate :: GroupMember -> CChatItem 'CTGroup -> CM () - moderate mem cci = case sndMemberId_ of - Just sndMemberId - | sameMemberId sndMemberId mem -> checkRole mem $ delete cci (Just m) >>= toView - | otherwise -> messageError "x.msg.del: message of another member with incorrect memberId" - _ -> messageError "x.msg.del: message of another member without memberId" - checkRole GroupMember {memberRole} a - | senderRole < GRAdmin || senderRole < memberRole = - messageError "x.msg.del: message of another member with insufficient member permissions" - | otherwise = a - delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM ChatResponse - delete cci byGroupMember - | groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCIs user gInfo [cci] False False byGroupMember brokerTs - | otherwise = markGroupCIsDeleted user gInfo [cci] False byGroupMember brokerTs - - -- TODO remove once XFile is discontinued - processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> CM () - processFileInvitation' ct fInv' msg@RcvMessage {sharedMsgId_} msgMeta = do - ChatConfig {fileChunkSize} <- asks config - let fInv@FileInvitation {fileName, fileSize} = mkValidFileInvitation fInv' - inline <- receiveInlineMode fInv Nothing fileChunkSize - RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct 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 (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False - toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] - where - brokerTs = metaBrokerTs msgMeta - - -- TODO remove once XFile is discontinued - processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> UTCTime -> CM () - processGroupFileInvitation' gInfo m fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} brokerTs = 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_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False - ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci - groupMsgToView gInfo ci' - - 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 -> CM (Maybe InlineFileMode) - receiveInlineMode FileInvitation {fileSize, fileInline, fileDescr} mc_ chSize = case (fileInline, fileDescr) of - (Just mode, Nothing) -> do - InlineFilesConfig {receiveChunks, receiveInstant} <- asks $ inlineFiles . config - pure $ if fileSize <= receiveChunks * chSize then inline' receiveInstant else Nothing - where - inline' receiveInstant = if mode == IFMOffer || (receiveInstant && maybe False isVoice mc_) then fileInline else Nothing - _ -> pure Nothing - - xFileCancel :: Contact -> SharedMsgId -> CM () - xFileCancel Contact {contactId} sharedMsgId = do - fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId - ft <- withStore (\db -> getRcvFileTransfer db user fileId) - unless (rcvFileCompleteOrCancelled ft) $ do - cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) - ci <- withStore $ \db -> getChatItemByFileId db vr user fileId - toView $ CRRcvFileSndCancelled user ci ft - - xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM () - xFileAcptInv ct sharedMsgId fileConnReq_ fName = do - fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId - (AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId - assertSMPAcceptNotProhibited ci - ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId) - -- [async agent commands] no continuation needed, but command should be asynchronous for stability - if fName == fileName - then unless cancelled $ case fileConnReq_ of - -- receiving via a separate connection - Just fileConnReq -> do - subMode <- chatReadVar subscriptionMode - dm <- encodeConnInfo XOk - connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode - withStore' $ \db -> createSndDirectFTConnection db vr user fileId connIds subMode - -- receiving inline - _ -> do - event <- withStore $ \db -> do - ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1 - sft <- createSndDirectInlineFT db ct ft - pure $ CRSndFileStart user ci' sft - toView event - ifM - (allowSendInline fileSize fileInline) - (sendDirectFileInline user ct ft sharedMsgId) - (messageError "x.file.acpt.inv: fileSize is bigger than allowed to send inline") - else messageError "x.file.acpt.inv: fileName is different from expected" - - assertSMPAcceptNotProhibited :: ChatItem c d -> CM () - assertSMPAcceptNotProhibited ChatItem {file = Just CIFile {fileId, fileProtocol}, content} - | fileProtocol == FPXFTP && not (imageOrVoice content) = throwChatError $ CEFallbackToSMPProhibited fileId - | otherwise = pure () - where - imageOrVoice :: CIContent d -> Bool - imageOrVoice (CISndMsgContent (MCImage _ _)) = True - imageOrVoice (CISndMsgContent (MCVoice _ _)) = True - imageOrVoice _ = False - assertSMPAcceptNotProhibited _ = pure () - - checkSndInlineFTComplete :: Connection -> AgentMsgId -> CM () - checkSndInlineFTComplete conn agentMsgId = do - sft_ <- withStore' $ \db -> getSndFTViaMsgDelivery db user conn agentMsgId - forM_ sft_ $ \sft@SndFileTransfer {fileId} -> do - ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do - liftIO $ updateSndFileStatus db sft FSComplete - liftIO $ deleteSndFileChunks db sft - updateDirectCIFileStatus db vr user fileId CIFSSndComplete - case file of - Just CIFile {fileProtocol = FPXFTP} -> do - ft <- withStore $ \db -> getFileTransferMeta db user fileId - toView $ CRSndFileCompleteXFTP user ci ft - _ -> toView $ CRSndFileComplete user ci sft - - allowSendInline :: Integer -> Maybe InlineFileMode -> CM Bool - allowSendInline fileSize = \case - Just IFMOffer -> do - ChatConfig {fileChunkSize, inlineFiles} <- asks config - pure $ fileSize <= fileChunkSize * offerChunks inlineFiles - _ -> pure False - - bFileChunk :: Contact -> SharedMsgId -> FileChunk -> MsgMeta -> CM () - bFileChunk ct sharedMsgId chunk meta = do - ft <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId >>= getRcvFileTransfer db user - receiveInlineChunk ft chunk meta - - bFileChunkGroup :: GroupInfo -> SharedMsgId -> FileChunk -> MsgMeta -> CM () - bFileChunkGroup GroupInfo {groupId} sharedMsgId chunk meta = do - ft <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId >>= getRcvFileTransfer db user - receiveInlineChunk ft chunk meta - - receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> CM () - receiveInlineChunk RcvFileTransfer {fileId, fileStatus = RFSNew} FileChunk {chunkNo} _ - | chunkNo == 1 = throwChatError $ CEInlineFileProhibited fileId - | otherwise = pure () - receiveInlineChunk ft@RcvFileTransfer {fileId} chunk meta = do - case chunk of - FileChunk {chunkNo} -> when (chunkNo == 1) $ startReceivingFile user fileId - _ -> pure () - receiveFileChunk ft Nothing meta chunk - - xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM () - xFileCancelGroup GroupInfo {groupId} GroupMember {groupMemberId, memberId} sharedMsgId = do - fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId - CChatItem msgDir ChatItem {chatDir} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId - case (msgDir, chatDir) of - (SMDRcv, CIGroupRcv m) -> do - if sameMemberId memberId m - then do - ft <- withStore (\db -> getRcvFileTransfer db user fileId) - unless (rcvFileCompleteOrCancelled ft) $ do - cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) - ci <- withStore $ \db -> getChatItemByFileId db vr user fileId - toView $ CRRcvFileSndCancelled user ci ft - else messageError "x.file.cancel: group member attempted to cancel file of another member" -- shouldn't happen now that query includes group member id - (SMDSnd, _) -> messageError "x.file.cancel: group member attempted invalid file cancel" - - xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM () - xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do - fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId - (AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId - assertSMPAcceptNotProhibited ci - -- TODO check that it's not already accepted - ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId) - if fName == fileName - then unless cancelled $ case (fileConnReq_, activeConn) of - (Just fileConnReq, _) -> do - subMode <- chatReadVar subscriptionMode - -- receiving via a separate connection - -- [async agent commands] no continuation needed, but command should be asynchronous for stability - dm <- encodeConnInfo XOk - connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode - withStore' $ \db -> createSndGroupFileTransferConnection db vr user fileId connIds m subMode - (_, Just conn) -> do - -- receiving inline - event <- withStore $ \db -> do - ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1 - sft <- liftIO $ createSndGroupInlineFT db m conn ft - pure $ CRSndFileStart user ci' sft - toView event - ifM - (allowSendInline fileSize fileInline) - (sendMemberFileInline m conn ft sharedMsgId) - (messageError "x.file.acpt.inv: fileSize is bigger than allowed to send inline") - _ -> messageError "x.file.acpt.inv: member connection is not active" - else messageError "x.file.acpt.inv: fileName is different from expected" - - groupMsgToView :: forall d. MsgDirectionI d => GroupInfo -> ChatItem 'CTGroup d -> CM () - groupMsgToView gInfo ci = - toView $ CRNewChatItems user [AChatItem SCTGroup (msgDirection @d) (GroupChat gInfo) ci] - - processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> CM () - processGroupInvitation ct inv msg msgMeta = do - let Contact {localDisplayName = c, activeConn} = ct - GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), invitedMember = (MemberIdRole memId memRole), connRequest, groupLinkId} = inv - forM_ activeConn $ \Connection {connId, connChatVersion, peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'} -> do - when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c) - when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId - -- [incognito] if direct connection with host is incognito, create membership using the same incognito profile - (gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId - let GroupMember {groupMemberId, memberId = membershipMemId} = membership - if sameGroupLinkId groupLinkId groupLinkId' - then do - subMode <- chatReadVar subscriptionMode - dm <- encodeConnInfo $ XGrpAcpt membershipMemId - connIds <- joinAgentConnectionAsync user True connRequest dm subMode - withStore' $ \db -> do - setViaGroupLinkHash db groupId connId - createMemberConnectionAsync db user hostId connIds connChatVersion peerChatVRange subMode - updateGroupMemberStatusById db userId hostId GSMemAccepted - updateGroupMemberStatus db userId membership GSMemAccepted - toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct) - else do - let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole - ci <- saveRcvChatItem user (CDDirectRcv ct) msg brokerTs content - withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci) - toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] - toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole} - where - brokerTs = metaBrokerTs msgMeta - sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool - sameGroupLinkId (Just gli) (Just gli') = gli == gli' - sameGroupLinkId _ _ = False - - checkIntegrityCreateItem :: forall c. ChatTypeI c => ChatDirection c 'MDRcv -> MsgMeta -> CM () - checkIntegrityCreateItem cd MsgMeta {integrity, broker = (_, brokerTs)} = case integrity of - MsgOk -> pure () - MsgError e -> createInternalChatItem user cd (CIRcvIntegrityError e) (Just brokerTs) - - xInfo :: Contact -> Profile -> CM () - xInfo c p' = void $ processContactProfileUpdate c p' True - - xDirectDel :: Contact -> RcvMessage -> MsgMeta -> CM () - xDirectDel c msg msgMeta = - if directOrUsed c - then do - ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted - contactConns <- withStore' $ \db -> getContactConnections db vr userId ct' - deleteAgentConnectionsAsync user $ map aConnId contactConns - forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted - activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted} - let ct'' = ct' {activeConn = activeConn'} :: Contact - ci <- saveRcvChatItem user (CDDirectRcv ct'') msg brokerTs (CIRcvDirectEvent RDEContactDeleted) - toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct'') ci] - toView $ CRContactDeletedByContact user ct'' - else do - contactConns <- withStore' $ \db -> getContactConnections db vr userId c - deleteAgentConnectionsAsync user $ map aConnId contactConns - withStore $ \db -> deleteContact db user c - where - brokerTs = metaBrokerTs msgMeta - - processContactProfileUpdate :: Contact -> Profile -> Bool -> CM Contact - processContactProfileUpdate c@Contact {profile = lp} p' createItems - | p /= p' = do - c' <- withStore $ \db -> - if userTTL == rcvTTL - then updateContactProfile db user c p' - else do - c' <- liftIO $ updateContactUserPreferences db user c ctUserPrefs' - updateContactProfile db user c' p' - when (directOrUsed c' && createItems) $ do - createProfileUpdatedItem c' - lift $ createRcvFeatureItems user c c' - toView $ CRContactUpdated user c c' - pure c' - | otherwise = - pure c - where - p = fromLocalProfile lp - Contact {userPreferences = ctUserPrefs@Preferences {timedMessages = ctUserTMPref}} = c - userTTL = prefParam $ getPreference SCFTimedMessages ctUserPrefs - Profile {preferences = rcvPrefs_} = p' - rcvTTL = prefParam $ getPreference SCFTimedMessages rcvPrefs_ - ctUserPrefs' = - let userDefault = getPreference SCFTimedMessages (fullPreferences user) - userDefaultTTL = prefParam userDefault - ctUserTMPref' = case ctUserTMPref of - Just userTM -> Just (userTM :: TimedMessagesPreference) {ttl = rcvTTL} - _ - | rcvTTL /= userDefaultTTL -> Just (userDefault :: TimedMessagesPreference) {ttl = rcvTTL} - | otherwise -> Nothing - in setPreference_ SCFTimedMessages ctUserTMPref' ctUserPrefs - createProfileUpdatedItem c' = - when visibleProfileUpdated $ do - let ciContent = CIRcvDirectEvent $ RDEProfileUpdated p p' - createInternalChatItem user (CDDirectRcv c') ciContent Nothing - where - visibleProfileUpdated = - n' /= n || fn' /= fn || i' /= i || cl' /= cl - Profile {displayName = n, fullName = fn, image = i, contactLink = cl} = p - Profile {displayName = n', fullName = fn', image = i', contactLink = cl'} = p' - - xInfoMember :: GroupInfo -> GroupMember -> Profile -> UTCTime -> CM () - xInfoMember gInfo m p' brokerTs = void $ processMemberProfileUpdate gInfo m p' True (Just brokerTs) - - xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM () - xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do - xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId - if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived - then do - m' <- processMemberProfileUpdate gInfo m p' False Nothing - withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True - let connectedIncognito = memberIncognito membership - probeMatchingMemberContact m' connectedIncognito - else messageError "x.grp.link.mem error: invalid group link host profile update" - - processMemberProfileUpdate :: GroupInfo -> GroupMember -> Profile -> Bool -> Maybe UTCTime -> CM GroupMember - processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} p' createItems itemTs_ - | redactedMemberProfile (fromLocalProfile p) /= redactedMemberProfile p' = do - updateBusinessChatProfile gInfo - case memberContactId of - Nothing -> do - m' <- withStore $ \db -> updateMemberProfile db user m p' - createProfileUpdatedItem m' - toView $ CRGroupMemberUpdated user gInfo m m' - pure m' - Just mContactId -> do - mCt <- withStore $ \db -> getContact db vr user mContactId - if canUpdateProfile mCt - then do - (m', ct') <- withStore $ \db -> updateContactMemberProfile db user m mCt p' - createProfileUpdatedItem m' - toView $ CRGroupMemberUpdated user gInfo m m' - toView $ CRContactUpdated user mCt ct' - pure m' - else pure m - where - canUpdateProfile ct - | not (contactActive ct) = True - | otherwise = case contactConn ct of - Nothing -> True - Just conn -> not (connReady conn) || (authErrCounter conn >= 1) - | otherwise = - pure m - where - updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of - Just bc | isMainBusinessMember bc m -> do - g' <- withStore $ \db -> updateGroupProfileFromMember db user g p' - toView $ CRGroupUpdated user g g' (Just m) - _ -> pure () - isMainBusinessMember BusinessChatInfo {chatType, businessId, customerId} GroupMember {memberId} = case chatType of - BCBusiness -> businessId == memberId - BCCustomer -> customerId == memberId - createProfileUpdatedItem m' = - when createItems $ do - let ciContent = CIRcvGroupEvent $ RGEMemberProfileUpdated (fromLocalProfile p) p' - createInternalChatItem user (CDGroupRcv gInfo m') ciContent itemTs_ - - createFeatureEnabledItems :: Contact -> CM () - createFeatureEnabledItems ct@Contact {mergedPreferences} = - forM_ allChatFeatures $ \(ACF f) -> do - let state = featureState $ getContactUserPreference f mergedPreferences - createInternalChatItem user (CDDirectRcv ct) (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing - - xInfoProbe :: ContactOrMember -> Probe -> CM () - xInfoProbe cgm2 probe = do - contactMerge <- readTVarIO =<< asks contactMergeEnabled - -- [incognito] unless connected incognito - when (contactMerge && not (contactOrMemberIncognito cgm2)) $ do - cgm1s <- withStore' $ \db -> matchReceivedProbe db vr user cgm2 probe - let cgm1s' = filter (not . contactOrMemberIncognito) cgm1s - probeMatches cgm1s' cgm2 - where - probeMatches :: [ContactOrMember] -> ContactOrMember -> CM () - probeMatches [] _ = pure () - probeMatches (cgm1' : cgm1s') cgm2' = do - cgm2''_ <- probeMatch cgm1' cgm2' probe `catchChatError` \_ -> pure (Just cgm2') - let cgm2'' = fromMaybe cgm2' cgm2''_ - probeMatches cgm1s' cgm2'' - - xInfoProbeCheck :: ContactOrMember -> ProbeHash -> CM () - xInfoProbeCheck cgm1 probeHash = do - contactMerge <- readTVarIO =<< asks contactMergeEnabled - -- [incognito] unless connected incognito - when (contactMerge && not (contactOrMemberIncognito cgm1)) $ do - cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db vr user cgm1 probeHash - forM_ cgm2Probe_ $ \(cgm2, probe) -> - unless (contactOrMemberIncognito cgm2) . void $ - probeMatch cgm1 cgm2 probe - - probeMatch :: ContactOrMember -> ContactOrMember -> Probe -> CM (Maybe ContactOrMember) - probeMatch cgm1 cgm2 probe = - case cgm1 of - COMContact c1@Contact {contactId = cId1, profile = p1} -> - case cgm2 of - COMContact c2@Contact {contactId = cId2, profile = p2} - | cId1 /= cId2 && profilesMatch p1 p2 -> do - void . sendDirectContactMessage user c1 $ XInfoProbeOk probe - COMContact <$$> mergeContacts c1 c2 - | otherwise -> messageWarning "probeMatch ignored: profiles don't match or same contact id" >> pure Nothing - COMGroupMember m2@GroupMember {memberProfile = p2, memberContactId} - | isNothing memberContactId && profilesMatch p1 p2 -> do - void . sendDirectContactMessage user c1 $ XInfoProbeOk probe - COMContact <$$> associateMemberAndContact c1 m2 - | otherwise -> messageWarning "probeMatch ignored: profiles don't match or member already has contact" >> pure Nothing - COMGroupMember GroupMember {activeConn = Nothing} -> pure Nothing - COMGroupMember m1@GroupMember {groupId, memberProfile = p1, memberContactId, activeConn = Just conn} -> - case cgm2 of - COMContact c2@Contact {profile = p2} - | memberCurrent m1 && isNothing memberContactId && profilesMatch p1 p2 -> do - void $ sendDirectMemberMessage conn (XInfoProbeOk probe) groupId - COMContact <$$> associateMemberAndContact c2 m1 - | otherwise -> messageWarning "probeMatch ignored: profiles don't match or member already has contact or member not current" >> pure Nothing - COMGroupMember _ -> messageWarning "probeMatch ignored: members are not matched with members" >> pure Nothing - - xInfoProbeOk :: ContactOrMember -> Probe -> CM () - xInfoProbeOk cgm1 probe = do - cgm2 <- withStore' $ \db -> matchSentProbe db vr user cgm1 probe - case cgm1 of - COMContact c1@Contact {contactId = cId1} -> - case cgm2 of - Just (COMContact c2@Contact {contactId = cId2}) - | cId1 /= cId2 -> void $ mergeContacts c1 c2 - | otherwise -> messageWarning "xInfoProbeOk ignored: same contact id" - Just (COMGroupMember m2@GroupMember {memberContactId}) - | isNothing memberContactId -> void $ associateMemberAndContact c1 m2 - | otherwise -> messageWarning "xInfoProbeOk ignored: member already has contact" - _ -> pure () - COMGroupMember m1@GroupMember {memberContactId} -> - case cgm2 of - Just (COMContact c2) - | isNothing memberContactId -> void $ associateMemberAndContact c2 m1 - | otherwise -> messageWarning "xInfoProbeOk ignored: member already has contact" - Just (COMGroupMember _) -> messageWarning "xInfoProbeOk ignored: members are not matched with members" - _ -> pure () - - -- to party accepting call - xCallInv :: Contact -> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> CM () - xCallInv ct@Contact {contactId} callId CallInvitation {callType, callDhPubKey} msg@RcvMessage {sharedMsgId_} msgMeta = do - if featureAllowed SCFCalls forContact ct - then do - g <- asks random - dhKeyPair <- atomically $ if encryptedCall callType then Just <$> C.generateKeyPair g else pure Nothing - ci <- saveCallItem CISCallPending - callUUID <- UUID.toText <$> liftIO V4.nextRandom - let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> (snd <$> dhKeyPair)) - callState = CallInvitationReceived {peerCallType = callType, localDhPubKey = fst <$> dhKeyPair, sharedKey} - call' = Call {contactId, callId, callUUID, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci} - calls <- asks currentCalls - -- theoretically, the new call invitation for the current contact can mark the in-progress call as ended - -- (and replace it in ChatController) - -- practically, this should not happen - withStore' $ \db -> createCall db user call' $ chatItemTs' ci - call_ <- atomically (TM.lookupInsert contactId call' calls) - forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing - toView $ CRCallInvitation RcvCallInvitation {user, contact = ct, callType, sharedKey, callUUID, callTs = chatItemTs' ci} - toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] - else featureRejected CFCalls - where - brokerTs = metaBrokerTs msgMeta - saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0) - featureRejected f = do - ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvChatFeatureRejected f) Nothing Nothing False - toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] - - -- to party initiating call - xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> CM () - xCallOffer ct callId CallOffer {callType, rtcSession, callDhPubKey} msg = do - msgCurrentCall ct callId "x.call.offer" msg $ - \call -> case callState call of - CallInvitationSent {localCallType, localDhPrivKey} -> do - let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> localDhPrivKey) - callState' = CallOfferReceived {localCallType, peerCallType = callType, peerCallSession = rtcSession, sharedKey} - askConfirmation = encryptedCall localCallType && not (encryptedCall callType) - toView CRCallOffer {user, contact = ct, callType, offer = rtcSession, sharedKey, askConfirmation} - pure (Just call {callState = callState'}, Just . ACIContent SMDSnd $ CISndCall CISCallAccepted 0) - _ -> do - msgCallStateError "x.call.offer" call - pure (Just call, Nothing) - - -- to party accepting call - xCallAnswer :: Contact -> CallId -> CallAnswer -> RcvMessage -> CM () - xCallAnswer ct callId CallAnswer {rtcSession} msg = do - msgCurrentCall ct callId "x.call.answer" msg $ - \call -> case callState call of - CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey} -> do - let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession = rtcSession, sharedKey} - toView $ CRCallAnswer user ct rtcSession - pure (Just call {callState = callState'}, Just . ACIContent SMDRcv $ CIRcvCall CISCallNegotiated 0) - _ -> do - msgCallStateError "x.call.answer" call - pure (Just call, Nothing) - - -- to any call party - xCallExtra :: Contact -> CallId -> CallExtraInfo -> RcvMessage -> CM () - xCallExtra ct callId CallExtraInfo {rtcExtraInfo} msg = do - msgCurrentCall ct callId "x.call.extra" msg $ - \call -> case callState call of - CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey} -> do - -- TODO update the list of ice servers in peerCallSession - let callState' = CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey} - toView $ CRCallExtraInfo user ct rtcExtraInfo - pure (Just call {callState = callState'}, Nothing) - CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} -> do - -- TODO update the list of ice servers in peerCallSession - let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} - toView $ CRCallExtraInfo user ct rtcExtraInfo - pure (Just call {callState = callState'}, Nothing) - _ -> do - msgCallStateError "x.call.extra" call - pure (Just call, Nothing) - - -- to any call party - xCallEnd :: Contact -> CallId -> RcvMessage -> CM () - xCallEnd ct callId msg = - msgCurrentCall ct callId "x.call.end" msg $ \Call {chatItemId} -> do - toView $ CRCallEnded user ct - (Nothing,) <$> callStatusItemContent user ct chatItemId WCSDisconnected - - msgCurrentCall :: Contact -> CallId -> Text -> RcvMessage -> (Call -> CM (Maybe Call, Maybe ACIContent)) -> CM () - msgCurrentCall ct@Contact {contactId = ctId'} callId' eventName RcvMessage {msgId} action = do - calls <- asks currentCalls - atomically (TM.lookup ctId' calls) >>= \case - Nothing -> messageError $ eventName <> ": no current call" - Just call@Call {contactId, callId, chatItemId} - | contactId /= ctId' || callId /= callId' -> messageError $ eventName <> ": wrong contact or callId" - | otherwise -> do - (call_, aciContent_) <- action call - case call_ of - Just call' -> do - unless (isRcvInvitation call') $ withStore' $ \db -> deleteCalls db user ctId' - atomically $ TM.insert ctId' call' calls - _ -> do - withStore' $ \db -> deleteCalls db user ctId' - atomically $ TM.delete ctId' calls - forM_ aciContent_ $ \aciContent -> do - timed_ <- callTimed ct aciContent - updateDirectChatItemView user ct chatItemId aciContent False False timed_ $ Just msgId - forM_ (timed_ >>= timedDeleteAt') $ - startProximateTimedItemThread user (ChatRef CTDirect ctId', chatItemId) - - msgCallStateError :: Text -> Call -> CM () - msgCallStateError eventName Call {callState} = - messageError $ eventName <> ": wrong call state " <> T.pack (show $ callStateTag callState) - - mergeContacts :: Contact -> Contact -> CM (Maybe Contact) - mergeContacts c1 c2 = do - let Contact {localDisplayName = cLDN1, profile = LocalProfile {displayName}} = c1 - Contact {localDisplayName = cLDN2} = c2 - case (suffixOrd displayName cLDN1, suffixOrd displayName cLDN2) of - (Just cOrd1, Just cOrd2) - | cOrd1 < cOrd2 -> merge c1 c2 - | cOrd2 < cOrd1 -> merge c2 c1 - | otherwise -> pure Nothing - _ -> pure Nothing - where - merge c1' c2' = do - c2'' <- withStore $ \db -> mergeContactRecords db vr user c1' c2' - toView $ CRContactsMerged user c1' c2' c2'' - when (directOrUsed c2'') $ showSecurityCodeChanged c2'' - pure $ Just c2'' - where - showSecurityCodeChanged mergedCt = do - let sc1_ = contactSecurityCode c1' - sc2_ = contactSecurityCode c2' - scMerged_ = contactSecurityCode mergedCt - case (sc1_, sc2_) of - (Just sc1, Nothing) - | scMerged_ /= Just sc1 -> securityCodeChanged mergedCt - | otherwise -> pure () - (Nothing, Just sc2) - | scMerged_ /= Just sc2 -> securityCodeChanged mergedCt - | otherwise -> pure () - _ -> pure () - - associateMemberAndContact :: Contact -> GroupMember -> CM (Maybe Contact) - associateMemberAndContact c m = do - let Contact {localDisplayName = cLDN, profile = LocalProfile {displayName}} = c - GroupMember {localDisplayName = mLDN} = m - case (suffixOrd displayName cLDN, suffixOrd displayName mLDN) of - (Just cOrd, Just mOrd) - | cOrd < mOrd -> Just <$> associateMemberWithContact c m - | mOrd < cOrd -> Just <$> associateContactWithMember m c - | otherwise -> pure Nothing - _ -> pure Nothing - - suffixOrd :: ContactName -> ContactName -> Maybe Int - suffixOrd displayName localDisplayName - | localDisplayName == displayName = Just 0 - | otherwise = case T.stripPrefix (displayName <> "_") localDisplayName of - Just suffix -> readMaybe $ T.unpack suffix - Nothing -> Nothing - - associateMemberWithContact :: Contact -> GroupMember -> CM Contact - associateMemberWithContact c1 m2@GroupMember {groupId} = do - withStore' $ \db -> associateMemberWithContactRecord db user c1 m2 - g <- withStore $ \db -> getGroupInfo db vr user groupId - toView $ CRContactAndMemberAssociated user c1 g m2 c1 - pure c1 - - associateContactWithMember :: GroupMember -> Contact -> CM Contact - associateContactWithMember m1@GroupMember {groupId} c2 = do - c2' <- withStore $ \db -> associateContactWithMemberRecord db vr user m1 c2 - g <- withStore $ \db -> getGroupInfo db vr user groupId - toView $ CRContactAndMemberAssociated user c2 g m1 c2' - pure c2' - - saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Bool) - saveConnInfo activeConn connInfo = do - ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo - conn' <- updatePeerChatVRange activeConn chatVRange - case chatMsgEvent of - XInfo p -> do - let contactUsed = connDirect activeConn - ct <- withStore $ \db -> createDirectContact db user conn' p contactUsed - toView $ CRContactConnecting user ct - pure (conn', False) - XGrpLinkInv glInv -> do - (gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db vr user conn' glInv - toView $ CRGroupLinkConnecting user gInfo host - pure (conn', True) - -- TODO show/log error, other events in SMP confirmation - _ -> pure (conn', False) - - xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> RcvMessage -> UTCTime -> CM () - xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _) msg brokerTs = do - checkHostRole m memRole - unless (sameMemberId memId $ membership gInfo) $ - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - Right unknownMember@GroupMember {memberStatus = GSMemUnknown} -> do - updatedMember <- withStore $ \db -> updateUnknownMemberAnnounced db vr user m unknownMember memInfo - toView $ CRUnknownMemberAnnounced user gInfo m unknownMember updatedMember - memberAnnouncedToView updatedMember - Right _ -> messageError "x.grp.mem.new error: member already exists" - Left _ -> do - newMember <- withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced - memberAnnouncedToView newMember - where - memberAnnouncedToView announcedMember@GroupMember {groupMemberId, memberProfile} = do - let event = RGEMemberAdded groupMemberId (fromLocalProfile memberProfile) - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent event) - groupMsgToView gInfo ci - toView $ CRJoinedGroupMemberConnecting user gInfo m announcedMember - - xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM () - xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _) memRestrictions = do - case memberCategory m of - GCHostMember -> - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - Right _ -> messageError "x.grp.mem.intro ignored: member already exists" - Left _ -> do - when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c) - subMode <- chatReadVar subscriptionMode - -- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second - groupConnIds <- createConn subMode - directConnIds <- case memChatVRange of - Nothing -> Just <$> createConn subMode - Just (ChatVersionRange mcvr) - | maxVersion mcvr >= groupDirectInvVersion -> pure Nothing - | otherwise -> Just <$> createConn subMode - let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo - chatV = maybe (minVersion vr) (\peerVR -> vr `peerConnChatVersion` fromChatVRange peerVR) memChatVRange - void $ withStore $ \db -> createIntroReMember db user gInfo m chatV memInfo memRestrictions groupConnIds directConnIds customUserProfileId subMode - _ -> messageError "x.grp.mem.intro can be only sent by host member" - where - createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation subMode - - sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> CM () - sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do - hostConn <- withStore $ \db -> getConnectionById db vr user hostConnId - let msg = XGrpMemInv memberId IntroInvitation {groupConnReq, directConnReq} - void $ sendDirectMemberMessage hostConn msg groupId - withStore' $ \db -> updateGroupMemberStatusById db userId groupMemberId GSMemIntroInvited - - xGrpMemInv :: GroupInfo -> GroupMember -> MemberId -> IntroInvitation -> CM () - xGrpMemInv gInfo m memId introInv = do - case memberCategory m of - GCInviteeMember -> - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - Left _ -> messageError "x.grp.mem.inv error: referenced member does not exist" - Right reMember -> do - GroupMemberIntro {introId} <- withStore $ \db -> saveIntroInvitation db reMember m introInv - sendGroupMemberMessage user gInfo reMember (XGrpMemFwd (memberInfo m) introInv) (Just introId) $ - withStore' $ - \db -> updateIntroStatus db introId GMIntroInvForwarded - _ -> messageError "x.grp.mem.inv can be only sent by invitee member" - - xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> CM () - xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do - let GroupMember {memberId = membershipMemId} = membership - checkHostRole m memRole - toMember <- - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - -- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent - -- the situation when member does not exist is an error - -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that. - -- For now, this branch compensates for the lack of delayed message delivery. - Left _ -> withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced - Right m' -> pure m' - withStore' $ \db -> saveMemberInvitation db toMember introInv - subMode <- chatReadVar subscriptionMode - -- [incognito] send membership incognito profile, create direct connection as incognito - let membershipProfile = redactedMemberProfile $ fromLocalProfile $ memberProfile membership - dm <- encodeConnInfo $ XGrpMemInfo membershipMemId membershipProfile - -- [async agent commands] no continuation needed, but commands should be asynchronous for stability - 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 memChatVRange - chatV = vr `peerConnChatVersion` mcvr - withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode - - xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM () - xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs - | membershipMemId == memId = - let gInfo' = gInfo {membership = membership {memberRole = memRole}} - in changeMemberRole gInfo' membership $ RGEUserRole memRole - | otherwise = - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole - Left _ -> messageError "x.grp.mem.role with unknown member ID" - where - GroupMember {memberId = membershipMemId} = membership - changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent - | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions" - | otherwise = do - withStore' $ \db -> updateGroupMemberRole db user member memRole - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent) - groupMsgToView gInfo ci - toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole} - - checkHostRole :: GroupMember -> GroupMemberRole -> CM () - checkHostRole GroupMember {memberRole, localDisplayName} memRole = - when (memberRole < GRAdmin || memberRole < memRole) $ throwChatError (CEGroupContactRole localDisplayName) - - xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM () - xGrpMemRestrict - gInfo@GroupInfo {groupId, membership = GroupMember {memberId = membershipMemId}} - m@GroupMember {memberRole = senderRole} - memId - MemberRestrictions {restriction} - msg - brokerTs - | membershipMemId == memId = - -- member shouldn't receive this message about themselves - messageError "x.grp.mem.restrict: admin blocks you" - | otherwise = - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - Right bm@GroupMember {groupMemberId = bmId, memberRole, memberProfile = bmp} - | senderRole < GRAdmin || senderRole < memberRole -> messageError "x.grp.mem.restrict with insufficient member permissions" - | otherwise -> do - bm' <- setMemberBlocked bmId - toggleNtf user bm' (not blocked) - let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs ciContent - groupMsgToView gInfo ci - toView CRMemberBlockedForAll {user, groupInfo = gInfo, byMember = m, member = bm, blocked} - Left (SEGroupMemberNotFoundByMemberId _) -> do - bm <- createUnknownMember gInfo memId - bm' <- setMemberBlocked $ groupMemberId' bm - toView $ CRUnknownMemberBlocked user gInfo m bm' - Left e -> throwError $ ChatErrorStore e - where - setMemberBlocked bmId = - withStore $ \db -> do - liftIO $ updateGroupMemberBlocked db user groupId bmId restriction - getGroupMember db vr user groupId bmId - blocked = mrsBlocked restriction - - xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM () - xGrpMemCon gInfo sendingMember memId = do - refMember <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo memId - case (memberCategory sendingMember, memberCategory refMember) of - (GCInviteeMember, GCInviteeMember) -> - withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case - Right intro -> inviteeXGrpMemCon intro - Left _ -> - withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case - Right intro -> forwardMemberXGrpMemCon intro - Left _ -> messageWarning "x.grp.mem.con: no introduction" - (GCInviteeMember, _) -> - withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case - Right intro -> inviteeXGrpMemCon intro - Left _ -> messageWarning "x.grp.mem.con: no introduction" - (_, GCInviteeMember) -> - withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case - Right intro -> forwardMemberXGrpMemCon intro - Left _ -> messageWarning "x.grp.mem.con: no introductiosupportn" - -- Note: we can allow XGrpMemCon to all member categories if we decide to support broader group forwarding, - -- deduplication (see saveGroupRcvMsg, saveGroupFwdRcvMsg) already supports sending XGrpMemCon - -- to any forwarding member, not only host/inviting member; - -- database would track all members connections then - -- (currently it's done via group_member_intros for introduced connections only) - _ -> - messageWarning "x.grp.mem.con: neither member is invitee" - where - inviteeXGrpMemCon :: GroupMemberIntro -> CM () - inviteeXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of - GMIntroReConnected -> updateStatus introId GMIntroConnected - GMIntroToConnected -> pure () - GMIntroConnected -> pure () - _ -> updateStatus introId GMIntroToConnected - forwardMemberXGrpMemCon :: GroupMemberIntro -> CM () - forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of - GMIntroToConnected -> updateStatus introId GMIntroConnected - GMIntroReConnected -> pure () - GMIntroConnected -> pure () - _ -> updateStatus introId GMIntroReConnected - updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status - - xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> CM () - xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg brokerTs = do - let GroupMember {memberId = membershipMemId} = membership - if membershipMemId == memId - then checkRole membership $ do - deleteGroupLinkIfExists user gInfo - -- member records are not deleted to keep history - members <- withStore' $ \db -> getGroupMembers db vr user gInfo - deleteMembersConnections user members - withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved - deleteMemberItem RGEUserDeleted - toView $ CRDeletedMemberUser user gInfo {membership = membership {memberStatus = GSMemRemoved}} m - else - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - Left _ -> messageError "x.grp.mem.del with unknown member ID" - Right member@GroupMember {groupMemberId, memberProfile} -> - checkRole member $ do - -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave - deleteMemberConnection user member - -- undeleted "member connected" chat item will prevent deletion of member record - deleteOrUpdateMemberRecord user member - deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) - toView $ CRDeletedMember user gInfo m member {memberStatus = GSMemRemoved} - where - checkRole GroupMember {memberRole} a - | senderRole < GRAdmin || senderRole < memberRole = - messageError "x.grp.mem.del with insufficient member permissions" - | otherwise = a - deleteMemberItem gEvent = do - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent) - groupMsgToView gInfo ci - - xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () - xGrpLeave gInfo m msg brokerTs = do - deleteMemberConnection user m - -- member record is not deleted to allow creation of "member left" chat item - withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEMemberLeft) - groupMsgToView gInfo ci - toView $ CRLeftMember user gInfo m {memberStatus = GSMemLeft} - - xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () - xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do - when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner - ms <- withStore' $ \db -> do - members <- getGroupMembers db vr user gInfo - updateGroupMemberStatus db userId membership GSMemGroupDeleted - pure members - -- member records are not deleted to keep history - deleteMembersConnections user ms - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEGroupDeleted) - groupMsgToView gInfo ci - toView $ CRGroupDeleted user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m - - xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM () - xGrpInfo g@GroupInfo {groupProfile = p, businessChat} m@GroupMember {memberRole} p' msg brokerTs - | memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" - | otherwise = case businessChat of - Nothing -> unless (p == p') $ do - g' <- withStore $ \db -> updateGroupProfile db user g p' - toView $ CRGroupUpdated user g g' (Just m) - let cd = CDGroupRcv g' m - unless (sameGroupProfileInfo p p') $ do - ci <- saveRcvChatItem user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p') - groupMsgToView g' ci - createGroupFeatureChangedItems user cd CIRcvGroupFeature g g' - Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' - - xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM () - xGrpPrefs g m@GroupMember {memberRole} ps' - | memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions" - | otherwise = updateGroupPrefs_ g m ps' - - updateGroupPrefs_ :: GroupInfo -> GroupMember -> GroupPreferences -> CM () - updateGroupPrefs_ g@GroupInfo {groupProfile = p} m ps' = - unless (groupPreferences p == Just ps') $ do - g' <- withStore' $ \db -> updateGroupPreferences db user g ps' - toView $ CRGroupUpdated user g g' (Just m) - let cd = CDGroupRcv g' m - createGroupFeatureChangedItems user cd CIRcvGroupFeature g g' - - xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> CM () - xGrpDirectInv g m mConn connReq mContent_ msg brokerTs = do - unless (groupFeatureMemberAllowed SGFDirectMessages m g) $ messageError "x.grp.direct.inv: direct messages not allowed" - let GroupMember {memberContactId} = m - subMode <- chatReadVar subscriptionMode - case memberContactId of - Nothing -> createNewContact subMode - Just mContactId -> do - mCt <- withStore $ \db -> getContact db vr user mContactId - let Contact {activeConn, contactGrpInvSent} = mCt - forM_ activeConn $ \Connection {connId} -> - if contactGrpInvSent - then do - ownConnReq <- withStore $ \db -> getConnReqInv db connId - -- in case both members sent x.grp.direct.inv before receiving other's for processing, - -- only the one who received greater connReq joins, the other creates items and waits for confirmation - if strEncode connReq > strEncode ownConnReq - then joinExistingContact subMode mCt - else createItems mCt m - else joinExistingContact subMode mCt - where - joinExistingContact subMode mCt = do - connIds <- joinConn subMode - mCt' <- withStore $ \db -> updateMemberContactInvited db user connIds g mConn mCt subMode - createItems mCt' m - securityCodeChanged mCt' - createNewContact subMode = do - connIds <- joinConn subMode - -- [incognito] reuse membership incognito profile - (mCt', m') <- withStore' $ \db -> createMemberContactInvited db user connIds g m mConn subMode - createItems mCt' m' - joinConn subMode = do - -- [incognito] send membership incognito profile - let p = userProfileToSend user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing False - -- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ) - dm <- encodeConnInfo $ XInfo p - joinAgentConnectionAsync user True connReq dm subMode - createItems mCt' m' = do - createInternalChatItem user (CDGroupRcv g m') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing - toView $ CRNewMemberContactReceivedInv user mCt' g m' - forM_ mContent_ $ \mc -> do - ci <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc) - toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat mCt') ci] - - securityCodeChanged :: Contact -> CM () - securityCodeChanged ct = do - toView $ CRContactVerificationReset user ct - createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing - - xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> ChatMessage 'Json -> UTCTime -> CM () - xGrpMsgForward gInfo@GroupInfo {groupId} m@GroupMember {memberRole, localDisplayName} memberId msg msgTs = do - when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole localDisplayName) - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case - Right author -> processForwardedMsg author msg - Left (SEGroupMemberNotFoundByMemberId _) -> do - unknownAuthor <- createUnknownMember gInfo memberId - toView $ CRUnknownMemberCreated user gInfo m unknownAuthor - processForwardedMsg unknownAuthor msg - Left e -> throwError $ ChatErrorStore e - where - -- Note: forwarded group events (see forwardedGroupMsg) should include msgId to be deduplicated - processForwardedMsg :: GroupMember -> ChatMessage 'Json -> CM () - processForwardedMsg author chatMsg = do - let body = LB.toStrict $ J.encode msg - rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg - case event of - XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs True - XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live - XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs - XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs - XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId - XInfo p -> xInfoMember gInfo author p msgTs - XGrpMemNew memInfo -> xGrpMemNew gInfo author memInfo rcvMsg msgTs - XGrpMemRole memId memRole -> xGrpMemRole gInfo author memId memRole rcvMsg msgTs - XGrpMemDel memId -> xGrpMemDel gInfo author memId rcvMsg msgTs - XGrpLeave -> xGrpLeave gInfo author rcvMsg msgTs - XGrpDel -> xGrpDel gInfo author rcvMsg msgTs - XGrpInfo p' -> xGrpInfo gInfo author p' rcvMsg msgTs - XGrpPrefs ps' -> xGrpPrefs gInfo author ps' - _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) - - createUnknownMember :: GroupInfo -> MemberId -> CM GroupMember - createUnknownMember gInfo memberId = do - let name = T.take 7 . safeDecodeUtf8 . B64.encode . unMemberId $ memberId - withStore $ \db -> createNewUnknownGroupMember db vr user gInfo memberId name - - directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM () - directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do - checkIntegrityCreateItem (CDDirectRcv ct) msgMeta `catchChatError` \_ -> pure () - forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do - withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus - updateDirectItemStatus ct conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete - - groupMsgReceived :: GroupInfo -> GroupMember -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM () - groupMsgReceived gInfo m conn@Connection {connId} msgMeta msgRcpts = do - checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure () - forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do - withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus - updateGroupItemsStatus gInfo m conn agentMsgId (GSSRcvd msgRcptStatus) Nothing - - -- Searches chat items for many agent message IDs and updates their status - updateDirectItemsStatusMsgs :: Contact -> Connection -> [AgentMsgId] -> CIStatus 'MDSnd -> CM () - updateDirectItemsStatusMsgs ct conn msgIds newStatus = do - cis <- withStore' $ \db -> forM msgIds $ \msgId -> runExceptT $ updateDirectItemsStatus' db ct conn msgId newStatus - let acis = map ctItem $ concat $ rights cis - unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis - where - ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct) - - updateDirectItemStatus :: Contact -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> CM () - updateDirectItemStatus ct conn msgId newStatus = do - cis <- withStore $ \db -> updateDirectItemsStatus' db ct conn msgId newStatus - let acis = map ctItem cis - unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis - where - ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct) - - updateDirectItemsStatus' :: DB.Connection -> Contact -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd] - updateDirectItemsStatus' db ct@Contact {contactId} Connection {connId} msgId newStatus = do - items <- liftIO $ getDirectChatItemsByAgentMsgId db user contactId connId msgId - catMaybes <$> mapM updateItem items - where - updateItem :: CChatItem 'CTDirect -> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd)) - updateItem = \case - (CChatItem SMDSnd ChatItem {meta = CIMeta {itemStatus = CISSndRcvd _ _}}) -> pure Nothing - (CChatItem SMDSnd ChatItem {meta = CIMeta {itemId, itemStatus}}) - | itemStatus == newStatus -> pure Nothing - | otherwise -> Just <$> updateDirectChatItemStatus db user ct itemId newStatus - _ -> pure Nothing - - updateGroupMemSndStatus' :: DB.Connection -> ChatItemId -> GroupMemberId -> GroupSndStatus -> IO Bool - updateGroupMemSndStatus' db itemId groupMemberId newStatus = - runExceptT (getGroupSndStatus db itemId groupMemberId) >>= \case - Right (GSSRcvd _) -> pure False - Right memStatus - | memStatus == newStatus -> pure False - | otherwise -> updateGroupSndStatus db itemId groupMemberId newStatus $> True - _ -> pure False - - updateGroupItemsStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> GroupSndStatus -> Maybe Bool -> CM () - updateGroupItemsStatus gInfo@GroupInfo {groupId} GroupMember {groupMemberId} Connection {connId} msgId newMemStatus viaProxy_ = do - items <- withStore' (\db -> getGroupChatItemsByAgentMsgId db user groupId connId msgId) - cis <- catMaybes <$> withStore (\db -> mapM (updateItem db) items) - let acis = map gItem cis - unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis - where - gItem = AChatItem SCTGroup SMDSnd (GroupChat gInfo) - updateItem :: DB.Connection -> CChatItem 'CTGroup -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd)) - updateItem db = \case - (CChatItem SMDSnd ChatItem {meta = CIMeta {itemStatus = CISSndRcvd _ SSPComplete}}) -> pure Nothing - (CChatItem SMDSnd ChatItem {meta = CIMeta {itemId, itemStatus}}) -> do - forM_ viaProxy_ $ \viaProxy -> liftIO $ setGroupSndViaProxy db itemId groupMemberId viaProxy - memStatusChanged <- liftIO $ updateGroupMemSndStatus' db itemId groupMemberId newMemStatus - if memStatusChanged - then do - memStatusCounts <- liftIO $ getGroupSndStatusCounts db itemId - let newStatus = membersGroupItemStatus memStatusCounts - if newStatus /= itemStatus - then Just <$> updateGroupChatItemStatus db user gInfo itemId newStatus - else pure Nothing - else pure Nothing - _ -> pure Nothing - -createContactPQSndItem :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection) -createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' = - flip catchChatError (const $ pure (ct, conn)) $ case (pqSndEnabled, pqSndEnabled') of - (Just b, b') | b' /= b -> createPQItem $ CISndConnEvent (SCEPqEnabled pqSndEnabled') - (Nothing, PQEncOn) -> createPQItem $ CISndDirectE2EEInfo (E2EInfo pqSndEnabled') - _ -> pure (ct, conn) - where - createPQItem ciContent = do - let conn' = conn {pqSndEnabled = Just pqSndEnabled'} :: Connection - ct' = ct {activeConn = Just conn'} :: Contact - when (contactPQEnabled ct /= contactPQEnabled ct') $ do - createInternalChatItem user (CDDirectSnd ct') ciContent Nothing - toView $ CRContactPQEnabled user ct' pqSndEnabled' - pure (ct', conn') - -updateContactPQRcv :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection) -updateContactPQRcv user ct conn@Connection {connId, pqRcvEnabled} pqRcvEnabled' = - flip catchChatError (const $ pure (ct, conn)) $ case (pqRcvEnabled, pqRcvEnabled') of - (Just b, b') | b' /= b -> updatePQ $ CIRcvConnEvent (RCEPqEnabled pqRcvEnabled') - (Nothing, PQEncOn) -> updatePQ $ CIRcvDirectE2EEInfo (E2EInfo pqRcvEnabled') - _ -> pure (ct, conn) - where - updatePQ ciContent = do - withStore' $ \db -> updateConnPQRcvEnabled db connId pqRcvEnabled' - let conn' = conn {pqRcvEnabled = Just pqRcvEnabled'} :: Connection - ct' = ct {activeConn = Just conn'} :: Contact - when (contactPQEnabled ct /= contactPQEnabled ct') $ do - createInternalChatItem user (CDDirectRcv ct') ciContent Nothing - toView $ CRContactPQEnabled user ct' pqRcvEnabled' - pure (ct', conn') - -metaBrokerTs :: MsgMeta -> UTCTime -metaBrokerTs MsgMeta {broker = (_, brokerTs)} = brokerTs - -sameMemberId :: MemberId -> GroupMember -> Bool -sameMemberId memId GroupMember {memberId} = memId == memberId - -updatePeerChatVRange :: Connection -> VersionRangeChat -> CM Connection -updatePeerChatVRange conn@Connection {connId, connChatVersion = v, peerChatVRange, connType, pqSupport, pqEncryption} msgVRange = do - v' <- lift $ upgradedConnVersion v msgVRange - conn' <- - if msgVRange /= peerChatVRange || v' /= v - then do - withStore' $ \db -> setPeerChatVRange db connId v' msgVRange - pure conn {connChatVersion = v', peerChatVRange = msgVRange} - else pure conn - -- TODO v6.0 remove/review: for contacts only version upgrade should trigger enabling PQ support/encryption - if connType == ConnContact && v' >= pqEncryptionCompressionVersion && (pqSupport /= PQSupportOn || pqEncryption /= PQEncOn) - then do - withStore' $ \db -> updateConnSupportPQ db connId PQSupportOn PQEncOn - pure conn' {pqSupport = PQSupportOn, pqEncryption = PQEncOn} - else pure conn' - -updateMemberChatVRange :: GroupMember -> Connection -> VersionRangeChat -> CM (GroupMember, Connection) -updateMemberChatVRange mem@GroupMember {groupMemberId} conn@Connection {connId, connChatVersion = v, peerChatVRange} msgVRange = do - v' <- lift $ upgradedConnVersion v msgVRange - if msgVRange /= peerChatVRange || v' /= v - then do - withStore' $ \db -> do - setPeerChatVRange db connId v' msgVRange - setMemberChatVRange db groupMemberId msgVRange - let conn' = conn {connChatVersion = v', peerChatVRange = msgVRange} - pure (mem {memberChatVRange = msgVRange, activeConn = Just conn'}, conn') - else pure (mem, conn) - -upgradedConnVersion :: VersionChat -> VersionRangeChat -> CM' VersionChat -upgradedConnVersion v peerVR = do - vr <- chatVersionRange' - -- don't allow reducing agreed connection version - pure $ maybe v (\(Compatible v') -> max v v') $ vr `compatibleVersion` peerVR - -parseFileDescription :: FilePartyI p => Text -> CM (ValidFileDescription p) -parseFileDescription = - liftEither . first (ChatError . CEInvalidFileDescription) . (strDecode . encodeUtf8) - -sendDirectFileInline :: User -> Contact -> FileTransferMeta -> SharedMsgId -> CM () -sendDirectFileInline user ct ft sharedMsgId = do - msgDeliveryId <- sendFileInline_ ft sharedMsgId $ sendDirectContactMessage user ct - withStore $ \db -> updateSndDirectFTDelivery db ct ft msgDeliveryId - -sendMemberFileInline :: GroupMember -> Connection -> FileTransferMeta -> SharedMsgId -> CM () -sendMemberFileInline m@GroupMember {groupId} conn ft sharedMsgId = do - msgDeliveryId <- sendFileInline_ ft sharedMsgId $ \msg -> do - (sndMsg, msgDeliveryId, _) <- sendDirectMemberMessage conn msg groupId - pure (sndMsg, msgDeliveryId) - withStore' $ \db -> updateSndGroupFTDelivery db m conn ft msgDeliveryId - -sendFileInline_ :: FileTransferMeta -> SharedMsgId -> (ChatMsgEvent 'Binary -> CM (SndMessage, Int64)) -> CM Int64 -sendFileInline_ FileTransferMeta {filePath, chunkSize} sharedMsgId sendMsg = - sendChunks 1 =<< liftIO . B.readFile =<< lift (toFSFilePath filePath) - where - sendChunks chunkNo bytes = do - let (chunk, rest) = B.splitAt chSize bytes - (_, msgDeliveryId) <- sendMsg $ BFileChunk sharedMsgId $ FileChunk chunkNo chunk - if B.null rest - then pure msgDeliveryId - else sendChunks (chunkNo + 1) rest - chSize = fromIntegral chunkSize - -parseChatMessage :: Connection -> ByteString -> CM (ChatMessage 'Json) -parseChatMessage conn s = do - case parseChatMessages s of - [msg] -> liftEither . first (ChatError . errType) $ (\(ACMsg _ m) -> checkEncoding m) =<< msg - _ -> throwChatError $ CEException "parseChatMessage: single message is expected" - where - errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s) -{-# INLINE parseChatMessage #-} - -sendFileChunk :: User -> SndFileTransfer -> CM () -sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} = - unless (fileStatus == FSComplete || fileStatus == FSCancelled) $ do - vr <- chatVersionRange - withStore' (`createSndFileChunk` ft) >>= \case - Just chunkNo -> sendFileChunkNo ft chunkNo - Nothing -> do - ci <- withStore $ \db -> do - liftIO $ updateSndFileStatus db ft FSComplete - liftIO $ deleteSndFileChunks db ft - updateDirectCIFileStatus db vr user fileId CIFSSndComplete - toView $ CRSndFileComplete user ci ft - lift $ closeFileHandle fileId sndFiles - deleteAgentConnectionAsync user acId - -sendFileChunkNo :: SndFileTransfer -> Integer -> CM () -sendFileChunkNo ft@SndFileTransfer {agentConnId = AgentConnId acId} chunkNo = do - chunkBytes <- readFileChunk ft chunkNo - (msgId, _) <- withAgent $ \a -> sendMessage a acId PQEncOff SMP.noMsgFlags $ smpEncode FileChunk {chunkNo, chunkBytes} - withStore' $ \db -> updateSndFileChunkMsg db ft chunkNo msgId - -readFileChunk :: SndFileTransfer -> Integer -> CM ByteString -readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo = do - fsFilePath <- lift $ toFSFilePath filePath - read_ fsFilePath `catchThrow` (ChatError . CEFileRead filePath . show) - where - read_ fsFilePath = do - h <- getFileHandle fileId fsFilePath sndFiles ReadMode - pos <- hTell h - let pos' = (chunkNo - 1) * chunkSize - when (pos /= pos') $ hSeek h AbsoluteSeek pos' - liftIO . B.hGet h $ fromInteger chunkSize - -parseFileChunk :: ByteString -> CM FileChunk -parseFileChunk = liftEither . first (ChatError . CEFileRcvChunk) . smpDecode - -appendFileChunk :: RcvFileTransfer -> Integer -> ByteString -> Bool -> CM () -appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs, fileInvitation = FileInvitation {fileName}} chunkNo chunk final = - case fileStatus of - RFSConnected RcvFileInfo {filePath} -> append_ filePath - -- sometimes update of file transfer status to FSConnected - -- doesn't complete in time before MSG with first file chunk - RFSAccepted RcvFileInfo {filePath} -> append_ filePath - RFSCancelled _ -> pure () - _ -> throwChatError $ CEFileInternal "receiving file transfer not in progress" - where - append_ :: FilePath -> CM () - append_ filePath = do - fsFilePath <- lift $ toFSFilePath filePath - h <- getFileHandle fileId fsFilePath rcvFiles AppendMode - liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (fileErr . show) - withStore' $ \db -> updatedRcvFileChunkStored db ft chunkNo - when final $ do - lift $ closeFileHandle fileId rcvFiles - forM_ cryptoArgs $ \cfArgs -> do - tmpFile <- lift getChatTempDirectory >>= liftIO . (`uniqueCombine` fileName) - tryChatError (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case - Right () -> do - removeFile fsFilePath `catchChatError` \_ -> pure () - renameFile tmpFile fsFilePath - Left e -> do - toView $ CRChatError Nothing e - removeFile tmpFile `catchChatError` \_ -> pure () - withStore' (`removeFileCryptoArgs` fileId) - where - encryptErr e = fileErr $ e <> ", received file not encrypted" - fileErr = ChatError . CEFileWrite filePath - -getFileHandle :: Int64 -> FilePath -> (ChatController -> TVar (Map Int64 Handle)) -> IOMode -> CM Handle -getFileHandle fileId filePath files ioMode = do - fs <- asks files - h_ <- M.lookup fileId <$> readTVarIO fs - maybe (newHandle fs) pure h_ - where - newHandle fs = do - h <- openFile filePath ioMode `catchThrow` (ChatError . CEFileInternal . show) - atomically . modifyTVar fs $ M.insert fileId h - pure h - -isFileActive :: Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> CM Bool -isFileActive fileId files = do - fs <- asks files - isJust . M.lookup fileId <$> readTVarIO fs - -cancelRcvFileTransfer :: User -> RcvFileTransfer -> CM (Maybe ConnId) -cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, xftpRcvFile, rcvFileInline} = - cancel' `catchChatError` (\e -> toView (CRChatError (Just user) e) $> fileConnId) - where - cancel' = do - lift $ closeFileHandle fileId rcvFiles - withStore' $ \db -> do - updateFileCancelled db user fileId CIFSRcvCancelled - updateRcvFileStatus db fileId FSCancelled - deleteRcvFileChunks db ft - case xftpRcvFile of - Just XFTPRcvFile {agentRcvFileId = Just (AgentRcvFileId aFileId), agentRcvFileDeleted} -> - unless agentRcvFileDeleted $ agentXFTPDeleteRcvFile aFileId fileId - _ -> pure () - pure fileConnId - fileConnId = if isNothing xftpRcvFile && isNothing rcvFileInline then liveRcvFileTransferConnId ft else Nothing - -cancelSndFile :: User -> FileTransferMeta -> [SndFileTransfer] -> Bool -> CM [ConnId] -cancelSndFile user FileTransferMeta {fileId, xftpSndFile} fts sendCancel = do - withStore' (\db -> updateFileCancelled db user fileId CIFSSndCancelled) - `catchChatError` (toView . CRChatError (Just user)) - case xftpSndFile of - Nothing -> - catMaybes <$> forM fts (\ft -> cancelSndFileTransfer user ft sendCancel) - Just xsf -> do - forM_ fts (\ft -> cancelSndFileTransfer user ft False) - lift (agentXFTPDeleteSndFileRemote user xsf fileId) `catchChatError` (toView . CRChatError (Just user)) - pure [] - --- TODO v6.0 remove -cancelSndFileTransfer :: User -> SndFileTransfer -> Bool -> CM (Maybe ConnId) -cancelSndFileTransfer user@User {userId} ft@SndFileTransfer {fileId, connId, agentConnId = AgentConnId acId, fileStatus, fileInline} sendCancel = - if fileStatus == FSCancelled || fileStatus == FSComplete - then pure Nothing - else cancel' `catchChatError` (\e -> toView (CRChatError (Just user) e) $> fileConnId) - where - cancel' = do - withStore' $ \db -> do - updateSndFileStatus db ft FSCancelled - deleteSndFileChunks db ft - when sendCancel $ case fileInline of - Just _ -> do - vr <- chatVersionRange - (sharedMsgId, conn) <- withStore $ \db -> (,) <$> getSharedMsgIdByFileId db userId fileId <*> getConnectionById db vr user connId - void $ sendDirectMessage_ conn (BFileChunk sharedMsgId FileChunkCancel) (ConnectionId connId) - _ -> withAgent $ \a -> void . sendMessage a acId PQEncOff SMP.noMsgFlags $ smpEncode FileChunkCancel - pure fileConnId - fileConnId = if isNothing fileInline then Just acId else Nothing - -closeFileHandle :: Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> CM' () -closeFileHandle fileId files = do - fs <- asks files - h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m) - liftIO $ mapM_ hClose h_ `catchAll_` pure () - -deleteMembersConnections :: User -> [GroupMember] -> CM () -deleteMembersConnections user members = deleteMembersConnections' user members False - -deleteMembersConnections' :: User -> [GroupMember] -> Bool -> CM () -deleteMembersConnections' user members waitDelivery = do - let memberConns = - filter (\Connection {connStatus} -> connStatus /= ConnDeleted) $ - mapMaybe (\GroupMember {activeConn} -> activeConn) members - deleteAgentConnectionsAsync' user (map aConnId memberConns) waitDelivery - lift . void . withStoreBatch' $ \db -> map (\conn -> updateConnectionStatus db conn ConnDeleted) memberConns - -deleteMemberConnection :: User -> GroupMember -> CM () -deleteMemberConnection user mem = deleteMemberConnection' user mem False - -deleteMemberConnection' :: User -> GroupMember -> Bool -> CM () -deleteMemberConnection' user GroupMember {activeConn} waitDelivery = do - forM_ activeConn $ \conn -> do - deleteAgentConnectionAsync' user (aConnId conn) waitDelivery - withStore' $ \db -> updateConnectionStatus db conn ConnDeleted - -deleteOrUpdateMemberRecord :: User -> GroupMember -> CM () -deleteOrUpdateMemberRecord user@User {userId} member = - withStore' $ \db -> - checkGroupMemberHasItems db user member >>= \case - Just _ -> updateGroupMemberStatus db userId member GSMemRemoved - Nothing -> deleteGroupMember db user member - -sendDirectContactMessages :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage] -sendDirectContactMessages user ct events = do - Connection {connChatVersion = v} <- liftEither $ contactSendConn_ ct - if v >= batchSend2Version - then sendDirectContactMessages' user ct events - else forM (L.toList events) $ \evt -> - (Right . fst <$> sendDirectContactMessage user ct evt) `catchChatError` \e -> pure (Left e) - -sendDirectContactMessages' :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage] -sendDirectContactMessages' user ct events = do - conn@Connection {connId} <- liftEither $ contactSendConn_ ct - let idsEvts = L.map (ConnectionId connId,) events - msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} - sndMsgs_ <- lift $ createSndMessages idsEvts - (sndMsgs', pqEnc_) <- batchSendConnMessagesB user conn msgFlags sndMsgs_ - forM_ pqEnc_ $ \pqEnc' -> void $ createContactPQSndItem user ct conn pqEnc' - pure sndMsgs' - -sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64) -sendDirectContactMessage user ct chatMsgEvent = do - conn@Connection {connId} <- liftEither $ contactSendConn_ ct - r <- sendDirectMessage_ conn chatMsgEvent (ConnectionId connId) - let (sndMessage, msgDeliveryId, pqEnc') = r - void $ createContactPQSndItem user ct conn pqEnc' - pure (sndMessage, msgDeliveryId) - -contactSendConn_ :: Contact -> Either ChatError Connection -contactSendConn_ ct@Contact {activeConn} = case activeConn of - Nothing -> err $ CEContactNotReady ct - Just conn - | not (connReady conn) -> err $ CEContactNotReady ct - | not (contactActive ct) -> err $ CEContactNotActive ct - | connDisabled conn -> err $ CEContactDisabled ct - | otherwise -> Right conn - where - err = Left . ChatError - --- unlike sendGroupMemberMessage, this function will not store message as pending --- TODO v5.8 we could remove pending messages once all clients support forwarding -sendDirectMemberMessage :: MsgEncodingI e => Connection -> ChatMsgEvent e -> GroupId -> CM (SndMessage, Int64, PQEncryption) -sendDirectMemberMessage conn chatMsgEvent groupId = sendDirectMessage_ conn chatMsgEvent (GroupId groupId) - -sendDirectMessage_ :: MsgEncodingI e => Connection -> ChatMsgEvent e -> ConnOrGroupId -> CM (SndMessage, Int64, PQEncryption) -sendDirectMessage_ conn chatMsgEvent connOrGroupId = do - when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn) - msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent connOrGroupId - -- TODO move compressed body to SndMessage and compress in createSndMessage - (msgDeliveryId, pqEnc') <- deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId - pure (msg, msgDeliveryId, pqEnc') - -createSndMessage :: MsgEncodingI e => ChatMsgEvent e -> ConnOrGroupId -> CM SndMessage -createSndMessage chatMsgEvent connOrGroupId = - liftEither . runIdentity =<< lift (createSndMessages $ Identity (connOrGroupId, chatMsgEvent)) - -createSndMessages :: forall e t. (MsgEncodingI e, Traversable t) => t (ConnOrGroupId, ChatMsgEvent e) -> CM' (t (Either ChatError SndMessage)) -createSndMessages idsEvents = do - g <- asks random - vr <- chatVersionRange' - withStoreBatch $ \db -> fmap (createMsg db g vr) idsEvents - where - createMsg :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> (ConnOrGroupId, ChatMsgEvent e) -> IO (Either ChatError SndMessage) - createMsg db g vr (connOrGroupId, evnt) = runExceptT $ do - withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId evnt encodeMessage - where - encodeMessage sharedMsgId = - encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt} - -sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> Connection -> NonEmpty (ChatMsgEvent e) -> GroupId -> CM () -sendGroupMemberMessages user conn events groupId = do - when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn) - let idsEvts = L.map (GroupId groupId,) events - (errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts - unless (null errs) $ toView $ CRChatErrors (Just user) errs - forM_ (L.nonEmpty msgs) $ \msgs' -> - batchSendConnMessages user conn MsgFlags {notification = True} msgs' - -batchSendConnMessages :: User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption) -batchSendConnMessages user conn msgFlags msgs = - batchSendConnMessagesB user conn msgFlags $ L.map Right msgs - -batchSendConnMessagesB :: User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption) -batchSendConnMessagesB _user conn msgFlags msgs_ = do - let batched_ = batchSndMessagesJSON msgs_ - case L.nonEmpty batched_ of - Just batched' -> do - let msgReqs = L.map (fmap (msgBatchReq conn msgFlags)) batched' - delivered <- deliverMessagesB msgReqs - let msgs' = concat $ L.zipWith flattenMsgs batched' delivered - pqEnc = findLastPQEnc delivered - when (length msgs' /= length msgs_) $ logError "batchSendConnMessagesB: msgs_ and msgs' length mismatch" - pure (msgs', pqEnc) - Nothing -> pure ([], Nothing) - where - flattenMsgs :: Either ChatError MsgBatch -> Either ChatError ([Int64], PQEncryption) -> [Either ChatError SndMessage] - flattenMsgs (Right (MsgBatch _ sndMsgs)) (Right _) = map Right sndMsgs - flattenMsgs (Right (MsgBatch _ sndMsgs)) (Left ce) = replicate (length sndMsgs) (Left ce) - flattenMsgs (Left ce) _ = [Left ce] -- restore original ChatError - findLastPQEnc :: NonEmpty (Either ChatError ([Int64], PQEncryption)) -> Maybe PQEncryption - findLastPQEnc = foldr' (\x acc -> case x of Right (_, pqEnc) -> Just pqEnc; Left _ -> acc) Nothing - -batchSndMessagesJSON :: NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch] -batchSndMessagesJSON = batchMessages maxEncodedMsgLength . L.toList - -msgBatchReq :: Connection -> MsgFlags -> MsgBatch -> ChatMsgReq -msgBatchReq conn msgFlags (MsgBatch batchBody sndMsgs) = (conn, msgFlags, batchBody, map (\SndMessage {msgId} -> msgId) sndMsgs) - -encodeConnInfo :: MsgEncodingI e => ChatMsgEvent e -> CM ByteString -encodeConnInfo chatMsgEvent = do - vr <- chatVersionRange - encodeConnInfoPQ PQSupportOff (maxVersion vr) chatMsgEvent - -encodeConnInfoPQ :: MsgEncodingI e => PQSupport -> VersionChat -> ChatMsgEvent e -> CM ByteString -encodeConnInfoPQ pqSup v chatMsgEvent = do - vr <- chatVersionRange - let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent} - case encodeChatMessage maxEncodedInfoLength info of - ECMEncoded connInfo -> case pqSup of - PQSupportOn | v >= pqEncryptionCompressionVersion && B.length connInfo > maxCompressedInfoLength -> do - let connInfo' = compressedBatchMsgBody_ connInfo - when (B.length connInfo' > maxCompressedInfoLength) $ throwChatError $ CEException "large compressed info" - pure connInfo' - _ -> pure connInfo - ECMLarge -> throwChatError $ CEException "large info" - -deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption) -deliverMessage conn cmEventTag msgBody msgId = do - let msgFlags = MsgFlags {notification = hasNotification cmEventTag} - deliverMessage' conn msgFlags msgBody msgId - -deliverMessage' :: Connection -> MsgFlags -> MsgBody -> MessageId -> CM (Int64, PQEncryption) -deliverMessage' conn msgFlags msgBody msgId = - deliverMessages ((conn, msgFlags, msgBody, [msgId]) :| []) >>= \case - r :| [] -> case r of - Right ([deliveryId], pqEnc) -> pure (deliveryId, pqEnc) - Right (deliveryIds, _) -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 delivery id, got " <> show (length deliveryIds) - Left e -> throwError e - rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs) - --- [MessageId] - SndMessage ids inside MsgBatch, or single message id -type ChatMsgReq = (Connection, MsgFlags, MsgBody, [MessageId]) - -deliverMessages :: NonEmpty ChatMsgReq -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption))) -deliverMessages msgs = deliverMessagesB $ L.map Right msgs - -deliverMessagesB :: NonEmpty (Either ChatError ChatMsgReq) -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption))) -deliverMessagesB msgReqs = do - msgReqs' <- liftIO compressBodies - sent <- L.zipWith prepareBatch msgReqs' <$> withAgent (`sendMessagesB` snd (mapAccumL toAgent Nothing msgReqs')) - lift . void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent) - lift . withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent - where - compressBodies = - forME msgReqs $ \mr@(conn@Connection {pqSupport, connChatVersion = v}, msgFlags, msgBody, msgIds) -> - runExceptT $ case pqSupport of - -- we only compress messages when: - -- 1) PQ support is enabled - -- 2) version is compatible with compression - -- 3) message is longer than max compressed size (as this function is not used for batched messages anyway) - PQSupportOn | v >= pqEncryptionCompressionVersion && B.length msgBody > maxCompressedMsgLength -> do - let msgBody' = compressedBatchMsgBody_ msgBody - when (B.length msgBody' > maxCompressedMsgLength) $ throwError $ ChatError $ CEException "large compressed message" - pure (conn, msgFlags, msgBody', msgIds) - _ -> pure mr - toAgent prev = \case - Right (conn@Connection {connId, pqEncryption}, msgFlags, msgBody, _msgIds) -> - let cId = case prev of - Just prevId | prevId == connId -> "" - _ -> aConnId conn - in (Just connId, Right (cId, pqEncryption, msgFlags, msgBody)) - Left _ce -> (prev, Left (AP.INTERNAL "ChatError, skip")) -- as long as it is Left, the agent batchers should just step over it - prepareBatch (Right req) (Right ar) = Right (req, ar) - prepareBatch (Left ce) _ = Left ce -- restore original ChatError - prepareBatch _ (Left ae) = Left $ ChatErrorAgent ae Nothing - createDelivery :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO (Either ChatError ([Int64], PQEncryption)) - createDelivery db ((Connection {connId}, _, _, msgIds), (agentMsgId, pqEnc')) = do - Right . (,pqEnc') <$> mapM (createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId})) msgIds - updatePQSndEnabled :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO () - updatePQSndEnabled db ((Connection {connId, pqSndEnabled}, _, _, _), (_, pqSndEnabled')) = - case (pqSndEnabled, pqSndEnabled') of - (Just b, b') | b' /= b -> updatePQ - (Nothing, PQEncOn) -> updatePQ - _ -> pure () - where - updatePQ = updateConnPQSndEnabled db connId pqSndEnabled' - -sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage -sendGroupMessage user gInfo members chatMsgEvent = do - sendGroupMessages user gInfo members (chatMsgEvent :| []) >>= \case - ((Right msg) :| [], _) -> pure msg - _ -> throwChatError $ CEInternalError "sendGroupMessage: expected 1 message" - -sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage -sendGroupMessage' user gInfo members chatMsgEvent = - sendGroupMessages_ user gInfo members (chatMsgEvent :| []) >>= \case - ((Right msg) :| [], _) -> pure msg - _ -> throwChatError $ CEInternalError "sendGroupMessage': expected 1 message" - -sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) -sendGroupMessages user gInfo members events = do - when shouldSendProfileUpdate $ - sendProfileUpdate `catchChatError` (toView . CRChatError (Just user)) - sendGroupMessages_ user gInfo members events - where - User {profile = p, userMemberProfileUpdatedAt} = user - GroupInfo {userMemberProfileSentAt} = gInfo - shouldSendProfileUpdate - | incognitoMembership gInfo = False - | otherwise = - case (userMemberProfileSentAt, userMemberProfileUpdatedAt) of - (Just lastSentTs, Just lastUpdateTs) -> lastSentTs < lastUpdateTs - (Nothing, Just _) -> True - _ -> False - sendProfileUpdate = do - let members' = filter (`supportsVersion` memberProfileUpdateVersion) members - profileUpdateEvent = XInfo $ redactedMemberProfile $ fromLocalProfile p - void $ sendGroupMessage' user gInfo members' profileUpdateEvent - currentTs <- liftIO getCurrentTime - withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs - -data GroupSndResult = GroupSndResult - { sentTo :: [(GroupMemberId, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption))], - pending :: [(GroupMemberId, Either ChatError MessageId, Either ChatError ())], - forwarded :: [GroupMember] - } - -sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) -sendGroupMessages_ _user gInfo@GroupInfo {groupId} members events = do - let idsEvts = L.map (GroupId groupId,) events - sndMsgs_ <- lift $ createSndMessages idsEvts - recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) - let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} - (toSendSeparate, toSendBatched, toPending, forwarded, _, dups) = - foldr' addMember ([], [], [], [], S.empty, 0 :: Int) recipientMembers - when (dups /= 0) $ logError $ "sendGroupMessages_: " <> tshow dups <> " duplicate members" - -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here - -- Deliver to toSend members - let (sendToMemIds, msgReqs) = prepareMsgReqs msgFlags sndMsgs_ toSendSeparate toSendBatched - delivered <- maybe (pure []) (fmap L.toList . deliverMessagesB) $ L.nonEmpty msgReqs - when (length delivered /= length sendToMemIds) $ logError "sendGroupMessages_: sendToMemIds and delivered length mismatch" - -- Save as pending for toPending members - let (pendingMemIds, pendingReqs) = preparePending sndMsgs_ toPending - stored <- lift $ withStoreBatch (\db -> map (bindRight $ createPendingMsg db) pendingReqs) - when (length stored /= length pendingMemIds) $ logError "sendGroupMessages_: pendingMemIds and stored length mismatch" - -- Zip for easier access to results - let sentTo = zipWith3 (\mId mReq r -> (mId, fmap (\(_, _, _, msgIds) -> msgIds) mReq, r)) sendToMemIds msgReqs delivered - pending = zipWith3 (\mId pReq r -> (mId, fmap snd pReq, r)) pendingMemIds pendingReqs stored - pure (sndMsgs_, GroupSndResult {sentTo, pending, forwarded}) - where - shuffleMembers :: [GroupMember] -> IO [GroupMember] - shuffleMembers ms = do - let (adminMs, otherMs) = partition isAdmin ms - liftM2 (<>) (shuffle adminMs) (shuffle otherMs) - where - isAdmin GroupMember {memberRole} = memberRole >= GRAdmin - addMember m acc@(toSendSeparate, toSendBatched, pending, forwarded, !mIds, !dups) = - case memberSendAction gInfo events members m of - Just a - | mId `S.member` mIds -> (toSendSeparate, toSendBatched, pending, forwarded, mIds, dups + 1) - | otherwise -> case a of - MSASend conn -> ((m, conn) : toSendSeparate, toSendBatched, pending, forwarded, mIds', dups) - MSASendBatched conn -> (toSendSeparate, (m, conn) : toSendBatched, pending, forwarded, mIds', dups) - MSAPending -> (toSendSeparate, toSendBatched, m : pending, forwarded, mIds', dups) - MSAForwarded -> (toSendSeparate, toSendBatched, pending, m : forwarded, mIds', dups) - Nothing -> acc - where - mId = groupMemberId' m - mIds' = S.insert mId mIds - prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq]) - prepareMsgReqs msgFlags msgs_ toSendSeparate toSendBatched = do - let batched_ = batchSndMessagesJSON msgs_ - case L.nonEmpty batched_ of - Just batched' -> do - let (memsSep, mreqsSep) = foldr' foldMsgs ([], []) toSendSeparate - (memsBtch, mreqsBtch) = foldr' (foldBatches batched') ([], []) toSendBatched - (memsSep <> memsBtch, mreqsSep <> mreqsBtch) - Nothing -> ([], []) - where - foldMsgs :: (GroupMember, Connection) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) - foldMsgs (GroupMember {groupMemberId}, conn) memIdsReqs = - foldr' (\msg_ (memIds, reqs) -> (groupMemberId : memIds, fmap sndMessageReq msg_ : reqs)) memIdsReqs msgs_ - where - sndMessageReq :: SndMessage -> ChatMsgReq - sndMessageReq SndMessage {msgId, msgBody} = (conn, msgFlags, msgBody, [msgId]) - foldBatches :: NonEmpty (Either ChatError MsgBatch) -> (GroupMember, Connection) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) - foldBatches batched' (GroupMember {groupMemberId}, conn) memIdsReqs = - foldr' (\batch_ (memIds, reqs) -> (groupMemberId : memIds, fmap (msgBatchReq conn msgFlags) batch_ : reqs)) memIdsReqs batched' - preparePending :: NonEmpty (Either ChatError SndMessage) -> [GroupMember] -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) - preparePending msgs_ = - foldr' foldMsgs ([], []) - where - foldMsgs :: GroupMember -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) - foldMsgs GroupMember {groupMemberId} memIdsReqs = - foldr' (\msg_ (memIds, reqs) -> (groupMemberId : memIds, fmap pendingReq msg_ : reqs)) memIdsReqs msgs_ - where - pendingReq :: SndMessage -> (GroupMemberId, MessageId) - pendingReq SndMessage {msgId} = (groupMemberId, msgId) - createPendingMsg :: DB.Connection -> (GroupMemberId, MessageId) -> IO (Either ChatError ()) - createPendingMsg db (groupMemberId, msgId) = - createPendingGroupMessage db groupMemberId msgId Nothing $> Right () - -data MemberSendAction = MSASend Connection | MSASendBatched Connection | MSAPending | MSAForwarded - -memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction -memberSendAction gInfo events members m@GroupMember {memberRole} = case memberConn m of - Nothing -> pendingOrForwarded - Just conn@Connection {connStatus} - | connDisabled conn || connStatus == ConnDeleted -> Nothing - | connInactive conn -> Just MSAPending - | connStatus == ConnSndReady || connStatus == ConnReady -> sendBatchedOrSeparate conn - | otherwise -> pendingOrForwarded - where - sendBatchedOrSeparate conn - -- admin doesn't support batch forwarding - send messages separately so that admin can forward one by one - | memberRole >= GRAdmin && not (m `supportsVersion` batchSend2Version) = Just (MSASend conn) - -- either member is not admin, or admin supports batched forwarding - | otherwise = Just (MSASendBatched conn) - pendingOrForwarded = case memberCategory m of - GCUserMember -> Nothing -- shouldn't happen - GCInviteeMember -> Just MSAPending - GCHostMember -> Just MSAPending - GCPreMember -> forwardSupportedOrPending (invitedByGroupMemberId $ membership gInfo) - GCPostMember -> forwardSupportedOrPending (invitedByGroupMemberId m) - where - forwardSupportedOrPending invitingMemberId_ - | membersSupport && all isForwardedGroupMsg events = Just MSAForwarded - | any isXGrpMsgForward events = Nothing - | otherwise = Just MSAPending - where - membersSupport = - m `supportsVersion` groupForwardVersion && invitingMemberSupportsForward - invitingMemberSupportsForward = case invitingMemberId_ of - Just invMemberId -> - -- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember - case find (\m' -> groupMemberId' m' == invMemberId) members of - Just invitingMember -> invitingMember `supportsVersion` groupForwardVersion - Nothing -> False - Nothing -> False - isXGrpMsgForward event = case event of - XGrpMsgForward {} -> True - _ -> False - -sendGroupMemberMessage :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> ChatMsgEvent e -> Maybe Int64 -> CM () -> CM () -sendGroupMemberMessage user gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} chatMsgEvent introId_ postDeliver = do - msg <- createSndMessage chatMsgEvent (GroupId groupId) - messageMember msg `catchChatError` (toView . CRChatError (Just user)) - where - messageMember :: SndMessage -> CM () - messageMember SndMessage {msgId, msgBody} = forM_ (memberSendAction gInfo (chatMsgEvent :| []) [m] m) $ \case - MSASend conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver - MSASendBatched conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver - MSAPending -> withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_ - MSAForwarded -> pure () - --- TODO ensure order - pending messages interleave with user input messages -sendPendingGroupMessages :: User -> GroupMember -> Connection -> CM () -sendPendingGroupMessages user GroupMember {groupMemberId} conn = do - pgms <- withStore' $ \db -> getPendingGroupMessages db groupMemberId - forM_ (L.nonEmpty pgms) $ \pgms' -> do - let msgs = L.map (\(sndMsg, _, _) -> sndMsg) pgms' - void $ batchSendConnMessages user conn MsgFlags {notification = True} msgs - lift . void . withStoreBatch' $ \db -> L.map (\SndMessage {msgId} -> deletePendingGroupMessage db groupMemberId msgId) msgs - lift . void . withStoreBatch' $ \db -> L.map (\(_, tag, introId_) -> updateIntro_ db tag introId_) pgms' - where - updateIntro_ :: DB.Connection -> ACMEventTag -> Maybe Int64 -> IO () - updateIntro_ db tag introId_ = case (tag, introId_) of - (ACMEventTag _ XGrpMemFwd_, Just introId) -> updateIntroStatus db introId GMIntroInvForwarded - _ -> pure () - -saveDirectRcvMSG :: MsgEncodingI e => Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (Connection, RcvMessage) -saveDirectRcvMSG conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do - conn' <- updatePeerChatVRange conn chatVRange - let agentMsgId = fst $ recipient agentMsgMeta - newMsg = NewRcvMessage {chatMsgEvent, msgBody} - rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} - msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing - pure (conn', msg) - -saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (GroupMember, Connection, RcvMessage) -saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do - (am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- updateMemberChatVRange authorMember conn chatVRange - let agentMsgId = fst $ recipient agentMsgMeta - newMsg = NewRcvMessage {chatMsgEvent, msgBody} - rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} - msg <- - withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId) - `catchChatError` \e -> case e of - ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do - vr <- chatVersionRange - fm <- withStore $ \db -> getGroupMember db vr user groupId forwardedByGroupMemberId - forM_ (memberConn fm) $ \fmConn -> - void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemId) groupId - throwError e - _ -> throwError e - pure (am', conn', msg) - -saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> CM RcvMessage -saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {memberId = refMemberId} msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = do - let newMsg = NewRcvMessage {chatMsgEvent, msgBody} - fwdMemberId = Just $ groupMemberId' forwardingMember - refAuthorId = Just $ groupMemberId' refAuthorMember - withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) - `catchChatError` \e -> case e of - ChatErrorStore (SEDuplicateGroupMessage _ _ (Just authorGroupMemberId) Nothing) -> do - vr <- chatVersionRange - am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db vr user groupId authorGroupMemberId - if sameMemberId refMemberId am - then forM_ (memberConn forwardingMember) $ \fmConn -> - void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemberId) groupId - else toView $ CRMessageError user "error" "saveGroupFwdRcvMsg: referenced author member id doesn't match message member id" - throwError e - _ -> throwError e - -saveSndChatItem :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> CM (ChatItem c 'MDSnd) -saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing Nothing False - -saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd) -saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = - saveSndChatItems user cd [Right NewSndChatItemData {msg, content, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case - [Right ci] -> pure ci - _ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item" - -data NewSndChatItemData c = NewSndChatItemData - { msg :: SndMessage, - content :: CIContent 'MDSnd, - ciFile :: Maybe (CIFile 'MDSnd), - quotedItem :: Maybe (CIQuote c), - itemForwarded :: Maybe CIForwardedFrom - } - -saveSndChatItems :: - forall c. - ChatTypeI c => - User -> - ChatDirection c 'MDSnd -> - [Either ChatError (NewSndChatItemData c)] -> - Maybe CITimed -> - Bool -> - CM [Either ChatError (ChatItem c 'MDSnd)] -saveSndChatItems user cd itemsData itemTimed live = do - createdAt <- liftIO getCurrentTime - when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $ - withStore' (\db -> updateChatTs db user cd createdAt) - lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData) - where - createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd)) - createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, ciFile, quotedItem, itemForwarded} = do - ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt - forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - pure $ Right $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live createdAt Nothing createdAt - -saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv) -saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = - saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False - -saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDRcv) -saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerTs content ciFile itemTimed live = do - createdAt <- liftIO getCurrentTime - (ciId, quotedItem, itemForwarded) <- withStore' $ \db -> do - when (ciRequiresAttention content || contactChatDeleted cd) $ updateChatTs db user cd createdAt - r@(ciId, _, _) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt - forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - pure r - pure $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live brokerTs forwardedByMember createdAt - -mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d -mkChatItem cd ciId content file quotedItem sharedMsgId itemForwarded itemTimed live itemTs forwardedByMember currentTs = - let itemText = ciContentToText content - itemStatus = ciCreateStatus content - meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs - in ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file} - -deleteDirectCIs :: User -> Contact -> [CChatItem 'CTDirect] -> Bool -> Bool -> CM ChatResponse -deleteDirectCIs user ct items byUser timed = do - let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items - deleteCIFiles user ciFilesInfo - (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) - unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure $ CRChatItemsDeleted user deletions byUser timed - where - deleteItem db (CChatItem md ci) = do - deleteDirectChatItem db user ct ci - pure $ contactDeletion md ct ci Nothing - -deleteGroupCIs :: User -> GroupInfo -> [CChatItem 'CTGroup] -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> CM ChatResponse -deleteGroupCIs user gInfo items byUser timed byGroupMember_ deletedTs = do - let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items - deleteCIFiles user ciFilesInfo - (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) - unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure $ CRChatItemsDeleted user deletions byUser timed - where - deleteItem :: DB.Connection -> CChatItem 'CTGroup -> IO ChatItemDeletion - deleteItem db (CChatItem md ci) = do - ci' <- case byGroupMember_ of - Just m -> Just <$> updateGroupChatItemModerated db user gInfo ci m deletedTs - Nothing -> Nothing <$ deleteGroupChatItem db user gInfo ci - pure $ groupDeletion md gInfo ci ci' - -deleteLocalCIs :: User -> NoteFolder -> [CChatItem 'CTLocal] -> Bool -> Bool -> CM ChatResponse -deleteLocalCIs user nf items byUser timed = do - let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items - deleteFilesLocally ciFilesInfo - (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) - unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure $ CRChatItemsDeleted user deletions byUser timed - where - deleteItem db (CChatItem md ci) = do - deleteLocalChatItem db user nf ci - pure $ ChatItemDeletion (nfItem md ci) Nothing - nfItem :: MsgDirectionI d => SMsgDirection d -> ChatItem 'CTLocal d -> AChatItem - nfItem md = AChatItem SCTLocal md (LocalChat nf) - -deleteCIFiles :: User -> [CIFileInfo] -> CM () -deleteCIFiles user filesInfo = do - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo - -markDirectCIsDeleted :: User -> Contact -> [CChatItem 'CTDirect] -> Bool -> UTCTime -> CM ChatResponse -markDirectCIsDeleted user ct items byUser deletedTs = do - let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items - cancelFilesInProgress user ciFilesInfo - (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items) - unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure $ CRChatItemsDeleted user deletions byUser False - where - markDeleted db (CChatItem md ci) = do - ci' <- markDirectChatItemDeleted db user ct ci deletedTs - pure $ contactDeletion md ct ci (Just ci') - -markGroupCIsDeleted :: User -> GroupInfo -> [CChatItem 'CTGroup] -> Bool -> Maybe GroupMember -> UTCTime -> CM ChatResponse -markGroupCIsDeleted user gInfo items byUser byGroupMember_ deletedTs = do - let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items - cancelFilesInProgress user ciFilesInfo - (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items) - unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure $ CRChatItemsDeleted user deletions byUser False - where - markDeleted db (CChatItem md ci) = do - ci' <- markGroupChatItemDeleted db user gInfo ci byGroupMember_ deletedTs - pure $ groupDeletion md gInfo ci (Just ci') - -groupDeletion :: MsgDirectionI d => SMsgDirection d -> GroupInfo -> ChatItem 'CTGroup d -> Maybe (ChatItem 'CTGroup d) -> ChatItemDeletion -groupDeletion md g ci ci' = ChatItemDeletion (gItem ci) (gItem <$> ci') - where - gItem = AChatItem SCTGroup md (GroupChat g) - -contactDeletion :: MsgDirectionI d => SMsgDirection d -> Contact -> ChatItem 'CTDirect d -> Maybe (ChatItem 'CTDirect d) -> ChatItemDeletion -contactDeletion md ct ci ci' = ChatItemDeletion (ctItem ci) (ctItem <$> ci') - where - ctItem = AChatItem SCTDirect md (DirectChat ct) - -createAgentConnectionAsync :: ConnectionModeI c => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> CM (CommandId, ConnId) -createAgentConnectionAsync user cmdFunction enableNtfs cMode subMode = do - cmdId <- withStore' $ \db -> createCommand db user Nothing cmdFunction - connId <- withAgent $ \a -> createConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cMode IKPQOff subMode - pure (cmdId, connId) - -joinAgentConnectionAsync :: User -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> CM (CommandId, ConnId) -joinAgentConnectionAsync user enableNtfs cReqUri cInfo subMode = do - cmdId <- withStore' $ \db -> createCommand db user Nothing CFJoinConn - connId <- withAgent $ \a -> joinConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cReqUri cInfo PQSupportOff subMode - pure (cmdId, connId) - -allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> ChatMsgEvent e -> CM () -allowAgentConnectionAsync user conn@Connection {connId, pqSupport, connChatVersion} confId msg = do - cmdId <- withStore' $ \db -> createCommand db user (Just connId) CFAllowConn - dm <- encodeConnInfoPQ pqSupport connChatVersion msg - withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm - withStore' $ \db -> updateConnectionStatus db conn ConnAccepted - -agentAcceptContactAsync :: MsgEncodingI e => User -> Bool -> InvitationId -> ChatMsgEvent e -> SubscriptionMode -> PQSupport -> VersionChat -> CM (CommandId, ConnId) -agentAcceptContactAsync user enableNtfs invId msg subMode pqSup chatV = do - cmdId <- withStore' $ \db -> createCommand db user Nothing CFAcceptContact - dm <- encodeConnInfoPQ pqSup chatV msg - connId <- withAgent $ \a -> acceptContactAsync a (aCorrId cmdId) enableNtfs invId dm pqSup subMode - pure (cmdId, connId) - -deleteAgentConnectionAsync :: User -> ConnId -> CM () -deleteAgentConnectionAsync user acId = deleteAgentConnectionAsync' user acId False - -deleteAgentConnectionAsync' :: User -> ConnId -> Bool -> CM () -deleteAgentConnectionAsync' user acId waitDelivery = do - withAgent (\a -> deleteConnectionAsync a waitDelivery acId) `catchChatError` (toView . CRChatError (Just user)) - -deleteAgentConnectionsAsync :: User -> [ConnId] -> CM () -deleteAgentConnectionsAsync user acIds = deleteAgentConnectionsAsync' user acIds False - -deleteAgentConnectionsAsync' :: User -> [ConnId] -> Bool -> CM () -deleteAgentConnectionsAsync' _ [] _ = pure () -deleteAgentConnectionsAsync' user acIds waitDelivery = do - withAgent (\a -> deleteConnectionsAsync a waitDelivery acIds) `catchChatError` (toView . CRChatError (Just user)) - -agentXFTPDeleteRcvFile :: RcvFileId -> FileTransferId -> CM () -agentXFTPDeleteRcvFile aFileId fileId = do - lift $ withAgent' (`xftpDeleteRcvFile` aFileId) - withStore' $ \db -> setRcvFTAgentDeleted db fileId - -agentXFTPDeleteRcvFiles :: [(XFTPRcvFile, FileTransferId)] -> CM' () -agentXFTPDeleteRcvFiles rcvFiles = do - let rcvFiles' = filter (not . agentRcvFileDeleted . fst) rcvFiles - rfIds = mapMaybe fileIds rcvFiles' - withAgent' $ \a -> xftpDeleteRcvFiles a (map fst rfIds) - void . withStoreBatch' $ \db -> map (setRcvFTAgentDeleted db . snd) rfIds - where - fileIds :: (XFTPRcvFile, FileTransferId) -> Maybe (RcvFileId, FileTransferId) - fileIds (XFTPRcvFile {agentRcvFileId = Just (AgentRcvFileId aFileId)}, fileId) = Just (aFileId, fileId) - fileIds _ = Nothing - -agentXFTPDeleteSndFileRemote :: User -> XFTPSndFile -> FileTransferId -> CM' () -agentXFTPDeleteSndFileRemote user xsf fileId = - agentXFTPDeleteSndFilesRemote user [(xsf, fileId)] - -agentXFTPDeleteSndFilesRemote :: User -> [(XFTPSndFile, FileTransferId)] -> CM' () -agentXFTPDeleteSndFilesRemote user sndFiles = do - (_errs, redirects) <- partitionEithers <$> withStoreBatch' (\db -> map (lookupFileTransferRedirectMeta db user . snd) sndFiles) - let redirects' = mapMaybe mapRedirectMeta $ concat redirects - sndFilesAll = redirects' <> sndFiles - sndFilesAll' = filter (not . agentSndFileDeleted . fst) sndFilesAll - -- while file is being prepared and uploaded, it would not have description available; - -- this partitions files into those with and without descriptions - - -- files with description are deleted remotely, files without description are deleted internally - (sfsNoDescr, sfsWithDescr) <- partitionSndDescr sndFilesAll' [] [] - withAgent' $ \a -> xftpDeleteSndFilesInternal a sfsNoDescr - withAgent' $ \a -> xftpDeleteSndFilesRemote a (aUserId user) sfsWithDescr - void . withStoreBatch' $ \db -> map (setSndFTAgentDeleted db user . snd) sndFilesAll' - where - mapRedirectMeta :: FileTransferMeta -> Maybe (XFTPSndFile, FileTransferId) - mapRedirectMeta FileTransferMeta {fileId = fileId, xftpSndFile = Just sndFileRedirect} = Just (sndFileRedirect, fileId) - mapRedirectMeta _ = Nothing - partitionSndDescr :: - [(XFTPSndFile, FileTransferId)] -> - [SndFileId] -> - [(SndFileId, ValidFileDescription 'FSender)] -> - CM' ([SndFileId], [(SndFileId, ValidFileDescription 'FSender)]) - partitionSndDescr [] filesWithoutDescr filesWithDescr = pure (filesWithoutDescr, filesWithDescr) - partitionSndDescr ((XFTPSndFile {agentSndFileId = AgentSndFileId aFileId, privateSndFileDescr}, _) : xsfs) filesWithoutDescr filesWithDescr = - case privateSndFileDescr of - Nothing -> partitionSndDescr xsfs (aFileId : filesWithoutDescr) filesWithDescr - Just sfdText -> - tryChatError' (parseFileDescription sfdText) >>= \case - Left _ -> partitionSndDescr xsfs (aFileId : filesWithoutDescr) filesWithDescr - Right sfd -> partitionSndDescr xsfs filesWithoutDescr ((aFileId, sfd) : filesWithDescr) - -userProfileToSend :: User -> Maybe Profile -> Maybe Contact -> Bool -> Profile -userProfileToSend user@User {profile = p} incognitoProfile ct inGroup = do - let p' = fromMaybe (fromLocalProfile p) incognitoProfile - if inGroup - then redactedMemberProfile p' - else - let userPrefs = maybe (preferences' user) (const Nothing) incognitoProfile - in (p' :: Profile) {preferences = Just . toChatPrefs $ mergePreferences (userPreferences <$> ct) userPrefs} - -createRcvFeatureItems :: User -> Contact -> Contact -> CM' () -createRcvFeatureItems user ct ct' = - createFeatureItems user ct ct' CDDirectRcv CIRcvChatFeature CIRcvChatPreference contactPreference - -createSndFeatureItems :: User -> Contact -> Contact -> CM' () -createSndFeatureItems user ct ct' = - createFeatureItems user ct ct' CDDirectSnd CISndChatFeature CISndChatPreference getPref - where - getPref ContactUserPreference {userPreference} = case userPreference of - CUPContact {preference} -> preference - CUPUser {preference} -> preference - -createContactsSndFeatureItems :: User -> [ChangedProfileContact] -> CM' () -createContactsSndFeatureItems user cts = - createContactsFeatureItems user cts' CDDirectSnd CISndChatFeature CISndChatPreference getPref - where - cts' = map (\ChangedProfileContact {ct, ct'} -> (ct, ct')) cts - getPref ContactUserPreference {userPreference} = case userPreference of - CUPContact {preference} -> preference - CUPUser {preference} -> preference - -type FeatureContent a d = ChatFeature -> a -> Maybe Int -> CIContent d - -createFeatureItems :: - MsgDirectionI d => - User -> - Contact -> - Contact -> - (Contact -> ChatDirection 'CTDirect d) -> - FeatureContent PrefEnabled d -> - FeatureContent FeatureAllowed d -> - (forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) -> - CM' () -createFeatureItems user ct ct' = createContactsFeatureItems user [(ct, ct')] - -createContactsFeatureItems :: - forall d. - MsgDirectionI d => - User -> - [(Contact, Contact)] -> - (Contact -> ChatDirection 'CTDirect d) -> - FeatureContent PrefEnabled d -> - FeatureContent FeatureAllowed d -> - (forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) -> - CM' () -createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do - let dirsCIContents = map contactChangedFeatures cts - (errs, acis) <- partitionEithers <$> createInternalItemsForChats user Nothing dirsCIContents - unless (null errs) $ toView' $ CRChatErrors (Just user) errs - toView' $ CRNewChatItems user acis - where - contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, [CIContent d]) - contactChangedFeatures (Contact {mergedPreferences = cups}, ct'@Contact {mergedPreferences = cups'}) = do - let contents = mapMaybe (\(ACF f) -> featureCIContent_ f) allChatFeatures - (chatDir ct', contents) - where - featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d) - featureCIContent_ f - | state /= state' = Just $ fContent ciFeature state' - | prefState /= prefState' = Just $ fContent ciOffer prefState' - | otherwise = Nothing - where - fContent :: FeatureContent a d -> (a, Maybe Int) -> CIContent d - fContent ci (s, param) = ci f' s param - f' = chatFeature f - state = featureState cup - state' = featureState cup' - prefState = preferenceState $ getPref cup - prefState' = preferenceState $ getPref cup' - cup = getContactUserPreference f cups - cup' = getContactUserPreference f cups' - -createGroupFeatureChangedItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> GroupInfo -> CM () -createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences = gps} GroupInfo {fullGroupPreferences = gps'} = - forM_ allGroupFeatures $ \(AGF f) -> do - let state = groupFeatureState $ getGroupPreference f gps - pref' = getGroupPreference f gps' - state'@(_, param', role') = groupFeatureState pref' - when (state /= state') $ - createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref') param' role') Nothing - -sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool -sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing} - -createGroupFeatureItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> CM () -createGroupFeatureItems user cd ciContent GroupInfo {fullGroupPreferences} = - forM_ allGroupFeatures $ \(AGF f) -> do - let p = getGroupPreference f fullGroupPreferences - (_, param, role) = groupFeatureState p - createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing - -createInternalChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM () -createInternalChatItem user cd content itemTs_ = - lift (createInternalItemsForChats user itemTs_ [(cd, [content])]) >>= \case - [Right aci] -> toView $ CRNewChatItems user [aci] - [Left e] -> throwError e - rs -> throwChatError $ CEInternalError $ "createInternalChatItem: expected 1 result, got " <> show (length rs) - -createInternalItemsForChats :: - forall c d. - (ChatTypeI c, MsgDirectionI d) => - User -> - Maybe UTCTime -> - [(ChatDirection c d, [CIContent d])] -> - CM' [Either ChatError AChatItem] -createInternalItemsForChats user itemTs_ dirsCIContents = do - createdAt <- liftIO getCurrentTime - let itemTs = fromMaybe createdAt itemTs_ - void . withStoreBatch' $ \db -> map (uncurry $ updateChat db createdAt) dirsCIContents - withStoreBatch' $ \db -> concatMap (uncurry $ createACIs db itemTs createdAt) dirsCIContents - where - updateChat :: DB.Connection -> UTCTime -> ChatDirection c d -> [CIContent d] -> IO () - updateChat db createdAt cd contents - | any ciRequiresAttention contents || contactChatDeleted cd = updateChatTs db user cd createdAt - | otherwise = pure () - createACIs :: DB.Connection -> UTCTime -> UTCTime -> ChatDirection c d -> [CIContent d] -> [IO AChatItem] - createACIs db itemTs createdAt cd = map $ \content -> do - ciId <- createNewChatItemNoMsg db user cd content itemTs createdAt - let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing Nothing False itemTs Nothing createdAt - pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci - -createLocalChatItems :: - User -> - ChatDirection 'CTLocal 'MDSnd -> - [(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom)] -> - UTCTime -> - CM [ChatItem 'CTLocal 'MDSnd] -createLocalChatItems user cd itemsData createdAt = do - withStore' $ \db -> updateChatTs db user cd createdAt - (errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) itemsData) - unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure items - where - createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom) -> IO (ChatItem 'CTLocal 'MDSnd) - createItem db (content, ciFile, itemForwarded) = do - ciId <- createNewChatItem_ db user cd Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False createdAt Nothing createdAt - forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - pure $ mkChatItem cd ciId content ciFile Nothing Nothing itemForwarded Nothing False createdAt Nothing createdAt - -withUser' :: (User -> CM ChatResponse) -> CM ChatResponse -withUser' action = - asks currentUser - >>= readTVarIO - >>= maybe (throwChatError CENoActiveUser) run - where - run u = action u `catchChatError` (pure . CRChatCmdError (Just u)) - -withUser :: (User -> CM ChatResponse) -> CM ChatResponse -withUser action = withUser' $ \user -> - ifM (lift chatStarted) (action user) (throwChatError CEChatNotStarted) - -withUser_ :: CM ChatResponse -> CM ChatResponse -withUser_ = withUser . const - -withUserId' :: UserId -> (User -> CM ChatResponse) -> CM ChatResponse -withUserId' userId action = withUser' $ \user -> do - checkSameUser userId user - action user - -withUserId :: UserId -> (User -> CM ChatResponse) -> CM ChatResponse -withUserId userId action = withUser $ \user -> do - checkSameUser userId user - action user - -checkSameUser :: UserId -> User -> CM () -checkSameUser userId User {userId = activeUserId} = when (userId /= activeUserId) $ throwChatError (CEDifferentActiveUser userId activeUserId) - -chatStarted :: CM' Bool -chatStarted = fmap isJust . readTVarIO =<< asks agentAsync - -waitChatStartedAndActivated :: CM' () -waitChatStartedAndActivated = do - agentStarted <- asks agentAsync - chatActivated <- asks chatActivated - atomically $ do - started <- readTVar agentStarted - activated <- readTVar chatActivated - unless (isJust started && activated) retry - -chatVersionRange :: CM VersionRangeChat -chatVersionRange = lift chatVersionRange' -{-# INLINE chatVersionRange #-} - -chatVersionRange' :: CM' VersionRangeChat -chatVersionRange' = do - ChatConfig {chatVRange} <- asks config - pure chatVRange -{-# INLINE chatVersionRange' #-} - -chatCommandP :: Parser ChatCommand -chatCommandP = - choice - [ "/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, - "/_user " *> (APISetActiveUser <$> A.decimal <*> optional (A.space *> jsonP)), - ("/user " <|> "/u ") *> (SetActiveUser <$> displayName <*> optional (A.space *> pwdP)), - "/set receipts all " *> (SetAllContactReceipts <$> onOffP), - "/_set receipts contacts " *> (APISetUserContactReceipts <$> A.decimal <* A.space <*> receiptSettings), - "/set receipts contacts " *> (SetUserContactReceipts <$> receiptSettings), - "/_set receipts groups " *> (APISetUserGroupReceipts <$> A.decimal <* A.space <*> receiptSettings), - "/set receipts groups " *> (SetUserGroupReceipts <$> receiptSettings), - "/_hide user " *> (APIHideUser <$> A.decimal <* A.space <*> jsonP), - "/_unhide user " *> (APIUnhideUser <$> A.decimal <* A.space <*> jsonP), - "/_mute user " *> (APIMuteUser <$> A.decimal), - "/_unmute user " *> (APIUnmuteUser <$> A.decimal), - "/hide user " *> (HideUser <$> pwdP), - "/unhide user " *> (UnhideUser <$> pwdP), - "/mute user" $> MuteUser, - "/unmute user" $> UnmuteUser, - "/_delete user " *> (APIDeleteUser <$> A.decimal <* " del_smp=" <*> onOffP <*> optional (A.space *> jsonP)), - "/delete user " *> (DeleteUser <$> displayName <*> pure True <*> optional (A.space *> pwdP)), - ("/user" <|> "/u") $> ShowActiveUser, - "/_start " *> do - mainApp <- "main=" *> onOffP - enableSndFiles <- " snd_files=" *> onOffP <|> pure mainApp - pure StartChat {mainApp, enableSndFiles}, - "/_start" $> StartChat True True, - "/_check running" $> CheckChatRunning, - "/_stop" $> APIStopChat, - "/_app activate restore=" *> (APIActivateChat <$> onOffP), - "/_app activate" $> APIActivateChat True, - "/_app suspend " *> (APISuspendChat <$> A.decimal), - "/_resubscribe all" $> ResubscribeAllConnections, - -- deprecated, use /set file paths - "/_temp_folder " *> (SetTempFolder <$> filePath), - -- /_files_folder deprecated, use /set file paths - ("/_files_folder " <|> "/files_folder ") *> (SetFilesFolder <$> filePath), - -- deprecated, use /set file paths - "/remote_hosts_folder " *> (SetRemoteHostsFolder <$> filePath), - "/set file paths " *> (APISetAppFilePaths <$> jsonP), - "/_files_encrypt " *> (APISetEncryptLocalFiles <$> onOffP), - "/contact_merge " *> (SetContactMergeEnabled <$> onOffP), - "/_db export " *> (APIExportArchive <$> jsonP), - "/db export" $> ExportArchive, - "/_db import " *> (APIImportArchive <$> jsonP), - "/_db delete" $> APIDeleteStorage, - "/_db encryption " *> (APIStorageEncryption <$> jsonP), - "/db encrypt " *> (APIStorageEncryption . dbEncryptionConfig "" <$> dbKeyP), - "/db key " *> (APIStorageEncryption <$> (dbEncryptionConfig <$> dbKeyP <* A.space <*> dbKeyP)), - "/db decrypt " *> (APIStorageEncryption . (`dbEncryptionConfig` "") <$> dbKeyP), - "/db test key " *> (TestStorageEncryption <$> dbKeyP), - "/_save app settings" *> (APISaveAppSettings <$> jsonP), - "/_get app settings" *> (APIGetAppSettings <$> optional (A.space *> jsonP)), - "/sql chat " *> (ExecChatStoreSQL <$> textP), - "/sql agent " *> (ExecAgentStoreSQL <$> textP), - "/sql slow" $> SlowSQLQueries, - "/_get chats " - *> ( APIGetChats - <$> A.decimal - <*> (" pcc=on" $> True <|> " pcc=off" $> False <|> pure False) - <*> (A.space *> paginationByTimeP <|> pure (PTLast 5000)) - <*> (A.space *> jsonP <|> pure clqNoFilters) - ), - "/_get chat " *> (APIGetChat <$> chatRefP <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)), - "/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)), - "/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal), - "/_send " *> (APISendMessages <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), - "/_create *" *> (APICreateChatItems <$> A.decimal <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), - "/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP), - "/_delete item " *> (APIDeleteChatItem <$> chatRefP <*> _strP <* A.space <*> ciDeleteMode), - "/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <*> _strP), - "/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP), - "/_reaction members " *> (APIGetReactionMembers <$> A.decimal <* " #" <*> A.decimal <* A.space <*> A.decimal <* A.space <*> jsonP), - "/_forward plan " *> (APIPlanForwardChatItems <$> chatRefP <*> _strP), - "/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP), - "/_read user " *> (APIUserRead <$> A.decimal), - "/read user" $> UserRead, - "/_read chat " *> (APIChatRead <$> chatRefP), - "/_read chat items " *> (APIChatItemsRead <$> chatRefP <*> _strP), - "/_unread chat " *> (APIChatUnread <$> chatRefP <* A.space <*> onOffP), - "/_delete " *> (APIDeleteChat <$> chatRefP <*> chatDeleteMode), - "/_clear chat " *> (APIClearChat <$> chatRefP), - "/_accept" *> (APIAcceptContact <$> incognitoOnOffP <* A.space <*> A.decimal), - "/_reject " *> (APIRejectContact <$> A.decimal), - "/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP), - "/call " *> char_ '@' *> (SendCallInvitation <$> displayName <*> pure defaultCallType), - "/_call reject @" *> (APIRejectCall <$> A.decimal), - "/_call offer @" *> (APISendCallOffer <$> A.decimal <* A.space <*> jsonP), - "/_call answer @" *> (APISendCallAnswer <$> A.decimal <* A.space <*> jsonP), - "/_call extra @" *> (APISendCallExtraInfo <$> A.decimal <* A.space <*> jsonP), - "/_call end @" *> (APIEndCall <$> A.decimal), - "/_call status @" *> (APICallStatus <$> A.decimal <* A.space <*> strP), - "/_call get" $> APIGetCallInvitations, - "/_network_statuses" $> APIGetNetworkStatuses, - "/_profile " *> (APIUpdateProfile <$> A.decimal <* A.space <*> jsonP), - "/_set alias @" *> (APISetContactAlias <$> A.decimal <*> (A.space *> textP <|> pure "")), - "/_set alias :" *> (APISetConnectionAlias <$> A.decimal <*> (A.space *> textP <|> pure "")), - "/_set prefs @" *> (APISetContactPrefs <$> A.decimal <* A.space <*> jsonP), - "/_set theme user " *> (APISetUserUIThemes <$> A.decimal <*> optional (A.space *> jsonP)), - "/_set theme " *> (APISetChatUIThemes <$> chatRefP <*> optional (A.space *> jsonP)), - "/_parse " *> (APIParseMarkdown . safeDecodeUtf8 <$> A.takeByteString), - "/_ntf get" $> APIGetNtfToken, - "/_ntf register " *> (APIRegisterToken <$> strP_ <*> strP), - "/_ntf verify " *> (APIVerifyToken <$> strP <* A.space <*> strP <* A.space <*> strP), - "/_ntf delete " *> (APIDeleteToken <$> strP), - "/_ntf conns " *> (APIGetNtfConns <$> strP <* A.space <*> strP), - "/_ntf conn messages " *> (ApiGetConnNtfMessages <$> strP), - "/_add #" *> (APIAddMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole), - "/_join #" *> (APIJoinGroup <$> A.decimal), - "/_member role #" *> (APIMemberRole <$> A.decimal <* A.space <*> A.decimal <*> memberRole), - "/_block #" *> (APIBlockMemberForAll <$> A.decimal <* A.space <*> A.decimal <* A.space <* "blocked=" <*> onOffP), - "/_remove #" *> (APIRemoveMember <$> A.decimal <* A.space <*> A.decimal), - "/_leave #" *> (APILeaveGroup <$> A.decimal), - "/_members #" *> (APIListMembers <$> A.decimal), - "/_server test " *> (APITestProtoServer <$> A.decimal <* A.space <*> strP), - "/smp test " *> (TestProtoServer . AProtoServerWithAuth SPSMP <$> strP), - "/xftp test " *> (TestProtoServer . AProtoServerWithAuth SPXFTP <$> strP), - "/ntf test " *> (TestProtoServer . AProtoServerWithAuth SPNTF <$> strP), - "/smp " *> (SetUserProtoServers (AProtocolType SPSMP) . map (AProtoServerWithAuth SPSMP) <$> protocolServersP), - "/xftp " *> (SetUserProtoServers (AProtocolType SPXFTP) . map (AProtoServerWithAuth SPXFTP) <$> protocolServersP), - "/smp" $> GetUserProtoServers (AProtocolType SPSMP), - "/xftp" $> GetUserProtoServers (AProtocolType SPXFTP), - "/_operators" $> APIGetServerOperators, - "/_operators " *> (APISetServerOperators <$> jsonP), - "/operators " *> (SetServerOperators . L.fromList <$> operatorRolesP `A.sepBy1` A.char ','), - "/_servers " *> (APIGetUserServers <$> A.decimal), - "/_servers " *> (APISetUserServers <$> A.decimal <* A.space <*> jsonP), - "/_validate_servers " *> (APIValidateServers <$> A.decimal <* A.space <*> jsonP), - "/_conditions" $> APIGetUsageConditions, - "/_conditions_notified " *> (APISetConditionsNotified <$> A.decimal), - "/_accept_conditions " *> (APIAcceptConditions <$> A.decimal <*> _strP), - "/_ttl " *> (APISetChatItemTTL <$> A.decimal <* A.space <*> ciTTLDecimal), - "/ttl " *> (SetChatItemTTL <$> ciTTL), - "/_ttl " *> (APIGetChatItemTTL <$> A.decimal), - "/ttl" $> GetChatItemTTL, - "/_network info " *> (APISetNetworkInfo <$> jsonP), - "/_network " *> (APISetNetworkConfig <$> jsonP), - ("/network " <|> "/net ") *> (SetNetworkConfig <$> netCfgP), - ("/network" <|> "/net") $> APIGetNetworkConfig, - "/reconnect " *> (ReconnectServer <$> A.decimal <* A.space <*> strP), - "/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), - ("/info #" <|> "/i #") *> (GroupMemberInfo <$> displayName <* A.space <* char_ '@' <*> displayName), - ("/info #" <|> "/i #") *> (ShowGroupInfo <$> displayName), - ("/info " <|> "/i ") *> char_ '@' *> (ContactInfo <$> displayName), - "/_queue info #" *> (APIGroupMemberQueueInfo <$> A.decimal <* A.space <*> A.decimal), - "/_queue info @" *> (APIContactQueueInfo <$> A.decimal), - ("/queue info #" <|> "/qi #") *> (GroupMemberQueueInfo <$> displayName <* A.space <* char_ '@' <*> displayName), - ("/queue info " <|> "/qi ") *> char_ '@' *> (ContactQueueInfo <$> displayName), - "/_switch #" *> (APISwitchGroupMember <$> A.decimal <* A.space <*> A.decimal), - "/_switch @" *> (APISwitchContact <$> A.decimal), - "/_abort switch #" *> (APIAbortSwitchGroupMember <$> A.decimal <* A.space <*> A.decimal), - "/_abort switch @" *> (APIAbortSwitchContact <$> A.decimal), - "/_sync #" *> (APISyncGroupMemberRatchet <$> A.decimal <* A.space <*> A.decimal <*> (" force=on" $> True <|> pure False)), - "/_sync @" *> (APISyncContactRatchet <$> A.decimal <*> (" force=on" $> True <|> pure False)), - "/switch #" *> (SwitchGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName), - "/switch " *> char_ '@' *> (SwitchContact <$> displayName), - "/abort switch #" *> (AbortSwitchGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName), - "/abort switch " *> char_ '@' *> (AbortSwitchContact <$> displayName), - "/sync #" *> (SyncGroupMemberRatchet <$> displayName <* A.space <* char_ '@' <*> displayName <*> (" force=on" $> True <|> pure False)), - "/sync " *> char_ '@' *> (SyncContactRatchet <$> displayName <*> (" force=on" $> True <|> pure False)), - "/_get code @" *> (APIGetContactCode <$> A.decimal), - "/_get code #" *> (APIGetGroupMemberCode <$> A.decimal <* A.space <*> A.decimal), - "/_verify code @" *> (APIVerifyContact <$> A.decimal <*> optional (A.space *> verifyCodeP)), - "/_verify code #" *> (APIVerifyGroupMember <$> A.decimal <* A.space <*> A.decimal <*> optional (A.space *> verifyCodeP)), - "/_enable @" *> (APIEnableContact <$> A.decimal), - "/_enable #" *> (APIEnableGroupMember <$> A.decimal <* A.space <*> A.decimal), - "/code " *> char_ '@' *> (GetContactCode <$> displayName), - "/code #" *> (GetGroupMemberCode <$> displayName <* A.space <* char_ '@' <*> displayName), - "/verify " *> char_ '@' *> (VerifyContact <$> displayName <*> optional (A.space *> verifyCodeP)), - "/verify #" *> (VerifyGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> optional (A.space *> verifyCodeP)), - "/enable " *> char_ '@' *> (EnableContact <$> displayName), - "/enable #" *> (EnableGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName), - ("/help files" <|> "/help file" <|> "/hf") $> ChatHelp HSFiles, - ("/help groups" <|> "/help group" <|> "/hg") $> ChatHelp HSGroups, - ("/help contacts" <|> "/help contact" <|> "/hc") $> ChatHelp HSContacts, - ("/help address" <|> "/ha") $> ChatHelp HSMyAddress, - ("/help incognito" <|> "/hi") $> ChatHelp HSIncognito, - ("/help messages" <|> "/hm") $> ChatHelp HSMessages, - ("/help remote" <|> "/hr") $> ChatHelp HSRemote, - ("/help settings" <|> "/hs") $> ChatHelp HSSettings, - ("/help db" <|> "/hd") $> ChatHelp HSDatabase, - ("/help" <|> "/h") $> ChatHelp HSMain, - ("/group" <|> "/g") *> (NewGroup <$> incognitoP <* A.space <* char_ '#' <*> groupProfile), - "/_group " *> (APINewGroup <$> A.decimal <*> incognitoOnOffP <* A.space <*> jsonP), - ("/add " <|> "/a ") *> char_ '#' *> (AddMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> (memberRole <|> pure GRMember)), - ("/join " <|> "/j ") *> char_ '#' *> (JoinGroup <$> displayName), - ("/member role " <|> "/mr ") *> char_ '#' *> (MemberRole <$> displayName <* A.space <* char_ '@' <*> displayName <*> memberRole), - "/block for all #" *> (BlockForAll <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure True), - "/unblock for all #" *> (BlockForAll <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure False), - ("/remove " <|> "/rm ") *> char_ '#' *> (RemoveMember <$> displayName <* A.space <* char_ '@' <*> displayName), - ("/leave " <|> "/l ") *> char_ '#' *> (LeaveGroup <$> displayName), - ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName), - ("/delete " <|> "/d ") *> char_ '@' *> (DeleteContact <$> displayName <*> chatDeleteMode), - "/clear *" $> ClearNoteFolder, - "/clear #" *> (ClearGroup <$> displayName), - "/clear " *> char_ '@' *> (ClearContact <$> displayName), - ("/members " <|> "/ms ") *> char_ '#' *> (ListMembers <$> displayName), - "/_groups" *> (APIListGroups <$> A.decimal <*> optional (" @" *> A.decimal) <*> optional (A.space *> stringP)), - ("/groups" <|> "/gs") *> (ListGroups <$> optional (" @" *> displayName) <*> optional (A.space *> stringP)), - "/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP), - ("/group_profile " <|> "/gp ") *> char_ '#' *> (UpdateGroupNames <$> displayName <* A.space <*> groupProfile), - ("/group_profile " <|> "/gp ") *> char_ '#' *> (ShowGroupProfile <$> displayName), - "/group_descr " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> optional (A.space *> msgTextP)), - "/set welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayName <* A.space <*> (Just <$> msgTextP)), - "/delete welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> pure Nothing), - "/show welcome " *> char_ '#' *> (ShowGroupDescription <$> displayName), - "/_create link #" *> (APICreateGroupLink <$> A.decimal <*> (memberRole <|> pure GRMember)), - "/_set link role #" *> (APIGroupLinkMemberRole <$> A.decimal <*> memberRole), - "/_delete link #" *> (APIDeleteGroupLink <$> A.decimal), - "/_get link #" *> (APIGetGroupLink <$> A.decimal), - "/create link #" *> (CreateGroupLink <$> displayName <*> (memberRole <|> pure GRMember)), - "/set link role #" *> (GroupLinkMemberRole <$> displayName <*> memberRole), - "/delete link #" *> (DeleteGroupLink <$> displayName), - "/show link #" *> (ShowGroupLink <$> displayName), - "/_create member contact #" *> (APICreateMemberContact <$> A.decimal <* A.space <*> A.decimal), - "/_invite member contact @" *> (APISendMemberContactInvitation <$> A.decimal <*> optional (A.space *> msgContentP)), - (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> msgTextP), - (">#" <|> "> #") *> (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), - "/_set conn user :" *> (APIChangeConnectionUser <$> A.decimal <* A.space <*> A.decimal), - ("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeTill isSpace $> Nothing)), - ("/connect" <|> "/c") *> (AddContact <$> incognitoP), - ForwardMessage <$> chatNameP <* " <- @" <*> displayName <* A.space <*> msgTextP, - ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayName <* A.space <* A.char '@' <*> (Just <$> displayName) <* A.space <*> msgTextP, - ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayName <*> pure Nothing <* A.space <*> msgTextP, - ForwardLocalMessage <$> chatNameP <* " <- * " <*> msgTextP, - SendMessage <$> chatNameP <* A.space <*> msgTextP, - "/* " *> (SendMessage (ChatName CTLocal "") <$> msgTextP), - "@#" *> (SendMemberContactMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> msgTextP), - "/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> msgTextP <|> pure "")), - (">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv), - (">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd), - ("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> textP), - ("\\\\ #" <|> "\\\\#") *> (DeleteMemberMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> textP), - ("! " <|> "!") *> (EditMessage <$> chatNameP <* A.space <*> (quotedMsg <|> pure "") <*> msgTextP), - ReactToMessage <$> (("+" $> True) <|> ("-" $> False)) <*> reactionP <* A.space <*> chatNameP' <* A.space <*> textP, - "/feed " *> (SendMessageBroadcast <$> msgTextP), - ("/chats" <|> "/cs") *> (LastChats <$> (" all" $> Nothing <|> Just <$> (A.space *> A.decimal <|> pure 20))), - ("/tail" <|> "/t") *> (LastMessages <$> optional (A.space *> chatNameP) <*> msgCountP <*> pure Nothing), - ("/search" <|> "/?") *> (LastMessages <$> optional (A.space *> chatNameP) <*> msgCountP <*> (Just <$> (A.space *> stringP))), - "/last_item_id" *> (LastChatItemId <$> optional (A.space *> chatNameP) <*> (A.space *> A.decimal <|> pure 0)), - "/show" *> (ShowLiveItems <$> (A.space *> onOffP <|> pure True)), - "/show " *> (ShowChatItem . Just <$> A.decimal), - "/item info " *> (ShowChatItemInfo <$> chatNameP <* A.space <*> msgTextP), - ("/file " <|> "/f ") *> (SendFile <$> chatNameP' <* A.space <*> cryptoFileP), - ("/image " <|> "/img ") *> (SendImage <$> chatNameP' <* A.space <*> cryptoFileP), - ("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal), - ("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal), - ("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath), - ("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> (" approved_relays=" *> onOffP <|> pure False) <*> optional (" encrypt=" *> onOffP) <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)), - "/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal <*> (" approved_relays=" *> onOffP <|> pure False) <*> optional (" encrypt=" *> onOffP)), - ("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal), - ("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal), - "/_connect contact " *> (APIConnectContactViaAddress <$> A.decimal <*> incognitoOnOffP <* A.space <*> A.decimal), - "/simplex" *> (ConnectSimplex <$> incognitoP), - "/_address " *> (APICreateMyAddress <$> A.decimal), - ("/address" <|> "/ad") $> CreateMyAddress, - "/_delete_address " *> (APIDeleteMyAddress <$> A.decimal), - ("/delete_address" <|> "/da") $> DeleteMyAddress, - "/_show_address " *> (APIShowMyAddress <$> A.decimal), - ("/show_address" <|> "/sa") $> ShowMyAddress, - "/_profile_address " *> (APISetProfileAddress <$> A.decimal <* A.space <*> onOffP), - ("/profile_address " <|> "/pa ") *> (SetProfileAddress <$> onOffP), - "/_auto_accept " *> (APIAddressAutoAccept <$> A.decimal <* A.space <*> autoAcceptP), - "/auto_accept " *> (AddressAutoAccept <$> autoAcceptP), - ("/accept" <|> "/ac") *> (AcceptContact <$> incognitoP <* A.space <* char_ '@' <*> displayName), - ("/reject " <|> "/rc ") *> char_ '@' *> (RejectContact <$> displayName), - ("/markdown" <|> "/m") $> ChatHelp HSMarkdown, - ("/welcome" <|> "/w") $> Welcome, - "/set profile image " *> (UpdateProfileImage . Just . ImageData <$> imageP), - "/delete profile image" $> UpdateProfileImage Nothing, - "/show profile image" $> ShowProfileImage, - ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> profileNames), - ("/profile" <|> "/p") $> ShowProfile, - "/set voice #" *> (SetGroupFeatureRole (AGFR SGFVoice) <$> displayName <*> _strP <*> optional memberRole), - "/set voice @" *> (SetContactFeature (ACF SCFVoice) <$> displayName <*> optional (A.space *> strP)), - "/set voice " *> (SetUserFeature (ACF SCFVoice) <$> strP), - "/set files #" *> (SetGroupFeatureRole (AGFR SGFFiles) <$> displayName <*> _strP <*> optional memberRole), - "/set history #" *> (SetGroupFeature (AGFNR SGFHistory) <$> displayName <*> (A.space *> strP)), - "/set reactions #" *> (SetGroupFeature (AGFNR SGFReactions) <$> displayName <*> (A.space *> strP)), - "/set calls @" *> (SetContactFeature (ACF SCFCalls) <$> displayName <*> optional (A.space *> strP)), - "/set calls " *> (SetUserFeature (ACF SCFCalls) <$> strP), - "/set delete #" *> (SetGroupFeature (AGFNR SGFFullDelete) <$> displayName <*> (A.space *> strP)), - "/set delete @" *> (SetContactFeature (ACF SCFFullDelete) <$> displayName <*> optional (A.space *> strP)), - "/set delete " *> (SetUserFeature (ACF SCFFullDelete) <$> strP), - "/set direct #" *> (SetGroupFeatureRole (AGFR SGFDirectMessages) <$> displayName <*> _strP <*> optional memberRole), - "/set disappear #" *> (SetGroupTimedMessages <$> displayName <*> (A.space *> timedTTLOnOffP)), - "/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)), - "/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))), - "/set links #" *> (SetGroupFeatureRole (AGFR SGFSimplexLinks) <$> displayName <*> _strP <*> optional memberRole), - ("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito, - "/set device name " *> (SetLocalDeviceName <$> textP), - "/list remote hosts" $> ListRemoteHosts, - "/switch remote host " *> (SwitchRemoteHost <$> ("local" $> Nothing <|> (Just <$> A.decimal))), - "/start remote host " *> (StartRemoteHost <$> ("new" $> Nothing <|> (Just <$> ((,) <$> A.decimal <*> (" multicast=" *> onOffP <|> pure False)))) <*> optional (A.space *> rcCtrlAddressP) <*> optional (" port=" *> A.decimal)), - "/stop remote host " *> (StopRemoteHost <$> ("new" $> RHNew <|> RHId <$> A.decimal)), - "/delete remote host " *> (DeleteRemoteHost <$> A.decimal), - "/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath), - "/get remote file " *> (GetRemoteFile <$> A.decimal <* A.space <*> jsonP), - ("/connect remote ctrl " <|> "/crc ") *> (ConnectRemoteCtrl <$> strP), - "/find remote ctrl" $> FindKnownRemoteCtrl, - "/confirm remote ctrl " *> (ConfirmRemoteCtrl <$> A.decimal), - "/verify remote ctrl " *> (VerifyRemoteCtrlSession <$> textP), - "/list remote ctrls" $> ListRemoteCtrls, - "/stop remote ctrl" $> StopRemoteCtrl, - "/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal), - "/_upload " *> (APIUploadStandaloneFile <$> A.decimal <* A.space <*> cryptoFileP), - "/_download info " *> (APIStandaloneFileInfo <$> strP), - "/_download " *> (APIDownloadStandaloneFile <$> A.decimal <* A.space <*> strP_ <*> cryptoFileP), - ("/quit" <|> "/q" <|> "/exit") $> QuitChat, - ("/version" <|> "/v") $> ShowVersion, - "/debug locks" $> DebugLocks, - "/debug event " *> (DebugEvent <$> jsonP), - "/get subs total " *> (GetAgentSubsTotal <$> A.decimal), - "/get servers summary " *> (GetAgentServersSummary <$> A.decimal), - "/reset servers stats" $> ResetAgentServersStats, - "/get subs" $> GetAgentSubs, - "/get subs details" $> GetAgentSubsDetails, - "/get workers" $> GetAgentWorkers, - "/get workers details" $> GetAgentWorkersDetails, - "/get queues" $> GetAgentQueuesInfo, - "//" *> (CustomChatCommand <$> A.takeByteString) - ] - where - choice = A.choice . map (\p -> p <* A.takeWhile (== ' ') <* A.endOfInput) - incognitoP = (A.space *> ("incognito" <|> "i")) $> True <|> pure False - incognitoOnOffP = (A.space *> "incognito=" *> onOffP) <|> pure False - imagePrefix = (<>) <$> "data:" <*> ("image/png;base64," <|> "image/jpg;base64,") - imageP = safeDecodeUtf8 <$> ((<>) <$> imagePrefix <*> (B64.encode <$> base64P)) - chatTypeP = A.char '@' $> CTDirect <|> A.char '#' $> CTGroup <|> A.char '*' $> CTLocal <|> A.char ':' $> CTContactConnection - chatPaginationP = - (CPLast <$ "count=" <*> A.decimal) - <|> (CPAfter <$ "after=" <*> A.decimal <* A.space <* "count=" <*> A.decimal) - <|> (CPBefore <$ "before=" <*> A.decimal <* A.space <* "count=" <*> A.decimal) - <|> (CPAround <$ "around=" <*> A.decimal <* A.space <* "count=" <*> A.decimal) - <|> (CPInitial <$ "initial=" <*> A.decimal) - paginationByTimeP = - (PTLast <$ "count=" <*> A.decimal) - <|> (PTAfter <$ "after=" <*> strP <* A.space <* "count=" <*> A.decimal) - <|> (PTBefore <$ "before=" <*> strP <* A.space <* "count=" <*> A.decimal) - mcTextP = MCText . safeDecodeUtf8 <$> A.takeByteString - msgContentP = "text " *> mcTextP <|> "json " *> jsonP - ciDeleteMode = "broadcast" $> CIDMBroadcast <|> "internal" $> CIDMInternal - chatDeleteMode = - A.choice - [ " full" *> (CDMFull <$> notifyP), - " entity" *> (CDMEntity <$> notifyP), - " messages" $> CDMMessages, - CDMFull <$> notifyP -- backwards compatible - ] - where - notifyP = " notify=" *> onOffP <|> pure True - displayName = safeDecodeUtf8 <$> (quoted "'" <|> takeNameTill isSpace) - where - takeNameTill p = - A.peekChar' >>= \c -> - if refChar c then A.takeTill p else fail "invalid first character in display name" - quoted cs = A.choice [A.char c *> takeNameTill (== c) <* A.char c | c <- cs] - refChar c = c > ' ' && c /= '#' && c /= '@' - sendMsgQuote msgDir = SendMessageQuote <$> displayName <* A.space <*> pure msgDir <*> quotedMsg <*> msgTextP - quotedMsg = safeDecodeUtf8 <$> (A.char '(' *> A.takeTill (== ')') <* A.char ')') <* optional A.space - reactionP = MREmoji <$> (mrEmojiChar <$?> (toEmoji <$> A.anyChar)) - toEmoji = \case - '1' -> '👍' - '+' -> '👍' - '-' -> '👎' - ')' -> '😀' - ',' -> '😢' - '*' -> head "❤️" - '^' -> '🚀' - c -> c - composedMessagesTextP = do - text <- mcTextP - pure $ (ComposedMessage Nothing Nothing text) :| [] - liveMessageP = " live=" *> onOffP <|> pure False - sendMessageTTLP = " ttl=" *> ((Just <$> A.decimal) <|> ("default" $> Nothing)) <|> pure Nothing - receiptSettings = do - enable <- onOffP - clearOverrides <- (" clear_overrides=" *> onOffP) <|> pure False - pure UserMsgReceiptSettings {enable, clearOverrides} - onOffP = ("on" $> True) <|> ("off" $> False) - profileNames = (,) <$> displayName <*> fullNameP - newUserP = do - (cName, fullName) <- profileNames - let profile = Just Profile {displayName = cName, fullName, image = Nothing, contactLink = Nothing, preferences = Nothing} - pure NewUser {profile, pastTimestamp = False} - jsonP :: J.FromJSON a => Parser a - jsonP = J.eitherDecodeStrict' <$?> A.takeByteString - groupProfile = do - (gName, fullName) <- profileNames - let groupPreferences = - Just - (emptyGroupPrefs :: GroupPreferences) - { directMessages = Just DirectMessagesGroupPreference {enable = FEOn, role = Nothing}, - history = Just HistoryGroupPreference {enable = FEOn} - } - pure GroupProfile {displayName = gName, fullName, description = Nothing, image = Nothing, groupPreferences} - fullNameP = A.space *> textP <|> pure "" - textP = safeDecodeUtf8 <$> A.takeByteString - pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' ')) - verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ') - msgTextP = jsonP <|> textP - stringP = T.unpack . safeDecodeUtf8 <$> A.takeByteString - filePath = stringP - cryptoFileP = do - cfArgs <- optional $ CFArgs <$> (" key=" *> strP <* A.space) <*> (" nonce=" *> strP) - path <- filePath - pure $ CryptoFile path cfArgs - memberRole = - A.choice - [ " owner" $> GROwner, - " admin" $> GRAdmin, - " member" $> GRMember, - " observer" $> GRObserver - ] - chatNameP = - chatTypeP >>= \case - CTLocal -> pure $ ChatName CTLocal "" - ct -> ChatName ct <$> displayName - chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayName - chatRefP = ChatRef <$> chatTypeP <*> A.decimal - msgCountP = A.space *> A.decimal <|> pure 10 - ciTTLDecimal = ("none" $> Nothing) <|> (Just <$> A.decimal) - ciTTL = - ("day" $> Just 86400) - <|> ("week" $> Just (7 * 86400)) - <|> ("month" $> Just (30 * 86400)) - <|> ("none" $> Nothing) - timedTTLP = - ("30s" $> 30) - <|> ("5min" $> 300) - <|> ("1h" $> 3600) - <|> ("8h" $> (8 * 3600)) - <|> ("day" $> 86400) - <|> ("week" $> (7 * 86400)) - <|> ("month" $> (30 * 86400)) - <|> A.decimal - timedTTLOnOffP = - optional ("on" *> A.space) *> (Just <$> timedTTLP) - <|> ("off" $> Nothing) - timedMessagesEnabledP = - optional ("yes" *> A.space) *> (TMEEnableSetTTL <$> timedTTLP) - <|> ("yes" $> TMEEnableKeepTTL) - <|> ("no" $> TMEDisableKeepTTL) - operatorRolesP = do - operatorId' <- A.decimal - enabled' <- A.char ':' *> onOffP - smpRoles' <- (":smp=" *> srvRolesP) <|> pure allRoles - xftpRoles' <- (":xftp=" *> srvRolesP) <|> pure allRoles - pure ServerOperatorRoles {operatorId', enabled', smpRoles', xftpRoles'} - srvRolesP = srvRoles <$?> A.takeTill (\c -> c == ':' || c == ',') - where - srvRoles = \case - "off" -> Right $ ServerRoles False False - "proxy" -> Right ServerRoles {storage = False, proxy = True} - "storage" -> Right ServerRoles {storage = True, proxy = False} - "on" -> Right allRoles - _ -> Left "bad ServerRoles" - netCfgP = do - socksProxy <- "socks=" *> ("off" $> Nothing <|> "on" $> Just defaultSocksProxyWithAuth <|> Just <$> strP) - socksMode <- " socks-mode=" *> strP <|> pure SMAlways - hostMode <- " host-mode=" *> (textToHostMode . safeDecodeUtf8 <$?> A.takeTill (== ' ')) <|> pure (defaultHostMode socksProxy) - requiredHostMode <- (" required-host-mode" $> True) <|> pure False - smpProxyMode_ <- optional $ " smp-proxy=" *> strP - smpProxyFallback_ <- optional $ " smp-proxy-fallback=" *> strP - smpWebPort <- (" smp-web-port" $> True) <|> pure False - t_ <- optional $ " timeout=" *> A.decimal - logTLSErrors <- " log=" *> onOffP <|> pure False - let tcpTimeout_ = (1000000 *) <$> t_ - pure $ SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} - dbKeyP = nonEmptyKey <$?> strP - nonEmptyKey k@(DBEncryptionKey s) = if BA.null s then Left "empty key" else Right k - dbEncryptionConfig currentKey newKey = DBEncryptionConfig {currentKey, newKey, keepKey = Just False} - autoAcceptP = ifM onOffP (Just <$> (businessAA <|> addressAA)) (pure Nothing) - where - addressAA = AutoAccept False <$> (" incognito=" *> onOffP <|> pure False) <*> autoReply - businessAA = AutoAccept True <$> (" business" *> pure False) <*> autoReply - autoReply = optional (A.space *> msgContentP) - rcCtrlAddressP = RCCtrlAddress <$> ("addr=" *> strP) <*> (" iface=" *> (jsonP <|> text1P)) - text1P = safeDecodeUtf8 <$> A.takeTill (== ' ') - char_ = optional . A.char - -adminContactReq :: ConnReqContact -adminContactReq = - either error id $ strDecode "simplex:/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23MCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%3D" - -simplexTeamContactProfile :: Profile -simplexTeamContactProfile = - Profile - { displayName = "SimpleX Chat team", - fullName = "", - image = Just (ImageData "data:image/jpg;base64,/9j/4AAQSkZJRgABAgAAAQABAAD/2wBDAAUDBAQEAwUEBAQFBQUGBwwIBwcHBw8KCwkMEQ8SEhEPERATFhwXExQaFRARGCEYGhwdHx8fExciJCIeJBweHx7/2wBDAQUFBQcGBw4ICA4eFBEUHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh7/wAARCAETARMDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREAAgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD7LooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiivP/iF4yFvv0rSpAZek0yn7v+yPeunC4WpiqihBf8A8rOc5w2UYZ4jEPTourfZDvH3jL7MW03SpR53SWUfw+w96veA/F0erRLY3zKl6owD2k/8Ar15EWLEljknqadDK8MqyxMUdTlWB5Br66WS0Hh/ZLfv1ufiNLj7Mo5m8ZJ3g9OTpy+Xn5/pofRdFcd4B8XR6tEthfMEvVHyk9JB/jXY18fiMPUw9R06i1P3PK80w2aYaOIw8rxf3p9n5hRRRWB6AUUVDe3UFlavc3MixxIMsxppNuyJnOMIuUnZIL26gsrV7m5kWOJBlmNeU+I/Gd9e6sk1hI8FvA2Y1z973NVPGnimfXLoxRFo7JD8if3vc1zefevr8syiNKPtKyvJ9Ox+F8Ycb1cdU+rYCTjTi/iWjk1+nbue3eEPEdtrtoMER3SD95Hn9R7Vu18+6bf3On3kd1aSmOVDkEd/Y17J4P8SW2vWY6R3aD97F/Ue1eVmmVPDP2lP4fyPtODeMoZrBYXFO1Zf+Tf8AB7r5o3qKKK8Q/QgooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAqavbTXmmz20Fw1vJIhVZB1FeDa3p15pWoSWl6hWQHr2YeoNfQlY3izw9Z6/YGGZQky8xSgcqf8K9jKcyWEnyzXuv8D4njLhZ51RVSi7VYLRdGu3k+z+88HzRuq1rWmXmkX8lnexFHU8Hsw9RVLNfcxlGcVKLumfgFahUozdOorSWjT6E0M0kMqyxOyOpyrKcEGvXPAPjCPVolsb9wl6owGPAkH+NeO5p8M0kMqyxOyOpyrA4INcWPy+njKfLLfoz2+HuIMTkmI9pT1i/ij0a/wA+zPpGiuM+H/jCPV4lsL91S+QfKTwJR/jXW3t1BZWslzcyLHFGMsxNfB4jC1aFX2U1r+fof0Rl2bYXMMKsVRl7vXy7p9rBfXVvZWr3NzKscSDLMTXjnjbxVPrtyYoiY7JD8if3vc0zxv4ruNeujFEWjsoz8if3vc1zOa+synKFh0qtVe9+X/BPxvjLjKWZSeEwjtSW7/m/4H5kmaM1HmlB54r3bH51YkzXo3wz8MXMc0es3ZeED/VR5wW9z7VB8O/BpnMerarEREDuhhb+L3Pt7V6cAAAAAAOgFfL5xmqs6FH5v9D9a4H4MlzQzHGq1tYR/KT/AEXzCiiivlj9hCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxfFvh208QWBhmASdRmKUdVP+FeH63pl5pGoSWV5EUdTwezD1HtX0VWL4t8O2fiHTzBONk6g+TKByp/wr28pzZ4WXs6msH+B8NxdwhTzeDxGHVqy/8m8n59n954FmjNW9b0y80fUHsr2MpIp4PZh6iqWfevuYyjOKlF3TPwetQnRm6dRWktGmSwzSQyrLE7I6nKsDgg1teIPFOqa3a29vdy4jiUAheN7f3jWBmjNROhTnJTkrtbGtLF4ijSnRpzajPddHbuP3e9Lmo80ua0scth+a9E+HXgw3Hl6tqsZEX3oYmH3vc+1J8OPBZnKavq0eIhzDCw+9/tH29q9SAAAAGAOgr5bOM35b0KD16v8ARH6twXwXz8uPx0dN4xfXzf6IFAUAAAAdBRRRXyZ+wBRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFB4GTXyj+1p+0ONJjufA3ga6DX7qU1DUY24gB4McZH8Xqe38tqFCdefLETaSufQ3h/4geEde8Uah4a0rWra51Ow/wBfCrD8ceuO+OldRX5I+GfEWseG/ENvr2j30ttqFvJ5iSqxyT3z6g96/RH9nD41aT8U9AWGcx2fiK1QC7tC33/+mieqn07V14zL3QXNHVEQnc9dooorzjQKKKKACiis7xHrel+HdGudY1m8is7K2QvLLI2AAP600m3ZAYfxUg8Pr4VutT1+7isYbSMuLp/4Pb3z6V8++HNd0zxDpq6hpVys8DHGRwVPoR2NeIftJ/G7VPifrbWVk8lp4btZD9mtwcGU/wDPR/c9h2rgfh34z1LwdrAurV2ktZCBcW5PyyD/AB9DX2WTyqYWny1Ho+nY+C4t4Wp5tF16CtVX/k3k/Ps/vPr/ADRmsjwx4g07xFpMWpaZOJInHI/iQ9wR61qbq+mVmro/D6tCdGbp1FZrdEma6/4XafpWoa7jUpV3oA0MLdJD/ntXG5p8E0kMqyxOyOhyrKcEGsMTRlWpShGVm+p1ZbiYYPFQr1IKai72fU+nFAUAKAAOABRXEfDnxpFrMK6fqDhL9BhSeko9frXb1+a4rDVMNUdOotT+k8szLD5lh44jDu8X968n5hRRRXOegFFFFABUGoXlvYWkl1dSrHFGMliaL+7t7C0kuruVYoYxlmNeI+OvFtx4huzHFuisYz+7jz97/aNenluW1MbU00it2fM8S8SUMkoXetR/DH9X5fmeteF/E+m+IFkFoxSWMnMb9cev0rbr5t0vULrTb6K8s5TFNGcgj+R9q9w8E+KbXxDYjlY7xB+9i/qPaurNsneE/eUtYfkeTwlxjHNV9XxVo1V90vTz8vmjoqKKK8I+8CiiigAooooAKKKKACiiigD5V/a8+P0mgvdeAvCUskepFdl9eDjyQR9xPfHeviiR3lkaSR2d2OWZjkk+tfoj+058CtP+Jektq2jxRWnie2T91KMKLlR/yzf+h7V+fOuaVqGiarcaXqtpLaXls5jlikXDKRX0mWSpOlaG/U56l76lKtPwtr+reGNetdb0S8ls761cPHJG2D9D6g9MVmUV6TSasyD9Jf2cfjXpPxR0MW9w0dp4gtkAubYnHmf7aeo/lXr1fkh4W1/V/DGuW2taHey2d9bOHjkjP6H1HtX6Jfs5fGvR/inoQgmeOz8RWqD7XaE439vMT1U+navnMfgHRfPD4fyN4Tvoz12iis7xJremeHdEutZ1i7jtLK1jLyyucAAf1rzUm3ZGgeJNb0vw7otzrOs3kVpZWyF5ZZDgAD+Z9q/PL9pP436r8UNZaxs2ks/Dlq5+z24ODMf77+p9B2o/aU+N2p/FDXDZ2LS2fhy1ci3t84Mx/wCej+/oO1eNV9DgMAqS55/F+RhOd9EFFFABJwBkmvUMzqPh34y1Lwjq63FszSWshAntyeHHt719Z2EstzpVlqD2txbR3kCzxLPGUbawyODXK/slfs8nUpbXx144tGFkhElhp8q4849pHB/h9B3r608X+GLDxBpX2WRFiljX9xIowUPYfT2rGnnkMPWVJ6x6vt/XU+P4o4SjmtN4igrVV/5N5Pz7P7z56zRmrmvaVe6LqMljexMkiHg9mHqKoZr6uEozipRd0z8Rq0J0ZunUVmtGmTwTSQTJNC7JIhyrKcEGvZvhz41j1mJdP1GRUv0GFY8CX/69eJZqSCaWCVZYXZHU5VlOCDXDmGXU8bT5ZaPo+x7WQZ9iMlxHtKesX8UejX+fZn1FRXDfDbxtHrUKadqDqmoIuAx4EoHf613NfnWKwtTC1HTqKzR/QGW5lh8yw8cRh3eL+9Ps/MKr6heW1hZyXd3KsUUYyzGjUby20+zku7yZYoY13MzGvDPHvi+48RXpjiZorCM/u4/73+0feuvLMsqY6pZaRW7/AK6nlcScR0MloXetR/DH9X5D/Hni648Q3nlxlo7GM/u48/e9zXL7qZmjNfodDDwoU1TpqyR+AY7G18dXlXryvJ/19w/dVvSdRutMvo7yzlaOVDkY7+xqkDmvTPhn4HMxj1jV4v3Y+aCFh97/AGjWGPxNHDUXKrt27+R15JlWLzHFxp4XSS1v/L53PQ/C+oXGqaJb3t1bNbyyLkoe/v8AQ1p0AAAAAADoBRX5nUkpSbirLsf0lh6c6dKMJy5mkrvv5hRRRUGwUUUUAFFFFABRRRQAV4d+038CdO+JWkyavo8cdp4mtkzHIBhbkD+B/f0Ne40VpSqypSUovUTV9GfkTruk6joer3Ok6taS2d7ayGOaGVdrKRVKv0T/AGnfgXp/xK0h9Y0iOO18TWqZikAwLkD+B/6Gvz51zStQ0TVbjS9UtZbW8tnKSxSLgqRX1GExccRG636o55RcSlWp4V1/VvDGvWut6JeSWl9bOGjkQ4/A+oPpWXRXU0mrMk/RP4LftDeFvF3ge41HxDfW+lappkG+/idsBwP40HfJ7V8o/tJ/G/VPifrbWVk8tn4btn/0e2zgykfxv6n0HavGwSM4JGeuO9JXFRwFKlUc18vIpzbVgoooAJIAGSa7SQr6x/ZM/Z4k1J7Xxz44tClkMSWFhIuDL3Ejg/w+g70fsmfs8NqMtt448c2eLJCJLCwlX/WnqHcH+H0HevtFFVECIoVVGAAMACvFx+PtenTfqzWEOrEjRI41jjUIigBVAwAPSnUUV4ZsYXjLwzZeJNOaCcBLhQfJmA5U/wCFeBa/pV7ompSWF9GUkToccMOxHtX01WF4z8M2XiXTTBOAk6AmGYDlD/hXvZPnEsHL2dTWD/A+K4r4UhmsHXoK1Zf+TeT8+z+8+c80Zq5r2k3ui6jJY30ZSRTwezD1FUM1+gQlGcVKLumfiFWjOjN06is1umTwTSQTJNE7JIh3KynBBr2PwL8QrO701odbnSC5t0yZCcCUD+teK5pd1cWPy2ljoctTdbPqetkme4rJ6rqUHdPdPZ/8Mdb4/wDGFz4ivDFGxisIz+7j/ve5rls1HuozXTQw1PD01TpqyR5+OxlfHV5V68ryf9fcSZozTAa9P+GHgQzmPWdZhIjHzQQMPvf7R9qxxuMpYOk6lR/8E6MpyfEZriFQoL1fRLux/wAMvApmMesazFiP70EDfxf7R9vavWFAUAAAAcACgAAAAAAdBRX5xjsdVxtXnn8l2P3/ACXJcNlGHVGivV9W/wCugUUUVxHrhRRRQAUUUUAFFFFABRRRQAUUUUAFeH/tOfArT/iXpUmsaSsVp4mto/3UuMLcgDhH/oe1e4Vn+I9a0zw7otzrGsXkVpZWyF5ZZGwAB/WtaNSdOalDcTSa1PyZ1zStQ0TVrnStVtZLS8tnMcsUgwVIqlXp/wC0l8S7T4nePn1aw0q3srO3XyYJBGBNOoPDSHv7DtXmFfXU5SlBOSszlYUUUVYAAScDk19Zfsmfs7vqLW3jjx1ZFLMESafYSjmXuJHHZfQd6+VtLvJtO1K2v7cRtLbyrKgkQOpKnIyp4I46Gv0b/Zv+NOjfFDw+lrIIrDX7RAtzZ8AMMffj9V9u1efmVSrCn7m3Vl00m9T16NEjjWONVRFGFUDAA9KWiivmToCiiigAooooAwfGnhiy8S6cYJwEuEH7mYDlT/hXz7r+k32h6lJYahFskQ8Hsw9QfSvpjUr2106ykvLyZYYYxlmY18+/EXxa/ijU1aOMRWkGRCCBuPuT/Svr+GK2KcnTSvT/ACfl/kfmPiBhMvUI1m7Vn0XVefp0fy9Oa3UbqZmjNfa2PynlJM+9AOajzTo5GjkV0YqynIPoaVg5T1P4XeA/P8vWdaiIj+9BAw+9/tH29q9dAAAAAAHQVwPwx8dQ63Ammai6R6hGuFJ4Ew9vf2rvq/Ms5qYmeJaxGjWy6W8j+gOFcPl9LAReBd0931b8+3oFFFFeSfSBRRRQAUUUUAFFFFABRRRQAUUUUAFFFZ3iTW9L8OaJdazrN5HaWNqheWWQ4AH+NNJt2QB4l1vTPDmiXWs6xdx2llaxl5ZHOAAO3ufavzx/aT+N2qfFDWzZWbSWfhy2ci3tg2DKf77+p9B2pf2lfjdqfxQ1trGxeW08N2z/AOj2+cGYj/lo/v6DtXjVfQ4DAKkuefxfkYTnfRBRRQAScAZNeoZhRXv3w2/Zh8V+Lfh7deJprgadcvHv02zlT5rgdcsf4Qe1eHa5pWoaJq1zpWq2ktpeW0hjlikXDKwrOFanUk4xd2htNFKtTwrr+reGNdtta0S8ltL22cPHIhx07H1HtWXRWjSasxH6S/s4/GrSfijoYtp3jtfENqg+1WpON4/vp6j27V69X5IeFfEGr+F9etdc0O9ks7+1cPHKh/QjuD3Ffoj+zl8bNI+KWhLbztFZ+IraMfa7TON+Osieqn07V85j8A6L54fD+RvCd9GevUUUV5hoFVtTvrXTbGW9vJligiXczNRqd9aabYy3t7MsMEQyzMa+ffiN42uvE96YoS0OmxH91F3b/ab3r1spympmFSy0it3+i8z57iDiCjlFG71qPZfq/Id8RPGl14lvTFEzRafGf3cf97/aNclmmZozX6Xh8NTw1NU6askfheNxdbG1pV68ryY/NGTTM16R4J+GVxrGkSX+pSSWfmJ/oq45J7MR6Vni8ZRwkOes7I1y7K8TmNX2WHjd7/0zzvJozV3xDpF7oepyWF/EUkQ8HHDD1FZ+feuiEozipRd0zjq0Z0puE1ZrdE0E8sEyTQu0ciHKspwQa9z+GHjuLXIU0zUpFTUEXCseBKB/WvBs1JBPLBMk0LmORCGVlOCDXn5lllLH0uWWjWz7HsZFnlfJ6/tKesXuu6/z7M+tKK4D4X+PItdhTTNSdY9SQYVicCYDuPf2rv6/M8XhKuEqulVVmj92y7MaGYUFXoO6f4Ps/MKKKK5juCiiigAooooAKKKKACiig9KAM7xLrmleG9EudZ1q8jtLG2QvLK5wAPQep9q/PH9pP43ap8T9beyspJbTw3bSH7NbZx5pH8b+p9u1bH7YPxL8XeJPG114V1G0udH0jT5SIrNuDOR0kbs2e3pXgdfRZfgVTSqT3/IwnO+iCiigAkgAZJr1DMK+s/2TP2d31Brbxz46tNtmMSafp8i8y9/MkB6L0wO9J+yb+zwdSe28b+ObLFmpEljYSr/rT1DuP7voO9faCKqIERQqqMAAYAFeLj8fa9Om/VmsIdWEaJGixooVFGFUDAA9K8Q/ac+BWnfErSZNY0mOO08T2yZilAwtyAPuP/Q9q9worx6VWVKSlF6mrSasfkTrmlahomrXOlaray2l7bSGOaKRcMrCqVfon+098C7D4l6U+s6Skdr4mtY/3UmMC5UdI29/Q1+fOt6XqGi6rcaVqlrJa3ls5SWKQYKkV9RhMXHERut+qOeUeUpVqeFfEGreGNdttb0W7ktb22cNG6HH4H1FZdFdTSasyT9Jf2cPjVpXxR0Fbe4eK18Q2qD7Va7sbx/z0T1H8q9V1O+tdNsZb29mWGCJdzMxr8ovAOoeIdK8W2GoeF5podVhlDQtEefcH2PevsbxP4417xTp1jDq3lQGKFPOigJ2NLj5m59849K4KHD0sTX9x2h18vJHj55xDSyqhd61Hsv1fkaXxG8bXXie9MURaLTo2/dR5+9/tH3rkM1HmjNffYfC08NTVOmrJH4ljMXWxtaVau7yZJmgHmmAmvWfhN8PTceVrmuQkRDDW9uw+9/tN7Vjj8dSwNJ1ar9F3OjK8pr5nXVGivV9Eu7H/Cf4emcx63rkJEfDW9u4+9/tMPT2r2RQFAVQABwAKAAAAAAB0Aor8uzDMKuOq+0qfJdj9zyjKMPlVBUaK9X1bOf8b+FbHxRppt7gCO4UfuZwOUP9R7V86+IdHv8AQtTk0/UIikqHg9mHqD6V9VVz3jnwrY+KNMNvcKEuEBME2OUP+FenkmdywUvZVdab/A8PijheGZw9vQVqq/8AJvJ+fZnzLuo3Ve8Q6Pf6FqclhqERjkQ8Hsw9Qazs1+jwlGpFSi7pn4xVozpTcJqzW6J7eeSCZJoZGjkQhlZTgg17t8LvHsWuQppmpOseooMKxPEw/wAa8DzV3Q7fULvVIIdLWQ3ZcGMx8EH1z2rzs1y2jjaLVTRrZ9v+AezkGcYnK8SpUVzKWjj3/wCD2PrCiqOgx38Oj20eqTJNeLGBK6jAJq9X5VOPLJq9z98pyc4KTVr9H0CiiipLCiiigAooooAKKKKAPK/2hfg3o/xT8PFdsVprlupNnebec/3W9VNfnR4y8Naz4R8RXWg69ZvaXts5V1YcEdmB7g9jX6115V+0P8GtF+Knh05SO0161UmzvQuD/uP6qf0r08DjnRfJP4fyM5wvqj80RycCvrP9kz9ndtRNr458dWTLaAiTT9PlXBl9JJB/d7gd+tXv2bv2Y7yz19vEHxFs1VbKYi1sCQwlZTw7f7PcDvX2CiLGioihVUYAAwAK6cfmGns6T9WTCHVhGiRoqRqFRRgKBgAUtFFeGbBRRRQAV4h+038CtP8AiZpTatpCQ2fia2jPlS4wtyo52P8A0Pavb6K0pVZUpKUXqJq+jPyJ1zStQ0TVrnStVtJbS9tnMcsUgwVIqPS7C61O+isrKFpZ5W2qor9AP2r/AIM6J448OzeJLV7fTtesoyRO3yrcqP4H9/Q14F8OvBlp4XsvMkCTajKP3suM7f8AZX0H86+1yiDzFcy0S3Pms+zqllNLXWb2X6vyH/DnwZaeF7EPIEm1CUDzZcfd/wBke1dfmo80ua+0pUY0oqMVofjWLxNXF1XWrO8mSZozUea9N+B/hTTdau5NUv5opvsrjbak8k9mYelc+OxcMHQlWqbI1y3LqmYYmOHpbvuafwj+HhnMWva5DiMENb27D73ozD09q9oAAAAAAHQCkUBVCqAAOABS1+U5jmNXH1XUqfJdj9yyjKKGV0FRor1fVsKKKK4D1AooooA57xz4UsPFOmG3uFEdwgJgnA5Q/wBR7V84eI9Gv9A1SXT9RhMcqHg/wuOxB7ivrCud8d+E7DxTpZt51CXKDMEwHKn/AAr6LI88lgpeyq603+Hmv1Pj+J+GIZnB16KtVX/k3k/Psz5p0uxu9Tv4rGxheaeVtqIoyTX0T8OPBNp4XsRJKFm1GQfvZf7v+yvtR8OfBFn4UtDIxW41CUfvJsdB/dX0FdfWue568W3RoP3Pz/4BhwvwtHL0sTiVeq9l/L/wQooor5g+3CiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKrarf2ml2E19fTpBbwrud2OAKTVdQtNLsJb6+mWGCJcszGvm34nePLzxXfmGEtDpkTfuos/f/wBpvevZyfJ6uZVbLSC3f6LzPBz3PaOVUbvWb2X6vyH/ABM8d3fiq/MULPDpsR/dRdN3+03vXF5pm6jdX6phsLTw1JUqSskfjGLxVbGVnWrO8mSZ96M0wGnSq8UhjkRkdeCrDBFb2OXlFzWn4b1y/wBA1SPUNPmMciHkdmHoR6Vk7hS596ipTjUi4zV0y6c50pqcHZrZn1X4C8W2HizShc27BLmMATwZ5Q/4V0dfIfhvXL/w/qseo6dMY5U6js47gj0r6Y8BeLtP8WaUtzbER3KAefATyh/qPevzPPshlgJe1pa03+Hk/wBGfr/DfEkcygqNbSqv/JvNefdHSUUUV80fWhRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFVtVv7TS7CW+vp1ht4l3O7HpSatqNnpWny319OsMES7mZjXzP8UfH154tv8AyYWeDS4WPlQ5xvP95vU/yr2smyarmVWy0gt3+i8zws8zylldK71m9l+r8h/xP8eXfiy/MUJaHTIm/cxZ5b/ab3ris0zNGa/V8NhaWFpKlSVkj8bxeKrYuq61Z3kx+aX2pmTXsnwc+GrXBh8Qa/CViB3W9sw5b0Zh6e1YZhj6OAourVfourfY3y3LK+Y11Ror1fRLux3wc+GxuPK1/X4SIgQ1tbuPvf7TD09BXT/Fv4dQ6/bPqukxpFqca5KgYE4Hb6+9ekKAqhVAAHAApa/L62fYupi1ilKzWy6W7f5n63R4bwVPBPBuN0931v3/AMj4wuIZred4J42jlQlWVhgg0zNfRHxc+HUXiCB9W0mNI9TRcso4EwH9a+eLiKW2neCeNo5UO1kYYIPpX6TlOa0cypc8NJLddv8AgH5XnOS1srrck9YvZ9/+CJmtPw1rl/4f1WLUdPmMcqHkZ4Yeh9qys0Zr0qlONSLhNXTPKpznSmpwdmtmfWHgDxfp/i3SVubZhHcoAJ4CfmQ/1HvXSV8feGdd1Dw9q0WpabMY5UPIz8rr3UjuK+nPAHjDT/FulLcW7CO6QYngJ5Q/1FfmGfZBLAS9rS1pv8PJ/oz9c4c4jjmMFRraVV/5N5rz7o6WiiivmT6wKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAOY+JXhRfFvh5rAXDwTod8LA/KW9GHcV8s65pV/oupzadqNu0FxC2GVu/uPUV9m1x/xM8DWHi/TD8qw6jEP3E4HP+6fUV9Tw7n7wEvY1v4b/AAf+Xc+S4k4eWYR9vR/iL8V29ex8q5o+gq9ruk32i6nLp2oQNFPG2CCOvuPUV6v8Gvhk1w0PiDxDBiH71tbOPvejMPT2r9Cx2Z4fB4f283o9rdfQ/OMBlWIxuI+rwjZre/T1F+DPw0NwYfEPiCDEQ+a2tnH3vRmHp6Cvc1AVQqgADgAUKoVQqgAAYAHalr8lzPMq2Y1nVqv0XRI/YsryuhltBUqS9X1bCiiivOPSCvNfi98OYvEVu+raTEseqRrllHAnHoff3r0qiuvBY2tgqyq0nZr8fJnHjsDRx1F0ayun+Hmj4ruIZbad4J42ilQlWRhgg1Hmvoz4vfDiLxDA+raRGseqRjLIOBOP8a8AsdI1K91hdIgtJDetJ5ZiK4Knvn0xX6zleb0Mwoe1Ts1uu3/A8z8dzbJK+XYj2TV0/hff/g+Q3SbC81XUIbCwgee4mYKiKOpr6a+F3ga28IaaWkYTajOo8+Tsv+yvtTPhd4DtPCWnCWULNqcq/vZcfd/2V9q7avh+IeIHjG6FB/u1u+//AAD73hrhuOBSxGIV6j2X8v8AwQooor5M+xCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxdd8LaHrd/a32pWKTT2rbo2Pf2PqK2VAVQqgAAYAHalorSVWc4qMm2lt5GcKNOEnKMUm9/MKKKKzNAooooAKKKKACs+HRdLh1iXV4rKFb6VQrzBfmIrQoqozlG/K7XJlCMrOSvYKKKKkoKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooA//2Q=="), - contactLink = Just adminContactReq, - preferences = Nothing - } - -simplexStatusContactProfile :: Profile -simplexStatusContactProfile = - Profile - { displayName = "SimpleX-Status", - fullName = "", - image = Just (ImageData "data:image/jpg;base64,/9j/4AAQSkZJRgABAQAASABIAAD/4QBYRXhpZgAATU0AKgAAAAgAAgESAAMAAAABAAEAAIdpAAQAAAABAAAAJgAAAAAAA6ABAAMAAAABAAEAAKACAAQAAAABAAAAr6ADAAQAAAABAAAArwAAAAD/7QA4UGhvdG9zaG9wIDMuMAA4QklNBAQAAAAAAAA4QklNBCUAAAAAABDUHYzZjwCyBOmACZjs+EJ+/8AAEQgArwCvAwEiAAIRAQMRAf/EAB8AAAEFAQEBAQEBAAAAAAAAAAABAgMEBQYHCAkKC//EALUQAAIBAwMCBAMFBQQEAAABfQECAwAEEQUSITFBBhNRYQcicRQygZGhCCNCscEVUtHwJDNicoIJChYXGBkaJSYnKCkqNDU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6g4SFhoeIiYqSk5SVlpeYmZqio6Slpqeoqaqys7S1tre4ubrCw8TFxsfIycrS09TV1tfY2drh4uPk5ebn6Onq8fLz9PX29/j5+v/EAB8BAAMBAQEBAQEBAQEAAAAAAAABAgMEBQYHCAkKC//EALURAAIBAgQEAwQHBQQEAAECdwABAgMRBAUhMQYSQVEHYXETIjKBCBRCkaGxwQkjM1LwFWJy0QoWJDThJfEXGBkaJicoKSo1Njc4OTpDREVGR0hJSlNUVVZXWFlaY2RlZmdoaWpzdHV2d3h5eoKDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uLj5OXm5+jp6vLz9PX29/j5+v/bAEMAAQEBAQEBAgEBAgMCAgIDBAMDAwMEBgQEBAQEBgcGBgYGBgYHBwcHBwcHBwgICAgICAkJCQkJCwsLCwsLCwsLC//bAEMBAgICAwMDBQMDBQsIBggLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLC//dAAQAC//aAAwDAQACEQMRAD8A/v4ooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAP/Q/v4ooooAKKKKACiiigAoorE8R+ItF8J6Jc+IvEVwlrZ2iGSWWQ4CgVUISlJRirtmdatTo05VaslGMU223ZJLVtvokbdFfl3of/BRbS734rtpup2Ig8LSsIYrjnzkOcea3bafTqBX6cafqFjq1jFqemSrPbzqHjkQ5VlPIINetm2Q43LXD65T5eZXX+XquqPiuC/Efh/itYh5HiVUdGTjJWaflJJ6uEvsy2fqXKKKK8c+5Ciq17e2mnWkl/fyLDDCpd3c4VVHJJJr8c/2kf8Ago34q8M3mpTfByG3fT7CGSJZrlC3nStwJF5GFU8gd69LA5VicXTrVaMfdpxcpPokk397toj4LjvxKyLhGjRqZxValVkowhFc05O9m0tPdjfV7dN2kfq346+J3w9+GWlPrXxA1m00i1QZL3Uqxj8Mnn8K/Mj4tf8ABYD4DeEJ5dM+Gmn3niq4TIE0YEFtn/ffBI+imv51vHfxA8b/ABR1+bxT8RNUuNXvp3LtJcOWCk84VeigdgBXI18LXzupLSkrL72fzrxH9IXNsTKVPKKMaMOkpe/P8fdXpaXqfqvrf/BYH9p6+1w3+iafo1jZA8WrRPKSPeTcpz9BX1l8J/8Ags34PvxDp/xn8M3OmSnAe709hcQfUoSHA/A1/PtSE4/GuKGZ4mLvz39T4TL/ABe4swlZ1ljpTvvGaUo/dbT/ALdsf2rfCX9pT4HfHGzF18M/EdnqTYBaFXCzJn+9G2GH5V7nX8IOm6hqGkX8eraLcy2d3EcpPbuY5FPsykGv6gf+CWf7QPxB+OPwX1Ky+JF22pX3h69+yJdyf62WJlDrvPdlzjPevdwGae3l7OcbP8D+i/DTxm/1ixkcqx2H5K7TalF3jLlV2rPWLtqtWvM/T2iiivYP3c//0f7+KKKKACiiigAooooAK/Fv/goX8Qvi2fFcXgfWrRtP8NDEls0bZS7YfxORxlT0Xt1r9pK8u+L/AMI/Cfxp8F3HgvxbFujlGYpgB5kMg6Op9R+tfR8K5vQy3MYYnE01KK0843+0vNf8NZn5f4wcFZhxTwziMpy3FOjVeqSdo1Lf8u5u11GXk97Xuro/mBFyDX3t+yL+2Be/CW+h8B+OHafw7cyALIxJa0Ldx6p6jt1FfMvx/wDgR4w/Z+8YN4d8RoZrSbLWd4owk6D+TDuK8KF0K/pLFYHA51geWVp0pq6a/Brs1/wH2P8ALvJsz4h4D4h9tR5qGLoS5ZRls11jJbSjJferSi9mf1uafqFlqtlFqWmyrPBOoeORDlWU8gg069vrPTbSS/v5FhghUu7ucKqjqSa/CH9j79sm++EuoQ/D/wAeSNceHbmRVjlZstZk9x6p6jt2q3+15+2fffFS8n8AfD2V7bw9CxWWZThrwj+Se3evxB+G2Zf2n9TX8Lf2nTl/+S/u/PbU/v2P0nuGv9Vf7cf+9/D9Xv73tLd/+ffXn7afF7pqftbfth3nxUu5vAXgGR7fw/A5WWUHDXZX19E9B361+Z/xKm3eCL9R3UfzFbQul6Cn+I/A3ivxR8LPEXivSbVn07RoVkurg8Iu5gAue7HPSv1HOsrwmVcN4uhRSjBUp6vq3Fq7fVt/5I/gTNeI884x4kjmeYOVWtKSdop2hCPvWjFbQjFNv5ybbuz4Toqa0ge9uoLOIhWnkSNSxwAXIUEnsBnmv0+/aK/4Jg+O/gj8Hoviz4b1n/hJFt40l1G2ig2NDG4yZEIJ3KvfgHHNfxVTw9SpGUoK6W5+xZVw1mWZYfEYrA0XOFBKU2raJ31te72b0T0R+XRIAyegr+gr/glx+yZoHhjwBc/tKfFywiafUY2OmpeIGS3sVGWmIbgF+TkjhR71+YP7DX7Lt9+1H8ZLfR75WTw5pBS61ScDKsoIKwg+snf0Ffqd/wAFSv2o4Phf4Ltv2WvhmVtrjUbRBfvA2Ps1kOFhAHQyAc9ML9a9HL6UacHi6q0W3mz9Q8M8owuV4KvxpnEL0aN40Yv/AJeVXpp5LZPo7v7J+M/7U/jX4e/EL4/+JfFXwrsI9P0Ke5K26RKESTZw0oUcAOeQBX7J/wDBFU5+HPjYf9RWH/0SK/nqACgKOgr+hT/giouPh143b11SH/0SKWVzc8YpPrf8jHwexk8XxzSxVRJSn7WTSVknKMnoui7H7a0UUV9cf3Mf/9L+/iiiigAoorzX4wfGD4afAP4bav8AF74v6xbaD4d0K3e6vb26cJHHGgyevUnoAOSeBTjFyajFXYHpVFf55Xxt/wCDu34nj9vzS/G3wX0Qz/ArQ2ksLnSp1CXurQyMA15uPMTqBmJD2+914/uU/Y//AGxfgH+3P8ENL+P37OutxazoWpoNwHyzW02PmhmjPKSKeCD9RxXqY/JcXg4QqV4WUvw8n2ZnCrGTaTPqGiiivKNDy/4u/CLwd8afBtx4N8ZW4kilBMUoH7yGTs6HsR+tfzjftA/AXxl+z54yfw34jQzWkuXs7xF/dzR/0YdxX9OPiDxBofhPQ7vxN4mu4rDT7CF57m4ncJHFFGMszMcAAAZJNf53n/Bav/g5W1H4ufGjTvg5+xB5F14E8JX4l1HVriIE6xNE2GjhLDKQdRuGC55HHX9L8Os+x2ExP1eKcsO/iX8vmvPy6/ifg3jZ4NYDjDBPFUEqeYU17k/50vsT8n0lvF+V0fq0LhTUgnA4r4y/ZG/bJ+FX7YXw9HjDwBP5N/ahV1LTZeJrSUjoR3U/wsOK+sRdL/n/APXX9G0nCrBTpu6Z/mVmuSYvLcXUwOPpOnWg7SjJWaf9ap7NarQ+pf2dP2evGH7Q3i4aLogNvp1uQ15esMpEnoPVj2Ffrd+1V8GvDnw5/YU8X+APh/Z7IrewEjYGXlZGUs7nqSQM18C/sO/ti6b8F7o/Dnx6qpoN9LvS6RRvglbjL45ZT69vpX7wX1poHjjwxNYzbL3TdUt2jbaQySRSrg4PoQa/nnxXxGaTxLwmIjy4e3uW2lpu33Xbp87v+7Po58I8L4nhfFVMuqKeY1oTp1nJe9S5k0oxWtoPfmXxve1uVfwqKA0YHYiv6Ev+CZ37bVv490eP9mb4zXAn1GKJo9Murg5F3bgYMLk9XUcD+8tflR+1/wDsn+Nv2XfiNdadqFs8vh28md9Mv1GY3iJyEY9nXoQa+UrC/v8ASr+DVdJnktbq2dZYZomKvG6nIZSOhFfztQrVMJW1Xqu5+Z8PZ5mvBWeSc4NSg+WrTeinHqv1jL56ptP+s7xHZ/A//gnR8EfE/jTwra+RHqF5JdxWpbLTXcwwkSnrsGPwXNfyrfEDx54l+J/jXU/iB4wna51LVZ3nmdj3Y8KPQKOAPQV2vxX/AGhvjT8corC3+K2vz6vFpq7beNgERT3YqvBY92NeNVeOxirNRpq0Fsju8RePKWfTo4TLqPscFRXuU9F7z+KTSuvJK7srvqwr+ir/AIIuaVd2/wAH/FesSIRDd6uFjb+8Y41Dfka/BX4YfCzx78ZfGVr4C+G+nyajqV22Aqj5I17u7dFUdya/r+/ZV+Aenfs2fBLSPhbZyC4ntVaW7nAx5tzKd0jfTJwPYV1ZLQk63tbaI+w8AOHcXiM8ebcjVClGS5ujlJWUV3sm27baX3R9FUUUV9Uf2gf/0/7+KKKKACv4If8Ag8QT9vN9W8IsVk/4Z+WJedOL7f7Xyd32/HGNu3yc/LnPev73q84+Lnwj+G/x3+HGr/CT4uaRba74d123e1vbK6QPHJG4weD0I6gjkHkV6WUY9YLFQxDgpJdP8vMipDmi0f4W1frt/wAEhP8Agrt8af8AglD8b38V+Fo21zwPr7xp4i0B3KpcRoeJoTyEnjBO04+boeK+m/8AguZ/wQz+I3/BMD4kyfEn4Ww3fiD4Oa5KzWWolC76XKx4tbphwOuI3PDAc81/PdX7LCeFzHC3VpU5f18mjympU5eZ/t9fsk/tb/Av9tv4G6N+0F+z3rUWs6BrEQYFCPNt5cfPDMnVJEPDKf5V794h8Q6F4T0O78TeJ7uGw06wiae4uZ3EcUUaDLMzHAAA6k1/j9f8EiP+Cunxv/4JTfHAeKPCZfWfAuuyRx+IvD8jkRTxg486Lsk8YJ2n+Loa/V7/AILy/wDBxZd/t2eHl/Zc/Y6mu9I+Gl1DDNrWoSBoLvUpGAY2+OqQoeH/AL5GOlfneI4OxCxio0taT+12Xn59u53xxMeW73ND/g4M/wCDgzVP2yNV1H9jz9j3UZrD4ZWE7waxrEDlH110ONiEYItgQe/7z6V/I6AAMDgCgAKNo6Cv0j/4Jkf8Ex/j/wD8FOvj/Y/Cj4UWE9voFvNGdf18xk2um2pPzEt0MhGdiZyTX6FhsNhctwvLH3YR1bfXzfn/AEjhlKVSR77/AMEMf2Rf2v8A9qr9tPRrb9mNpdL0fSp438UaxKjNYW+nk/PHKOA7uoIjTrnniv7Lfj98CvG37PPjiXwj4uiLxNl7S7UYjuIuzD39R1Ffvt+wn+wd+z5/wTy+A+n/AAF/Z70pbKyt1V728cA3V/c4w0079WYnoOijgV7V8cPgb4G+Pngqfwb41twwYEwXCgebBJ2ZT/MdDXi5N4mTwmYWqRvhXpb7S/vL9V28z8c8YfBXC8XYL61hbQx9Ne7LpNfyT8v5ZfZfkfyXi5r9Lf2Jv24bn4S3UHwz+JkzT+HZ5AsNy5LNZlu3vHn8q+KPj38CPHf7PPjabwn4yt2ELMxtLsD91cRg8Mp6Z9R2rxAXAPANfuePyzL89y/2c7TpTV1JdOzT6Nf8Bn8C5FnGfcEZ79Yw96OJpPlnCS0a6xkusX/k4u9mf2IeK/B/w++Mngt9C8U2ltrWi6lEGCuA6OrDhlPY+hHNfztftw/8E4tN+AGlTfE34ba3HJo0koVdMvGC3CFv4Ym/5aAenBArvf2PP2+9R+CGmv4B+JSy6joEUbtaOp3TQOBkRj1Rjx7V8uftEftH+Nf2i/G7+KPEzmG0hyllZqT5cEef1Y9zX4LT8GMTisynhsY7UI6qot5J7Jefe+i87o/prxI8YuEM/wCF6WM+rc2ZSXKo6qVJrdykvih/Ktebsmnb4DkilicxyqVYdQRzXUaN4R1HVMSzjyIf7zDk/QV6dIlpJIJ5Y1Z16MRk1+qf7DX7Ed58ULmH4p/Fe2kt/D8Dq9paSDabwjncf+mf/oX0rKXg3lOR+0zDPMW6lCL92EVyufZN3vfyjbvdI/AeFsJnHFOPp5TktD97L4pP4YLrJu2iXnq3ok20es/8Erv2f/G/gf8AtD4ozj7Bo2pwiFIpY/3t2VOQ4J5VFzx659q/aKq9paWthax2VlGsUMShERBtVVHAAA6AVYr4LNcdTxWIdSjRjSpqyjGKslFber7t6tn+k3APB1LhjJaOUUqsqjjdylJ/FKTvJpfZV9orbzd2yiiivNPsj//U/v4ooooAKKKKAPO/iz8Jvh18c/h1q/wm+LGk2+ueHtdt3tb2yukDxyxuMEEHoR1B6g81/lm/8Fy/+CFfxG/4Jh/ENvid8J4bzxF8Htdmke1vliaRtHctxbXTAEBecRyHAbGDzX+q54j8R6B4Q0C88U+KbyHT9N0+F7i5ubhxHFFFGMszMcAADqa/zM/+Dhb/AIL06p+3f4rvP2Tf2Xr6S0+Eui3DR397GcHXriM8N7W6EfIP4jz6V9fwfPGLFctD+H9q+3/D9jmxKjy+9ufyq0UAY4or9ZPMP0v/AOCX3/BLf9oT/gqP8d4Phf8ACa0lsvDtjLG3iDxDJGTa6bbse56NKwB8uPOSfav9ZX9hD9hT4Df8E8v2fdK/Z7+AenLbWNkoe8vHUfab+6I+eeZhyWY9B0UcCv8AKC/4JUf8FV/j1/wSu+PCfEf4aSHUvC+rPHH4i0CViIL63U43D+7MgJKN+B4r/Wd/Yy/bM+BH7eHwH0j9oL9n7Vo9S0fU4182LI8+0nx88MydVdTxz16ivzbjZ43nipfwOlu/n59uh6GE5Labn1ZRRRXwB2Hi3x3+BPgj9oHwJceCPGcIIYFre4UfvYJezKf5jvX8vH7QvwB8d/s4eOZfB/jKEtDIS9neKP3VxFngqfX1Hav6gvj58e/An7PHgK48ceN7gLtBW2twf3txL2RR/M9hX8rX7Qn7Rnjz9o3x5L418ZyhUXKWlqh/dW8WeFUevqe5r988G4Zu3Ut/ueu/839z/wBu6fM/jj6UdPhlwo8y/wCFTS3Lb+H/ANPf/bPtf9unlQuAec077SPWueFznrTxc1+/eyP4udE/XX9g79h24+K8tv8AF74qQvD4fgkDWdo64N4V53H/AKZg/wDfX0r+ge0tLWwtY7KyjWKGJQiIgwqqOAAOwFfzc/sIft2XnwO1KH4ZfEeVp/Ct5L8k7Es9k7YHH/TMnkjt1r+kDTNT07WtOg1fSJ0ubW5QSRSxncjowyCCOoNfyr4q0s3jmreYfwtfZW+Hl/8Akv5r6/Kx/or9HSXDX+rqhkqtidPb81vac/d/3P5Lab/auXqKKK/Lz+gwooooA//V/v4ooooAKxfEniTQPB2gXnirxVew6dpunQvcXV1cOI4oYoxlndjgAADJJrar/PV/4Ozf+CiX7Xlr8Yrf9hCx0u98GfDaS0iv5L1GZT4iZs5HmKceTERgx9d3LcYr08py2eOxMaEXbu/L9SKk1CN2fIX/AAcD/wDBfrXv27vFF1+yx+ylqFzpnwl0id476+icxSa/MhwGOMEWykHYv8fU9hX8qoAAwOAKUAAYFfqj/wAEnf8AglH8cv8Agqp8ek+Hvw/R9M8I6NJFJ4k19lzHZW7k/ImeGmcAhF/E8V+xUKGFyzC2Xuwju/1fds8tuVSXmM/4JQ/8Epfjr/wVU+Pcfw5+HiPpXhPSXjl8ReIZEJhsoGP3E7PO4B2J+J4r7o/4Li/8EC/H3/BL/UYPjH8Hp7vxV8JNQMcL3sy7rnTLkgDbcFRjZI3KPwATg9q/0rP2MP2MPgL+wZ8BdI/Z5/Z60hNM0bS4x5kpANxeTn7887gAvI55JPToOK9y+J/ww8AfGfwBqvwu+KOlW+t6Brdu9re2V0gkilicYIIP6HqDXwVbjSu8YqlNfulpy9139e3Y7VhY8tnuf4VdfqD/AMErP+Cpvx1/4Jb/ALQNn8S/h7cS6j4VvpUj8QeH2kIt723zgsB0WVRyjetffn/BeH/ghJ4x/wCCZvjlvjP8EYbvXPg5rk7GKcqZJdGmc5FvOwH+rOcRyH0wea/nCr9ApVcNmOGuvehL+vk0cLUqcvM/24v2Mf20PgH+3l8CdK/aA/Z61iPVNI1FF86LI+0Wc+PnhnTqjqeOevUcV3nx/wD2gfh/+zp4CuPHHjq5CBQVtrZT+9uJeyIP5noBX+Ud/wAEL/25f2t/2NP2u7A/s7xPrPhzW5Yk8T6LOzCyls1PzTE9I5UXJRupPHIr+p39o79pXx/+0v8AEGbxv42l2RrlLO0QnyreLPCqPX1PUmvM4b8KauYZg5VJWwkdW/tP+6vPu+i8z8r8VvF3D8L4P6vhbTx017sekF/PL/21fafkjV/aF/aN8e/tHePZ/GvjOc+XuK2lopPlW8WeFUevqe9eFfasDmsL7UB1r9kv+Cen/BPuX4mPa/Gv41Wrw6HE4k0/T5FwbsjkO4PPl56D+L6V/QWbZjlnDmW+1q2hSgrRit2+kYrq/wDh2fw9kXDmdcZ526NK9SvUfNOctorrKT6JdF6JIh/Yq/4JyXXxq8MSfEn4wtPpukXkLLp1vH8s0hYcTHPRR1Ud6+KP2nP2bvHX7MXj+Twl4pUz2U+Xsb5QRHcRZ/Rh/Etf2D2trbWNtHZ2caxRRKEREGFVRwAAOgFeSfHL4G+Af2gvAVz4A8f2wmt5huimUDzYJB0dD2I/Wv5/yrxgx0c3niMcr4abtyL7C6OPdrr/ADeWlv604g+jdlFTh6ngsrfLjaauqj/5eS6xn2i/s2+Hz1v/ABi+d3r9O/2DP28r/wCBGpRfDT4lSvdeFL2UBJmYs9izcZX1j7kduor48/ah/Zr8bfsu/EWTwZ4pHn2c4MtheqMJcQ5IB9mHRhXzd9oAFf0Djsuy3iHLeSdqlGorpr8Gn0a/4DW6P5DyrMc74Mzz2tG9LE0XaUXs11jJdYv/ACaezP7pdK1bTNd02DWdGnS6tLlBJFLEwZHRuQQR1FaFfix/wSG1n47X3hPVLHXUL+BoT/oEtxneLjPzLD6pjr2B6d6/aev424nyP+yMyrZf7RT5Huvv17NdV0Z/pTwPxP8A6w5Lh82dGVJ1FrGXdaNp9YveL6oKKKK8A+sP/9b+/iiiigAr4E/4KI/8E4f2b/8AgpZ8DLr4M/H7SklljV5NJ1aJQLzTblhxLC/Uc43L0YcGvvuitKNadKaqU3aS2Ymk1Zn+Vt8Nf+DZH9vDxJ/wUEn/AGQfGti+m+DdMkF5eeNlTNjLpRb5Xgz964cfL5XVWyTx1/0lv2L/ANif9nv9gn4H6b8Bv2dNDh0jSrFF8+YKDcXs4GGmuJOskjHPJ6dBxX1lgZz3pa9bNc+xWPjGFV2iui6vu/60M6dKMNgooorxTU4T4m/DHwB8ZfAeqfDH4paRba7oGtQPbXtjeRiWGaJxghlII/wr/M//AOCw/wDwbq/En9kb9o7Ttc/ZhQ6h8KvGl4VgknkUyaJIxy0UmTueMDmNgCexr/SN/aA/aA+Hf7N3w6u/iL8RbtYYIFIggBHm3Ev8Mca9yfyA5NfyB/tTftZfEX9qv4gSeL/GEv2exgLJYWEZPlW8WeOO7H+Ju9fsXhRwnmOZYl4hNwwi+Jv7T/lj5930Xnofj3iv4nYThrCPD0bTxs17kekV/PPy7L7T8rn58fs1fs1/Df8AZg8Dp4U8CwB7qYK19fuAZrmQDkseyjsvQV9GfaWrAWcjvUnnt6mv62w+Cp0KapUo2itkfwFmOLxWPxNTGYyo51Zu8pN6t/1stktEftx/wTa/YHsfi6sHx2+L8aT6BFJnT7DcGFy6dWlAzhQf4T171/SBaWltY20dlZRrFDEoREQYVVHAAA6AV/Hv+xJ+3N4y/ZO8Wi0ui+oeE9QkX7dYk5KdjLFzw49Ohr+tj4c/Efwb8WPB1l498A30eoaZqEYkiljOevVWHZh0IPIr+TPGXLs6p5p9Zxz5sO9KbXwxX8rXSXd/a3Wmi/t76P8AmHD08l+qZZDkxUdaydueT/mT0vDsl8Oz1d33FFFFfjR/QB4x8dPgN8O/2hvA1x4F+Idms8MgJhmAxLbydnjbqCP1r8RPg3/wSV8Z/wDC9r7T/izMreDNIlEkM8TYfUVPKpgcoAPv+/Ar+iKivrsh43zbKMLWweCq2hUXXXlf80eza0/HdJnwPFHhpkHEGOw+YZlQ5qlJ7rTnXSM/5op6/hs2jD8NeGdA8HaHbeGvC9nFYWFmgjhghUIiKOwArcoor5Oc5Tk5Sd292fd06cacVCCtFaJLZLsgoooqSz//1/7+KKKKACiiigAooooAK8J/aK/aG+H37M/wzvPiX8QrgRwwDbb26kebczH7saDuSep7DmvdW3bTt69s1/Hj/wAFS9c/acu/2hbiw+Psf2fTYWf+w47bd9ha2zw0ZPWQj7+eQfav0Dw44PpcRZssLXqqFOK5pK9pSS6RXfu+i1PzvxN4zrcN5PLF4ei51JPli7XjFv7U327Lq9Dwr9qv9rn4lftZ+Pv+Ev8AG8i29na7ksNPiJ8m2iJ7Ak5Y/wATHrXy/wDacDJNYfn45PFftR/wTX/4Ju6j8aryz+OXxttpLXwtbSrJY2Mi7W1Bl53MD0hB/wC+vpX9jZpmGU8LZT7WolTo01aMVu30jFdW/wDNvqz+HcryTOeLs4dODdSvUd5Tlsl1lJ9Eui9Elsix/wAE8/8Agmpc/Hq3HxZ+OcFxY+F8f6Daj93Jen++eMiMdum76V88ft4fsM+LP2RvGH9p6MJtS8G6gxNnfMMmFj/yxmIAAYfwnuPev7DbGxs9Ms4tP0+JYIIFCRxoNqqq8AADoBXL+P8AwB4R+KHhG+8C+OrGPUNM1CMxTQyjIIPcehHUEdDX8x4PxqzWOdvH11fDS0dJbKPRp/zrdvrtta39V47wCyWeQRy7D6YqOqrPeUuqkv5Hsl9ndXd7/wACwuGHevvT9iL9u7x1+yP4n+wMDqXhPUJVN/YMTlOxlh/uuB+BqH9vD9hXxl+yD4v/ALS03zNT8HajIfsV8VyYSf8AljNjgMOx/iHvX59C6bHav6fjDKeJsqurVcPVX9ecZRfzTP5LdLOeE850vRxNJ/15SjJfJo/v3+GnxJ8HfF3wRp/xC8BXiX2l6lEJYZEPr1Vh2YdCDyDXd1/PD/wRa8KftJW8moeKfPNp8N7kMBBdKT9ouR/Hbgn5QP4m6Gv6Hq/iHjXh6lkmb1svoVlUjF6Nbq/2ZdOZdbfhsf6AcC8SVs9yahmWIoOlOS1T2dvtR68r3V/x3ZRRRXyh9eFFFFABRRRQB//Q/v4ooooAKKKKACiiigAr5u/aj/Zg+HX7VvwyuPh14+i2N/rLO8jA861mHR0Pp2YdCOK+kaK6sDjq+DxEMVhZuFSDumt00cmOwOHxuHnhcVBTpzVpJ7NM/nF/ZW/4I2eINL+MV9rH7Rk0Vz4d0G5H2GCA8anjlXfuiDjcvJJ46V/RfY2FlpdlFpumxJBbwII444wFVEUYAAHAAFW6K9/injHM+Ia8a+Y1L8qsorSK7tLu3q3+iSPn+E+C8q4dw86GW07czvJvWT7Jvstkv1bYUUUV8sfVnEfEb4c+Dvix4Mv/AAB49sY9Q0vUYjFNDIMjB7j0YdQRyDX4HeH/APgiNJB+0LKNe1vzvhzARcxBeLyUEn/R27ADu46jtmv6KKK+r4d42zjI6Vajl1ZxjUVmt7P+aN9pW0uv0R8lxJwNk2e1aFfMqCnKk7p7XX8srbxvrZ/qzn/CnhXw/wCCPDll4R8K2sdlp2nQrBbwRDCoiDAAFdBRRXy05ynJzm7t6tvqfVwhGEVCCsloktkgoooqSgooooAKKKKAP//R/v4ooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAP/Z"), - contactLink = Just (either error id $ strDecode "simplex:/contact/#/?v=1-2&smp=smp%3A%2F%2Fu2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU%3D%40smp4.simplex.im%2FShQuD-rPokbDvkyotKx5NwM8P3oUXHxA%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEA6fSx1k9zrOmF0BJpCaTarZvnZpMTAVQhd3RkDQ35KT0%253D%26srv%3Do5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"), - preferences = Nothing - } - -timeItToView :: String -> CM' a -> CM' a -timeItToView s action = do - t1 <- liftIO getCurrentTime - a <- action - t2 <- liftIO getCurrentTime - let diff = diffToMilliseconds $ diffUTCTime t2 t1 - toView' $ CRTimedAction s diff - pure a - -mkValidName :: String -> String -mkValidName = reverse . dropWhile isSpace . fst3 . foldl' addChar ("", '\NUL', 0 :: Int) - where - fst3 (x, _, _) = x - addChar (r, prev, punct) c = if validChar then (c' : r, c', punct') else (r, prev, punct) - where - c' = if isSpace c then ' ' else c - punct' - | isPunctuation c = punct + 1 - | isSpace c = punct - | otherwise = 0 - validChar - | c == '\'' = False - | prev == '\NUL' = c > ' ' && c /= '#' && c /= '@' && validFirstChar - | isSpace prev = validFirstChar || (punct == 0 && isPunctuation c) - | isPunctuation prev = validFirstChar || isSpace c || (punct < 3 && isPunctuation c) - | otherwise = validFirstChar || isSpace c || isMark c || isPunctuation c - validFirstChar = isLetter c || isNumber c || isSymbol c - -xftpSndFileTransfer_ :: User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta) -xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ = do - let fileName = takeFileName filePath - fInv = xftpFileInvitation fileName fileSize dummyFileDescr - fsFilePath <- lift $ toFSFilePath filePath - let srcFile = CryptoFile fsFilePath cfArgs - aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n) - -- TODO CRSndFileStart event for XFTP - chSize <- asks $ fileChunkSize . config - ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup_ file fInv (AgentSndFileId aFileId) Nothing chSize - let fileSource = Just $ CryptoFile filePath cfArgs - ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP} - pure (fInv, ciFile, ft) - -xftpSndFileRedirect :: User -> FileTransferId -> ValidFileDescription 'FRecipient -> CM FileTransferMeta -xftpSndFileRedirect user ftId vfd = do - let fileName = "redirect.yaml" - file = CryptoFile fileName Nothing - fInv = xftpFileInvitation fileName (fromIntegral $ B.length $ strEncode vfd) dummyFileDescr - aFileId <- withAgent $ \a -> xftpSendDescription a (aUserId user) vfd (roundedFDCount 1) - chSize <- asks $ fileChunkSize . config - withStore' $ \db -> createSndFileTransferXFTP db user Nothing file fInv (AgentSndFileId aFileId) (Just ftId) chSize - -dummyFileDescr :: FileDescr -dummyFileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 593c328d0c..ffefddd701 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -294,11 +294,17 @@ data ChatCommand | ExecChatStoreSQL Text | ExecAgentStoreSQL Text | SlowSQLQueries + | APIGetChatTags UserId | APIGetChats {userId :: UserId, pendingConnections :: Bool, pagination :: PaginationByTime, query :: ChatListQuery} | APIGetChat ChatRef ChatPagination (Maybe String) | APIGetChatItems ChatPagination (Maybe String) | APIGetChatItemInfo ChatRef ChatItemId | APISendMessages {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage} + | APICreateChatTag ChatTagData + | APISetChatTags ChatRef (Maybe (NonEmpty ChatTagId)) + | APIDeleteChatTag ChatTagId + | APIUpdateChatTag ChatTagId ChatTagData + | APIReorderChatTags (NonEmpty ChatTagId) | APICreateChatItems {noteFolderId :: NoteFolderId, composedMessages :: NonEmpty ComposedMessage} | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent} | APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode @@ -587,6 +593,7 @@ data ChatResponse | CRApiChats {user :: User, chats :: [AChat]} | CRChats {chats :: [AChat]} | CRApiChat {user :: User, chat :: AChat, navInfo :: Maybe NavigationInfo} + | CRChatTags {user :: User, userTags :: [ChatTag]} | CRChatItems {user :: User, chatName_ :: Maybe ChatName, chatItems :: [AChatItem]} | CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo} | CRChatItemId User (Maybe ChatItemId) @@ -617,6 +624,7 @@ data ChatResponse | CRContactCode {user :: User, contact :: Contact, connectionCode :: Text} | CRGroupMemberCode {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionCode :: Text} | CRConnectionVerified {user :: User, verified :: Bool, expectedCode :: Text} + | CRTagsUpdated {user :: User, userTags :: [ChatTag], chatTags :: [ChatTagId]} | CRNewChatItems {user :: User, chatItems :: [AChatItem]} | CRChatItemsStatusesUpdated {user :: User, chatItems :: [AChatItem]} | CRChatItemUpdated {user :: User, chatItem :: AChatItem} @@ -1068,6 +1076,16 @@ instance FromJSON ComposedMessage where parseJSON invalid = JT.prependFailure "bad ComposedMessage, " (JT.typeMismatch "Object" invalid) +data ChatTagData = ChatTagData + { emoji :: Maybe Text, + text :: Text + } + deriving (Show) + +instance FromJSON ChatTagData where + parseJSON (J.Object v) = ChatTagData <$> v .:? "emoji" <*> v .: "text" + parseJSON invalid = JT.prependFailure "bad ChatTagData, " (JT.typeMismatch "Object" invalid) + data NtfConn = NtfConn { user_ :: Maybe User, connEntity_ :: Maybe ConnectionEntity, @@ -1603,3 +1621,5 @@ $(JQ.deriveFromJSON defaultJSON ''ArchiveConfig) $(JQ.deriveFromJSON defaultJSON ''DBEncryptionConfig) $(JQ.deriveToJSON defaultJSON ''ComposedMessage) + +$(JQ.deriveToJSON defaultJSON ''ChatTagData) diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index 94af3a9dad..37a5d5bf0d 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -21,11 +21,12 @@ import Data.Time.Clock (getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone) import Simplex.Chat import Simplex.Chat.Controller +import Simplex.Chat.Library.Commands import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Store.Profiles import Simplex.Chat.Types import Simplex.Chat.View (serializeChatResponse) -import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore, withTransaction, MigrationConfirmation (..)) +import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore, withTransaction) import System.Exit (exitFailure) import System.IO (hFlush, stdout) import Text.Read (readMaybe) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs new file mode 100644 index 0000000000..cadf35f580 --- /dev/null +++ b/src/Simplex/Chat/Library/Commands.hs @@ -0,0 +1,3992 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +module Simplex.Chat.Library.Commands where + +import Control.Applicative (optional, (<|>)) +import Control.Concurrent.STM (retry) +import Control.Logger.Simple +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Unlift +import Control.Monad.Reader +import qualified Data.Aeson as J +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (bimap, first, second) +import qualified Data.ByteArray as BA +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Char +import Data.Constraint (Dict (..)) +import Data.Either (fromRight, partitionEithers, rights) +import Data.Foldable (foldr') +import Data.Functor (($>)) +import Data.Int (Int64) +import Data.List (find, foldl', isSuffixOf, partition, sortOn, zipWith4) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as L +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime) +import Data.Time.Clock (UTCTime, getCurrentTime, nominalDay) +import Data.Type.Equality +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as V4 +import qualified Database.SQLite.Simple as SQL +import Simplex.Chat.Library.Subscriber +import Simplex.Chat.Archive +import Simplex.Chat.Call +import Simplex.Chat.Controller +import Simplex.Chat.Files +import Simplex.Chat.Markdown +import Simplex.Chat.Messages +import Simplex.Chat.Messages.CIContent +import Simplex.Chat.Messages.CIContent.Events +import Simplex.Chat.Operators +import Simplex.Chat.Options +import Simplex.Chat.ProfileGenerator (generateRandomProfile) +import Simplex.Chat.Protocol +import Simplex.Chat.Remote +import Simplex.Chat.Remote.Types +import Simplex.Chat.Library.Internal +import Simplex.Chat.Stats +import Simplex.Chat.Store +import Simplex.Chat.Store.AppSettings +import Simplex.Chat.Store.Connections +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Files +import Simplex.Chat.Store.Groups +import Simplex.Chat.Store.Messages +import Simplex.Chat.Store.NoteFolders +import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences +import Simplex.Chat.Types.Shared +import Simplex.Chat.Util (liftIOEither) +import qualified Simplex.Chat.Util as U +import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSize, maxFileSizeHard) +import Simplex.Messaging.Agent as Agent +import Simplex.Messaging.Agent.Client (SubInfo (..), agentClientStore, getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary) +import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles) +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Agent.Store.SQLite (execSQL, upMigration, withConnection) +import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) +import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB +import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations +import Simplex.Messaging.Client (NetworkConfig (..), SocksMode (SMAlways), textToHostMode) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) +import qualified Simplex.Messaging.Crypto.File as CF +import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQSupportOff, pattern PQSupportOn) +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (base64P) +import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolServer, ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, userProtocol) +import qualified Simplex.Messaging.Protocol as SMP +import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) +import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Transport.Client (defaultSocksProxyWithAuth) +import Simplex.Messaging.Util +import Simplex.Messaging.Version +import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..)) +import Simplex.RemoteControl.Types (RCCtrlAddress (..)) +import System.Exit (ExitCode, exitSuccess) +import System.FilePath (takeFileName, ()) +import System.IO (Handle, IOMode (..)) +import System.Random (randomRIO) +import UnliftIO.Async +import UnliftIO.Concurrent (forkIO, threadDelay) +import UnliftIO.Directory +import qualified UnliftIO.Exception as E +import UnliftIO.IO (hClose) +import UnliftIO.STM + +_defaultNtfServers :: [NtfServer] +_defaultNtfServers = + [ "ntf://FB-Uop7RTaZZEG0ZLD2CIaTjsPh-Fw0zFAnb7QyA8Ks=@ntf2.simplex.im,5ex3mupcazy3zlky64ab27phjhijpemsiby33qzq3pliejipbtx5xgad.onion" + -- "ntf://KmpZNNXiVZJx_G2T7jRUmDFxWXM3OAnunz3uLT0tqAA=@ntf3.simplex.im,pxculznuryunjdvtvh6s6szmanyadumpbmvevgdpe4wk5c65unyt4yid.onion", + -- "ntf://CJ5o7X6fCxj2FFYRU2KuCo70y4jSqz7td2HYhLnXWbU=@ntf4.simplex.im,wtvuhdj26jwprmomnyfu5wfuq2hjkzfcc72u44vi6gdhrwxldt6xauad.onion" + ] + +maxImageSize :: Integer +maxImageSize = 261120 * 2 -- auto-receive on mobiles + +imageExtensions :: [String] +imageExtensions = [".jpg", ".jpeg", ".png", ".gif"] + +fixedImagePreview :: ImageData +fixedImagePreview = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAYAAACqaXHeAAAAAXNSR0IArs4c6QAAAKVJREFUeF7t1kENACEUQ0FQhnVQ9lfGO+xggITQdvbMzArPey+8fa3tAfwAEdABZQspQStgBssEcgAIkSAJkiAJljtEgiRIgmUCSZAESZAESZAEyx0iQRIkwTKBJEiCv5fgvTd1wDmn7QAP4AeIgA4oW0gJWgEzWCZwbQ7gAA7ggLKFOIADOKBMIAeAEAmSIAmSYLlDJEiCJFgmkARJkARJ8N8S/ADTZUewBvnTOQAAAABJRU5ErkJggg==" + +-- enableSndFiles has no effect when mainApp is True +startChatController :: Bool -> Bool -> CM' (Async ()) +startChatController mainApp enableSndFiles = do + asks smpAgent >>= liftIO . resumeAgentClient + unless mainApp $ chatWriteVar' subscriptionMode SMOnlyCreate + users <- fromRight [] <$> runExceptT (withFastStore' getUsers) + restoreCalls + s <- asks agentAsync + readTVarIO s >>= maybe (start s users) (pure . fst) + where + start s users = do + a1 <- async agentSubscriber + a2 <- + if mainApp + then Just <$> async (subscribeUsers False users) + else pure Nothing + atomically . writeTVar s $ Just (a1, a2) + if mainApp + then do + startXFTP xftpStartWorkers + void $ forkIO $ startFilesToReceive users + startCleanupManager + void $ forkIO $ startExpireCIs users + else when enableSndFiles $ startXFTP xftpStartSndWorkers + pure a1 + startXFTP startWorkers = do + tmp <- readTVarIO =<< asks tempDirectory + runExceptT (withAgent $ \a -> startWorkers a tmp) >>= \case + Left e -> liftIO $ putStrLn $ "Error starting XFTP workers: " <> show e + Right _ -> pure () + startCleanupManager = do + cleanupAsync <- asks cleanupManagerAsync + readTVarIO cleanupAsync >>= \case + Nothing -> do + a <- Just <$> async (void $ runExceptT cleanupManager) + atomically $ writeTVar cleanupAsync a + _ -> pure () + startExpireCIs users = + forM_ users $ \user -> do + ttl <- fromRight Nothing <$> runExceptT (withStore' (`getChatItemTTL` user)) + forM_ ttl $ \_ -> do + startExpireCIThread user + setExpireCIFlag user True + +subscribeUsers :: Bool -> [User] -> CM' () +subscribeUsers onlyNeeded users = do + let (us, us') = partition activeUser users + vr <- chatVersionRange' + subscribe vr us + subscribe vr us' + where + subscribe :: VersionRangeChat -> [User] -> CM' () + subscribe vr = mapM_ $ runExceptT . subscribeUserConnections vr onlyNeeded Agent.subscribeConnections + +startFilesToReceive :: [User] -> CM' () +startFilesToReceive users = do + let (us, us') = partition activeUser users + startReceive us + startReceive us' + where + startReceive :: [User] -> CM' () + startReceive = mapM_ $ runExceptT . startReceiveUserFiles + +startReceiveUserFiles :: User -> CM () +startReceiveUserFiles user = do + filesToReceive <- withStore' (`getRcvFilesToReceive` user) + forM_ filesToReceive $ \ft -> + flip catchChatError (toView . CRChatError (Just user)) $ + toView =<< receiveFile' user ft False Nothing Nothing + +restoreCalls :: CM' () +restoreCalls = do + savedCalls <- fromRight [] <$> runExceptT (withFastStore' getCalls) + let callsMap = M.fromList $ map (\call@Call {contactId} -> (contactId, call)) savedCalls + calls <- asks currentCalls + atomically $ writeTVar calls callsMap + +stopChatController :: ChatController -> IO () +stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do + readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd) + atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd) + disconnectAgentClient smpAgent + readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2) + closeFiles sndFiles + closeFiles rcvFiles + atomically $ do + keys <- M.keys <$> readTVar expireCIFlags + forM_ keys $ \k -> TM.insert k False expireCIFlags + writeTVar s Nothing + where + closeFiles :: TVar (Map Int64 Handle) -> IO () + closeFiles files = do + fs <- readTVarIO files + mapM_ hClose fs + atomically $ writeTVar files M.empty + +updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig +updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} = + let cfg1 = maybe cfg (\smpProxyMode -> cfg {smpProxyMode}) smpProxyMode_ + cfg2 = maybe cfg1 (\smpProxyFallback -> cfg1 {smpProxyFallback}) smpProxyFallback_ + cfg3 = maybe cfg2 (\tcpTimeout -> cfg2 {tcpTimeout, tcpConnectTimeout = (tcpTimeout * 3) `div` 2}) tcpTimeout_ + in cfg3 {socksProxy, socksMode, hostMode, requiredHostMode, smpWebPort, logTLSErrors} + +useServers :: Foldable f => RandomAgentServers -> [(Text, ServerOperator)] -> f UserOperatorServers -> (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP)) +useServers as opDomains uss = + let smp' = useServerCfgs SPSMP as opDomains $ concatMap (servers' SPSMP) uss + xftp' = useServerCfgs SPXFTP as opDomains $ concatMap (servers' SPXFTP) uss + in (smp', xftp') + +execChatCommand :: Maybe RemoteHostId -> ByteString -> CM' ChatResponse +execChatCommand rh s = do + u <- readTVarIO =<< asks currentUser + case parseChatCommand s of + Left e -> pure $ chatCmdError u e + Right cmd -> case rh of + Just rhId + | allowRemoteCommand cmd -> execRemoteCommand u rhId cmd s + | otherwise -> pure $ CRChatCmdError u $ ChatErrorRemoteHost (RHId rhId) $ RHELocalCommand + _ -> do + cc@ChatController {config = ChatConfig {chatHooks}} <- ask + liftIO (preCmdHook chatHooks cc cmd) >>= either pure (execChatCommand_ u) + +execChatCommand' :: ChatCommand -> CM' ChatResponse +execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd) + +execChatCommand_ :: Maybe User -> ChatCommand -> CM' ChatResponse +execChatCommand_ u cmd = handleCommandError u $ processChatCommand cmd + +execRemoteCommand :: Maybe User -> RemoteHostId -> ChatCommand -> ByteString -> CM' ChatResponse +execRemoteCommand u rhId cmd s = handleCommandError u $ getRemoteHostClient rhId >>= \rh -> processRemoteCommand rhId rh cmd s + +handleCommandError :: Maybe User -> CM ChatResponse -> CM' ChatResponse +handleCommandError u a = either (CRChatCmdError u) id <$> (runExceptT a `E.catches` ioErrors) + where + ioErrors = + [ E.Handler $ \(e :: ExitCode) -> E.throwIO e, + E.Handler $ pure . Left . mkChatError + ] + +parseChatCommand :: ByteString -> Either String ChatCommand +parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace + +-- | Chat API commands interpreted in context of a local zone +processChatCommand :: ChatCommand -> CM ChatResponse +processChatCommand cmd = + chatVersionRange >>= (`processChatCommand'` cmd) +{-# INLINE processChatCommand #-} + +processChatCommand' :: VersionRangeChat -> ChatCommand -> CM ChatResponse +processChatCommand' vr = \case + ShowActiveUser -> withUser' $ pure . CRActiveUser + CreateActiveUser NewUser {profile, pastTimestamp} -> do + forM_ profile $ \Profile {displayName} -> checkValidName displayName + p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile + u <- asks currentUser + users <- withFastStore' getUsers + forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash} -> + when (n == displayName) . throwChatError $ + if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""} + (uss, (smp', xftp')) <- chooseServers =<< readTVarIO u + auId <- withAgent $ \a -> createUser a smp' xftp' + ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure + user <- withFastStore $ \db -> do + user <- createUserRecordAt db (AgentUserId auId) p True ts + mapM_ (setUserServers db user ts) uss + createPresetContactCards db user `catchStoreError` \_ -> pure () + createNoteFolder db user + pure user + atomically . writeTVar u $ Just user + pure $ CRActiveUser user + where + createPresetContactCards :: DB.Connection -> User -> ExceptT StoreError IO () + createPresetContactCards db user = do + createContact db user simplexStatusContactProfile + createContact db user simplexTeamContactProfile + chooseServers :: Maybe User -> CM ([UpdatedUserOperatorServers], (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))) + chooseServers user_ = do + as <- asks randomAgentServers + mapM (withFastStore . flip getUserServers >=> liftIO . groupByOperator) user_ >>= \case + Just uss -> do + let opDomains = operatorDomains $ mapMaybe operator' uss + uss' = map copyServers uss + pure $ (uss',) $ useServers as opDomains uss + Nothing -> do + ps <- asks randomPresetServers + uss <- presetUserServers <$> withFastStore' (\db -> getUpdateServerOperators db ps True) + let RandomAgentServers {smpServers = smp', xftpServers = xftp'} = as + pure (uss, (smp', xftp')) + copyServers :: UserOperatorServers -> UpdatedUserOperatorServers + copyServers UserOperatorServers {operator, smpServers, xftpServers} = + let new srv = AUS SDBNew srv {serverId = DBNewEntity} + in UpdatedUserOperatorServers {operator, smpServers = map new smpServers, xftpServers = map new xftpServers} + coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day) + day = 86400 + ListUsers -> CRUsersList <$> withFastStore' getUsersInfo + APISetActiveUser userId' viewPwd_ -> do + unlessM (lift chatStarted) $ throwChatError CEChatNotStarted + user_ <- chatReadVar currentUser + user' <- privateGetUser userId' + validateUserPassword_ user_ user' viewPwd_ + user'' <- withFastStore' (`setActiveUser` user') + chatWriteVar currentUser $ Just user'' + pure $ CRActiveUser user'' + SetActiveUser uName viewPwd_ -> do + tryChatError (withFastStore (`getUserIdByName` uName)) >>= \case + Left _ -> throwChatError CEUserUnknown + Right userId -> processChatCommand $ APISetActiveUser userId viewPwd_ + SetAllContactReceipts onOff -> withUser $ \_ -> withFastStore' (`updateAllContactReceipts` onOff) >> ok_ + APISetUserContactReceipts userId' settings -> withUser $ \user -> do + user' <- privateGetUser userId' + validateUserPassword user user' Nothing + withFastStore' $ \db -> updateUserContactReceipts db user' settings + ok user + SetUserContactReceipts settings -> withUser $ \User {userId} -> processChatCommand $ APISetUserContactReceipts userId settings + APISetUserGroupReceipts userId' settings -> withUser $ \user -> do + user' <- privateGetUser userId' + validateUserPassword user user' Nothing + withFastStore' $ \db -> updateUserGroupReceipts db user' settings + ok user + SetUserGroupReceipts settings -> withUser $ \User {userId} -> processChatCommand $ APISetUserGroupReceipts userId settings + APIHideUser userId' (UserPwd viewPwd) -> withUser $ \user -> do + user' <- privateGetUser userId' + case viewPwdHash user' of + Just _ -> throwChatError $ CEUserAlreadyHidden userId' + _ -> do + when (T.null viewPwd) $ throwChatError $ CEEmptyUserPassword userId' + users <- withFastStore' getUsers + unless (length (filter (isNothing . viewPwdHash) users) > 1) $ throwChatError $ CECantHideLastUser userId' + viewPwdHash' <- hashPassword + setUserPrivacy user user' {viewPwdHash = viewPwdHash', showNtfs = False} + where + hashPassword = do + salt <- drgRandomBytes 16 + let hash = B64UrlByteString $ C.sha512Hash $ encodeUtf8 viewPwd <> salt + pure $ Just UserPwdHash {hash, salt = B64UrlByteString salt} + APIUnhideUser userId' viewPwd@(UserPwd pwd) -> withUser $ \user -> do + user' <- privateGetUser userId' + case viewPwdHash user' of + Nothing -> throwChatError $ CEUserNotHidden userId' + _ -> do + when (T.null pwd) $ throwChatError $ CEEmptyUserPassword userId' + validateUserPassword user user' $ Just viewPwd + setUserPrivacy user user' {viewPwdHash = Nothing, showNtfs = True} + APIMuteUser userId' -> setUserNotifications userId' False + APIUnmuteUser userId' -> setUserNotifications userId' True + HideUser viewPwd -> withUser $ \User {userId} -> processChatCommand $ APIHideUser userId viewPwd + UnhideUser viewPwd -> withUser $ \User {userId} -> processChatCommand $ APIUnhideUser userId viewPwd + MuteUser -> withUser $ \User {userId} -> processChatCommand $ APIMuteUser userId + UnmuteUser -> withUser $ \User {userId} -> processChatCommand $ APIUnmuteUser userId + APIDeleteUser userId' delSMPQueues viewPwd_ -> withUser $ \user -> do + user' <- privateGetUser userId' + validateUserPassword user user' viewPwd_ + checkDeleteChatUser user' + withChatLock "deleteUser" . procCmd $ deleteChatUser user' delSMPQueues + DeleteUser uName delSMPQueues viewPwd_ -> withUserName uName $ \userId -> APIDeleteUser userId delSMPQueues viewPwd_ + StartChat {mainApp, enableSndFiles} -> withUser' $ \_ -> + asks agentAsync >>= readTVarIO >>= \case + Just _ -> pure CRChatRunning + _ -> checkStoreNotChanged . lift $ startChatController mainApp enableSndFiles $> CRChatStarted + CheckChatRunning -> maybe CRChatStopped (const CRChatRunning) <$> chatReadVar agentAsync + APIStopChat -> do + ask >>= liftIO . stopChatController + pure CRChatStopped + APIActivateChat restoreChat -> withUser $ \_ -> do + lift $ when restoreChat restoreCalls + lift $ withAgent' foregroundAgent + chatWriteVar chatActivated True + when restoreChat $ do + users <- withFastStore' getUsers + lift $ do + void . forkIO $ subscribeUsers True users + void . forkIO $ startFilesToReceive users + setAllExpireCIFlags True + ok_ + APISuspendChat t -> do + chatWriteVar chatActivated False + lift $ setAllExpireCIFlags False + stopRemoteCtrl + lift $ withAgent' (`suspendAgent` t) + ok_ + ResubscribeAllConnections -> withStore' getUsers >>= lift . subscribeUsers False >> ok_ + -- has to be called before StartChat + SetTempFolder tf -> do + createDirectoryIfMissing True tf + asks tempDirectory >>= atomically . (`writeTVar` Just tf) + ok_ + SetFilesFolder ff -> do + createDirectoryIfMissing True ff + asks filesFolder >>= atomically . (`writeTVar` Just ff) + ok_ + SetRemoteHostsFolder rf -> do + createDirectoryIfMissing True rf + chatWriteVar remoteHostsFolder $ Just rf + ok_ + -- has to be called before StartChat + APISetAppFilePaths cfg -> do + setFolder filesFolder $ appFilesFolder cfg + setFolder tempDirectory $ appTempFolder cfg + setFolder assetsDirectory $ appAssetsFolder cfg + mapM_ (setFolder remoteHostsFolder) $ appRemoteHostsFolder cfg + ok_ + where + setFolder sel f = do + createDirectoryIfMissing True f + chatWriteVar sel $ Just f + APISetEncryptLocalFiles on -> chatWriteVar encryptLocalFiles on >> ok_ + SetContactMergeEnabled onOff -> chatWriteVar contactMergeEnabled onOff >> ok_ + APIExportArchive cfg -> checkChatStopped $ CRArchiveExported <$> lift (exportArchive cfg) + ExportArchive -> do + ts <- liftIO getCurrentTime + let filePath = "simplex-chat." <> formatTime defaultTimeLocale "%FT%H%M%SZ" ts <> ".zip" + processChatCommand $ APIExportArchive $ ArchiveConfig filePath Nothing Nothing + APIImportArchive cfg -> checkChatStopped $ do + fileErrs <- lift $ importArchive cfg + setStoreChanged + pure $ CRArchiveImported fileErrs + APISaveAppSettings as -> withFastStore' (`saveAppSettings` as) >> ok_ + APIGetAppSettings platformDefaults -> CRAppSettings <$> withFastStore' (`getAppSettings` platformDefaults) + APIDeleteStorage -> withStoreChanged deleteStorage + APIStorageEncryption cfg -> withStoreChanged $ sqlCipherExport cfg + TestStorageEncryption key -> sqlCipherTestKey key >> ok_ + ExecChatStoreSQL query -> CRSQLResult <$> withStore' (`execSQL` query) + ExecAgentStoreSQL query -> CRSQLResult <$> withAgent (`execAgentStoreSQL` query) + SlowSQLQueries -> do + ChatController {chatStore, smpAgent} <- ask + chatQueries <- slowQueries chatStore + agentQueries <- slowQueries $ agentClientStore smpAgent + pure CRSlowSQLQueries {chatQueries, agentQueries} + where + slowQueries st = + liftIO $ + map (uncurry SlowSQLQuery . first SQL.fromQuery) + . sortOn (timeAvg . snd) + . M.assocs + <$> withConnection st (readTVarIO . DB.slow) + APIGetChatTags userId -> withUserId' userId $ \user -> do + tags <- withFastStore' (`getUserChatTags` user) + pure $ CRChatTags user tags + APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do + (errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user pendingConnections pagination query) + unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs) + pure $ CRApiChats user previews + APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of + -- TODO optimize queries calculating ChatStats, currently they're disabled + CTDirect -> do + (directChat, navInfo) <- withFastStore (\db -> getDirectChat db vr user cId pagination search) + pure $ CRApiChat user (AChat SCTDirect directChat) navInfo + CTGroup -> do + (groupChat, navInfo) <- withFastStore (\db -> getGroupChat db vr user cId pagination search) + pure $ CRApiChat user (AChat SCTGroup groupChat) navInfo + CTLocal -> do + (localChat, navInfo) <- withFastStore (\db -> getLocalChat db user cId pagination search) + pure $ CRApiChat user (AChat SCTLocal localChat) navInfo + CTContactRequest -> pure $ chatCmdError (Just user) "not implemented" + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + APIGetChatItems pagination search -> withUser $ \user -> do + chatItems <- withFastStore $ \db -> getAllChatItems db vr user pagination search + pure $ CRChatItems user Nothing chatItems + APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do + (aci@(AChatItem cType dir _ ci), versions) <- withFastStore $ \db -> + (,) <$> getAChatItem db vr user chatRef itemId <*> liftIO (getChatItemVersions db itemId) + let itemVersions = if null versions then maybeToList $ mkItemVersion ci else versions + memberDeliveryStatuses <- case (cType, dir) of + (SCTGroup, SMDSnd) -> L.nonEmpty <$> withFastStore' (`getGroupSndStatuses` itemId) + _ -> pure Nothing + forwardedFromChatItem <- getForwardedFromItem user ci + pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses, forwardedFromChatItem} + where + getForwardedFromItem :: User -> ChatItem c d -> CM (Maybe AChatItem) + getForwardedFromItem user ChatItem {meta = CIMeta {itemForwarded}} = case itemForwarded of + Just (CIFFContact _ _ (Just ctId) (Just fwdItemId)) -> + Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTDirect ctId) fwdItemId) + Just (CIFFGroup _ _ (Just gId) (Just fwdItemId)) -> + Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId) + _ -> pure Nothing + APISendMessages (ChatRef cType chatId) live itemTTL cms -> withUser $ \user -> case cType of + CTDirect -> + withContactLock "sendMessage" chatId $ + sendContactContentMessages user chatId live itemTTL (L.map (,Nothing) cms) + CTGroup -> + withGroupLock "sendMessage" chatId $ + sendGroupContentMessages user chatId live itemTTL (L.map (,Nothing) cms) + CTLocal -> pure $ chatCmdError (Just user) "not supported" + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do + _ <- createChatTag db user emoji text + CRChatTags user <$> getUserChatTags db user + APISetChatTags (ChatRef cType chatId) tagIds -> withUser $ \user -> withFastStore' $ \db -> case cType of + CTDirect -> do + updateDirectChatTags db chatId (maybe [] L.toList tagIds) + CRTagsUpdated user <$> getUserChatTags db user <*> getDirectChatTags db chatId + CTGroup -> do + updateGroupChatTags db chatId (maybe [] L.toList tagIds) + CRTagsUpdated user <$> getUserChatTags db user <*> getGroupChatTags db chatId + _ -> pure $ chatCmdError (Just user) "not supported" + APIDeleteChatTag tagId -> withUser $ \user -> do + withFastStore' $ \db -> deleteChatTag db user tagId + ok user + APIUpdateChatTag tagId (ChatTagData emoji text) -> withUser $ \user -> do + withFastStore' $ \db -> updateChatTag db user tagId emoji text + ok user + APIReorderChatTags tagIds -> withUser $ \user -> do + withFastStore' $ \db -> reorderChatTags db user $ L.toList tagIds + ok user + APICreateChatItems folderId cms -> withUser $ \user -> + createNoteFolderContentItems user folderId (L.map (,Nothing) cms) + APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> case cType of + CTDirect -> withContactLock "updateChatItem" chatId $ do + ct@Contact {contactId} <- withFastStore $ \db -> getContact db vr user chatId + assertDirectAllowed user MDSnd ct XMsgUpdate_ + cci <- withFastStore $ \db -> getDirectCIWithReactions db user ct itemId + case cci of + CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do + case (ciContent, itemSharedMsgId, editable) of + (CISndMsgContent oldMC, Just itemSharedMId, True) -> do + let changed = mc /= oldMC + if changed || fromMaybe False itemLive + then do + (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) + ci' <- withFastStore' $ \db -> do + currentTs <- liftIO getCurrentTime + when changed $ + addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) + let edited = itemLive /= Just True + updateDirectChatItem' db user contactId ci (CISndMsgContent mc) edited live Nothing $ Just msgId + startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci' + 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 -> withGroupLock "updateChatItem" chatId $ do + Group gInfo@GroupInfo {groupId, membership} ms <- withFastStore $ \db -> getGroup db vr user chatId + assertUserGroupRole gInfo GRAuthor + if prohibitedSimplexLinks gInfo membership mc + then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks)) + else do + cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId + case cci of + CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do + case (ciContent, itemSharedMsgId, editable) of + (CISndMsgContent oldMC, Just itemSharedMId, True) -> do + let changed = mc /= oldMC + if changed || fromMaybe False itemLive + then do + SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) + ci' <- withFastStore' $ \db -> do + currentTs <- liftIO getCurrentTime + when changed $ + addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) + let edited = itemLive /= Just True + updateGroupChatItem db user groupId ci (CISndMsgContent mc) edited live $ Just msgId + startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci' + pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci') + else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) + _ -> throwChatError CEInvalidChatItemUpdate + CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate + CTLocal -> do + (nf@NoteFolder {noteFolderId}, cci) <- withFastStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId + case cci of + CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent oldMC} + | mc == oldMC -> pure $ CRChatItemNotChanged user (AChatItem SCTLocal SMDSnd (LocalChat nf) ci) + | otherwise -> withFastStore' $ \db -> do + currentTs <- getCurrentTime + addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) + ci' <- updateLocalChatItem' db user noteFolderId ci (CISndMsgContent mc) True + pure $ CRChatItemUpdated user (AChatItem SCTLocal SMDSnd (LocalChat nf) ci') + _ -> throwChatError CEInvalidChatItemUpdate + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + APIDeleteChatItem (ChatRef cType chatId) itemIds mode -> withUser $ \user -> case cType of + CTDirect -> withContactLock "deleteChatItem" chatId $ do + (ct, items) <- getCommandDirectChatItems user chatId itemIds + case mode of + CIDMInternal -> deleteDirectCIs user ct items True False + CIDMBroadcast -> do + assertDeletable items + assertDirectAllowed user MDSnd ct XMsgDel_ + let msgIds = itemsMsgIds items + events = map (\msgId -> XMsgDel msgId Nothing) msgIds + forM_ (L.nonEmpty events) $ \events' -> + sendDirectContactMessages user ct events' + if featureAllowed SCFFullDelete forUser ct + then deleteDirectCIs user ct items True False + else markDirectCIsDeleted user ct items True =<< liftIO getCurrentTime + CTGroup -> withGroupLock "deleteChatItem" chatId $ do + (gInfo, items) <- getCommandGroupChatItems user chatId itemIds + ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo + case mode of + CIDMInternal -> deleteGroupCIs user gInfo items True False Nothing =<< liftIO getCurrentTime + CIDMBroadcast -> do + assertDeletable items + assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier + let msgIds = itemsMsgIds items + events = L.nonEmpty $ map (`XMsgDel` Nothing) msgIds + mapM_ (sendGroupMessages user gInfo ms) events + delGroupChatItems user gInfo items Nothing + CTLocal -> do + (nf, items) <- getCommandLocalChatItems user chatId itemIds + deleteLocalCIs user nf items True False + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + where + assertDeletable :: forall c. ChatTypeI c => [CChatItem c] -> CM () + assertDeletable items = do + currentTs <- liftIO getCurrentTime + unless (all (itemDeletable currentTs) items) $ throwChatError CEInvalidChatItemDelete + where + itemDeletable :: UTCTime -> CChatItem c -> Bool + itemDeletable currentTs (CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, itemTs, itemDeleted}, content}) = + case msgDir of + -- We check with a 6 hour margin compared to CIMeta deletable to account for deletion on the border + SMDSnd -> isJust itemSharedMsgId && deletable' content itemDeleted itemTs (nominalDay + 6 * 3600) currentTs + SMDRcv -> False + itemsMsgIds :: [CChatItem c] -> [SharedMsgId] + itemsMsgIds = mapMaybe (\(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) -> itemSharedMsgId) + APIDeleteMemberChatItem gId itemIds -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do + (gInfo@GroupInfo {membership}, items) <- getCommandGroupChatItems user gId itemIds + ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo + assertDeletable gInfo items + assertUserGroupRole gInfo GRAdmin + let msgMemIds = itemsMsgMemIds gInfo items + events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId (Just memId)) msgMemIds + mapM_ (sendGroupMessages user gInfo ms) events + delGroupChatItems user gInfo items (Just membership) + where + assertDeletable :: GroupInfo -> [CChatItem 'CTGroup] -> CM () + assertDeletable GroupInfo {membership = GroupMember {memberRole = membershipMemRole}} items = + unless (all itemDeletable items) $ throwChatError CEInvalidChatItemDelete + where + itemDeletable :: CChatItem 'CTGroup -> Bool + itemDeletable (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) = + case chatDir of + CIGroupRcv GroupMember {memberRole} -> membershipMemRole >= memberRole && isJust itemSharedMsgId + CIGroupSnd -> isJust itemSharedMsgId + itemsMsgMemIds :: GroupInfo -> [CChatItem 'CTGroup] -> [(SharedMsgId, MemberId)] + itemsMsgMemIds GroupInfo {membership = GroupMember {memberId = membershipMemId}} = mapMaybe itemMsgMemIds + where + itemMsgMemIds :: CChatItem 'CTGroup -> Maybe (SharedMsgId, MemberId) + itemMsgMemIds (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) = + join <$> forM itemSharedMsgId $ \msgId -> Just $ case chatDir of + CIGroupRcv GroupMember {memberId} -> (msgId, memberId) + CIGroupSnd -> (msgId, membershipMemId) + APIChatItemReaction (ChatRef cType chatId) itemId add reaction -> withUser $ \user -> case cType of + CTDirect -> + withContactLock "chatItemReaction" chatId $ + withFastStore (\db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId) >>= \case + (ct, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do + unless (featureAllowed SCFReactions forUser ct) $ + throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) + unless (ciReactionAllowed ci) $ + throwChatError (CECommandError "reaction not allowed - chat item has no content") + rs <- withFastStore' $ \db -> getDirectReactions db ct itemSharedMId True + checkReactionAllowed rs + (SndMessage {msgId}, _) <- sendDirectContactMessage user ct $ XMsgReact itemSharedMId Nothing reaction add + createdAt <- liftIO getCurrentTime + reactions <- withFastStore' $ \db -> do + setDirectReaction db ct itemSharedMId True reaction add msgId createdAt + liftIO $ getDirectCIReactions db ct itemSharedMId + let ci' = CChatItem md ci {reactions} + r = ACIReaction SCTDirect SMDSnd (DirectChat ct) $ CIReaction CIDirectSnd ci' createdAt reaction + pure $ CRChatItemReaction user add r + _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" + CTGroup -> + withGroupLock "chatItemReaction" chatId $ + withFastStore (\db -> (,) <$> getGroup db vr user chatId <*> getGroupChatItem db user chatId itemId) >>= \case + (Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do + unless (groupFeatureAllowed SGFReactions g) $ + throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) + unless (ciReactionAllowed ci) $ + throwChatError (CECommandError "reaction not allowed - chat item has no content") + let GroupMember {memberId = itemMemberId} = chatItemMember g ci + rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True + checkReactionAllowed rs + SndMessage {msgId} <- sendGroupMessage user g ms (XMsgReact itemSharedMId (Just itemMemberId) reaction add) + createdAt <- liftIO getCurrentTime + reactions <- withFastStore' $ \db -> do + setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt + liftIO $ getGroupCIReactions db g itemMemberId itemSharedMId + let ci' = CChatItem md ci {reactions} + r = ACIReaction SCTGroup SMDSnd (GroupChat g) $ CIReaction CIGroupSnd ci' createdAt reaction + pure $ CRChatItemReaction user add r + _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" + CTLocal -> pure $ chatCmdError (Just user) "not supported" + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + where + checkReactionAllowed rs = do + when ((reaction `elem` rs) == add) $ + throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") + when (add && length rs >= maxMsgReactions) $ + throwChatError (CECommandError "too many reactions") + APIGetReactionMembers userId groupId itemId reaction -> withUserId userId $ \user -> do + memberReactions <- withStore $ \db -> do + CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}} <- getGroupChatItem db user groupId itemId + liftIO $ getReactionMembers db vr user groupId itemSharedMId reaction + pure $ CRReactionMembers user memberReactions + APIPlanForwardChatItems (ChatRef fromCType fromChatId) itemIds -> withUser $ \user -> case fromCType of + CTDirect -> planForward user . snd =<< getCommandDirectChatItems user fromChatId itemIds + CTGroup -> planForward user . snd =<< getCommandGroupChatItems user fromChatId itemIds + CTLocal -> planForward user . snd =<< getCommandLocalChatItems user fromChatId itemIds + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + where + planForward :: User -> [CChatItem c] -> CM ChatResponse + planForward user items = do + (itemIds', forwardErrors) <- unzip <$> mapM planItemForward items + let forwardConfirmation = case catMaybes forwardErrors of + [] -> Nothing + errs -> Just $ case mainErr of + FFENotAccepted _ -> FCFilesNotAccepted fileIds + FFEInProgress -> FCFilesInProgress filesCount + FFEMissing -> FCFilesMissing filesCount + FFEFailed -> FCFilesFailed filesCount + where + mainErr = minimum errs + fileIds = catMaybes $ map (\case FFENotAccepted ftId -> Just ftId; _ -> Nothing) errs + filesCount = length $ filter (mainErr ==) errs + pure CRForwardPlan {user, itemsCount = length itemIds, chatItemIds = catMaybes itemIds', forwardConfirmation} + where + planItemForward :: CChatItem c -> CM (Maybe ChatItemId, Maybe ForwardFileError) + planItemForward (CChatItem _ ci) = forwardMsgContent ci >>= maybe (pure (Nothing, Nothing)) (forwardContentPlan ci) + forwardContentPlan :: ChatItem c d -> MsgContent -> CM (Maybe ChatItemId, Maybe ForwardFileError) + forwardContentPlan ChatItem {file, meta = CIMeta {itemId}} mc = case file of + Nothing -> pure (Just itemId, Nothing) + Just CIFile {fileId, fileStatus, fileSource} -> case ciFileForwardError fileId fileStatus of + Just err -> pure $ itemIdWithoutFile err + Nothing -> case fileSource of + Just CryptoFile {filePath} -> do + exists <- doesFileExist =<< lift (toFSFilePath filePath) + pure $ if exists then (Just itemId, Nothing) else itemIdWithoutFile FFEMissing + Nothing -> pure $ itemIdWithoutFile FFEMissing + where + itemIdWithoutFile err = (if hasContent then Just itemId else Nothing, Just err) + hasContent = case mc of + MCText _ -> True + MCLink {} -> True + MCImage {} -> True + MCVideo {text} -> text /= "" + MCVoice {text} -> text /= "" + MCFile t -> t /= "" + MCUnknown {} -> True + APIForwardChatItems (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemIds itemTTL -> withUser $ \user -> case toCType of + CTDirect -> do + cmrs <- prepareForward user + case L.nonEmpty cmrs of + Just cmrs' -> + withContactLock "forwardChatItem, to contact" toChatId $ + sendContactContentMessages user toChatId False itemTTL cmrs' + Nothing -> pure $ CRNewChatItems user [] + CTGroup -> do + cmrs <- prepareForward user + case L.nonEmpty cmrs of + Just cmrs' -> + withGroupLock "forwardChatItem, to group" toChatId $ + sendGroupContentMessages user toChatId False itemTTL cmrs' + Nothing -> pure $ CRNewChatItems user [] + CTLocal -> do + cmrs <- prepareForward user + case L.nonEmpty cmrs of + Just cmrs' -> + createNoteFolderContentItems user toChatId cmrs' + Nothing -> pure $ CRNewChatItems user [] + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + where + prepareForward :: User -> CM [ComposeMessageReq] + prepareForward user = case fromCType of + CTDirect -> withContactLock "forwardChatItem, from contact" fromChatId $ do + (ct, items) <- getCommandDirectChatItems user fromChatId itemIds + catMaybes <$> mapM (\ci -> ciComposeMsgReq ct ci <$$> prepareMsgReq ci) items + where + ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq + ciComposeMsgReq ct (CChatItem md ci) (mc', file) = + let itemId = chatItemId' ci + ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) (toMsgDirection md) (Just fromChatId) (Just itemId)) + in (ComposedMessage file Nothing mc', ciff) + where + forwardName :: Contact -> ContactName + forwardName Contact {profile = LocalProfile {displayName, localAlias}} + | localAlias /= "" = localAlias + | otherwise = displayName + CTGroup -> withGroupLock "forwardChatItem, from group" fromChatId $ do + (gInfo, items) <- getCommandGroupChatItems user fromChatId itemIds + catMaybes <$> mapM (\ci -> ciComposeMsgReq gInfo ci <$$> prepareMsgReq ci) items + where + ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq + ciComposeMsgReq gInfo (CChatItem md ci) (mc', file) = do + let itemId = chatItemId' ci + ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) (toMsgDirection md) (Just fromChatId) (Just itemId)) + in (ComposedMessage file Nothing mc', ciff) + where + forwardName :: GroupInfo -> ContactName + forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName + CTLocal -> do + (_, items) <- getCommandLocalChatItems user fromChatId itemIds + catMaybes <$> mapM (\ci -> ciComposeMsgReq ci <$$> prepareMsgReq ci) items + where + ciComposeMsgReq :: CChatItem 'CTLocal -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq + ciComposeMsgReq (CChatItem _ ci) (mc', file) = + let ciff = forwardCIFF ci Nothing + in (ComposedMessage file Nothing mc', ciff) + CTContactRequest -> throwChatError $ CECommandError "not supported" + CTContactConnection -> throwChatError $ CECommandError "not supported" + where + prepareMsgReq :: CChatItem c -> CM (Maybe (MsgContent, Maybe CryptoFile)) + prepareMsgReq (CChatItem _ ci) = forwardMsgContent ci $>>= forwardContent ci + forwardCIFF :: ChatItem c d -> Maybe CIForwardedFrom -> Maybe CIForwardedFrom + forwardCIFF ChatItem {meta = CIMeta {itemForwarded}} ciff = case itemForwarded of + Nothing -> ciff + Just CIFFUnknown -> ciff + Just prevCIFF -> Just prevCIFF + forwardContent :: ChatItem c d -> MsgContent -> CM (Maybe (MsgContent, Maybe CryptoFile)) + forwardContent ChatItem {file} mc = case file of + Nothing -> pure $ Just (mc, Nothing) + Just CIFile {fileName, fileStatus, fileSource = Just fromCF@CryptoFile {filePath}} + | ciFileLoaded fileStatus -> + chatReadVar filesFolder >>= \case + Nothing -> + ifM (doesFileExist filePath) (pure $ Just (mc, Just fromCF)) (pure contentWithoutFile) + Just filesFolder -> do + let fsFromPath = filesFolder filePath + ifM + (doesFileExist fsFromPath) + ( do + fsNewPath <- liftIO $ filesFolder `uniqueCombine` fileName + liftIO $ B.writeFile fsNewPath "" -- create empty file + encrypt <- chatReadVar encryptLocalFiles + cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing + let toCF = CryptoFile fsNewPath cfArgs + -- to keep forwarded file in case original is deleted + liftIOEither $ runExceptT $ withExceptT (ChatError . CEInternalError . show) $ copyCryptoFile (fromCF {filePath = fsFromPath} :: CryptoFile) toCF + pure $ Just (mc, Just (toCF {filePath = takeFileName fsNewPath} :: CryptoFile)) + ) + (pure contentWithoutFile) + _ -> pure contentWithoutFile + where + contentWithoutFile = case mc of + MCImage {} -> Just (mc, Nothing) + MCLink {} -> Just (mc, Nothing) + _ | contentText /= "" -> Just (MCText contentText, Nothing) + _ -> Nothing + contentText = msgContentText mc + copyCryptoFile :: CryptoFile -> CryptoFile -> ExceptT CF.FTCryptoError IO () + copyCryptoFile fromCF@CryptoFile {filePath = fsFromPath, cryptoArgs = fromArgs} toCF@CryptoFile {cryptoArgs = toArgs} = do + fromSizeFull <- getFileSize fsFromPath + let fromSize = fromSizeFull - maybe 0 (const $ toInteger C.authTagSize) fromArgs + CF.withFile fromCF ReadMode $ \fromH -> + CF.withFile toCF WriteMode $ \toH -> do + copyChunks fromH toH fromSize + forM_ fromArgs $ \_ -> CF.hGetTag fromH + forM_ toArgs $ \_ -> liftIO $ CF.hPutTag toH + where + copyChunks :: CF.CryptoFileHandle -> CF.CryptoFileHandle -> Integer -> ExceptT CF.FTCryptoError IO () + copyChunks r w size = do + let chSize = min size U.chunkSize + chSize' = fromIntegral chSize + size' = size - chSize + ch <- liftIO $ CF.hGet r chSize' + when (B.length ch /= chSize') $ throwError $ CF.FTCEFileIOError "encrypting file: unexpected EOF" + liftIO . CF.hPut w $ LB.fromStrict ch + when (size' > 0) $ copyChunks r w size' + APIUserRead userId -> withUserId userId $ \user -> withFastStore' (`setUserChatsRead` user) >> ok user + UserRead -> withUser $ \User {userId} -> processChatCommand $ APIUserRead userId + APIChatRead chatRef@(ChatRef cType chatId) -> withUser $ \_ -> case cType of + CTDirect -> do + user <- withFastStore $ \db -> getUserByContactId db chatId + ts <- liftIO getCurrentTime + timedItems <- withFastStore' $ \db -> do + timedItems <- getDirectUnreadTimedItems db user chatId + updateDirectChatItemsRead db user chatId + setDirectChatItemsDeleteAt db user chatId timedItems ts + forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt + ok user + CTGroup -> do + user <- withFastStore $ \db -> getUserByGroupId db chatId + ts <- liftIO getCurrentTime + timedItems <- withFastStore' $ \db -> do + timedItems <- getGroupUnreadTimedItems db user chatId + updateGroupChatItemsRead db user chatId + setGroupChatItemsDeleteAt db user chatId timedItems ts + forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt + ok user + CTLocal -> do + user <- withFastStore $ \db -> getUserByNoteFolderId db chatId + withFastStore' $ \db -> updateLocalChatItemsRead db user chatId + ok user + CTContactRequest -> pure $ chatCmdError Nothing "not supported" + CTContactConnection -> pure $ chatCmdError Nothing "not supported" + APIChatItemsRead chatRef@(ChatRef cType chatId) itemIds -> withUser $ \_ -> case cType of + CTDirect -> do + user <- withFastStore $ \db -> getUserByContactId db chatId + timedItems <- withFastStore' $ \db -> do + timedItems <- updateDirectChatItemsReadList db user chatId itemIds + setDirectChatItemsDeleteAt db user chatId timedItems =<< getCurrentTime + forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt + ok user + CTGroup -> do + user <- withFastStore $ \db -> getUserByGroupId db chatId + timedItems <- withFastStore' $ \db -> do + timedItems <- updateGroupChatItemsReadList db user chatId itemIds + setGroupChatItemsDeleteAt db user chatId timedItems =<< getCurrentTime + forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt + ok user + CTLocal -> pure $ chatCmdError Nothing "not supported" + CTContactRequest -> pure $ chatCmdError Nothing "not supported" + CTContactConnection -> pure $ chatCmdError Nothing "not supported" + APIChatUnread (ChatRef cType chatId) unreadChat -> withUser $ \user -> case cType of + CTDirect -> do + withFastStore $ \db -> do + ct <- getContact db vr user chatId + liftIO $ updateContactUnreadChat db user ct unreadChat + ok user + CTGroup -> do + withFastStore $ \db -> do + Group {groupInfo} <- getGroup db vr user chatId + liftIO $ updateGroupUnreadChat db user groupInfo unreadChat + ok user + CTLocal -> do + withFastStore $ \db -> do + nf <- getNoteFolder db user chatId + liftIO $ updateNoteFolderUnreadChat db user nf unreadChat + ok user + _ -> pure $ chatCmdError (Just user) "not supported" + APIDeleteChat cRef@(ChatRef cType chatId) cdm -> withUser $ \user@User {userId} -> case cType of + CTDirect -> do + ct <- withFastStore $ \db -> getContact db vr user chatId + filesInfo <- withFastStore' $ \db -> getContactFileInfo db user ct + withContactLock "deleteChat direct" chatId . procCmd $ + case cdm of + CDMFull notify -> do + cancelFilesInProgress user filesInfo + deleteFilesLocally filesInfo + sendDelDeleteConns ct notify + -- functions below are called in separate transactions to prevent crashes on android + -- (possibly, race condition on integrity check?) + withFastStore' $ \db -> do + deleteContactConnections db user ct + deleteContactFiles db user ct + withFastStore $ \db -> deleteContact db user ct + pure $ CRContactDeleted user ct + CDMEntity notify -> do + cancelFilesInProgress user filesInfo + sendDelDeleteConns ct notify + ct' <- withFastStore $ \db -> do + liftIO $ deleteContactConnections db user ct + liftIO $ void $ updateContactStatus db user ct CSDeletedByUser + getContact db vr user chatId + pure $ CRContactDeleted user ct' + CDMMessages -> do + void $ processChatCommand $ APIClearChat cRef + withFastStore' $ \db -> setContactChatDeleted db user ct True + pure $ CRContactDeleted user ct {chatDeleted = True} + where + sendDelDeleteConns ct notify = do + let doSendDel = contactReady ct && contactActive ct && notify + when doSendDel $ void (sendDirectContactMessage user ct XDirectDel) `catchChatError` const (pure ()) + contactConnIds <- map aConnId <$> withFastStore' (\db -> getContactConnections db vr userId ct) + deleteAgentConnectionsAsync' user contactConnIds doSendDel + CTContactConnection -> withConnectionLock "deleteChat contactConnection" chatId . procCmd $ do + conn@PendingContactConnection {pccAgentConnId = AgentConnId acId} <- withFastStore $ \db -> getPendingContactConnection db userId chatId + deleteAgentConnectionAsync user acId + withFastStore' $ \db -> deletePendingContactConnection db userId chatId + pure $ CRContactConnectionDeleted user conn + CTGroup -> do + Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user chatId + let GroupMember {memberRole = membershipMemRole} = membership + let isOwner = membershipMemRole == GROwner + canDelete = isOwner || not (memberCurrent membership) + unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner + filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo + withGroupLock "deleteChat group" chatId . procCmd $ do + cancelFilesInProgress user filesInfo + deleteFilesLocally filesInfo + let doSendDel = memberActive membership && isOwner + when doSendDel . void $ sendGroupMessage' user gInfo members XGrpDel + deleteGroupLinkIfExists user gInfo + deleteMembersConnections' user members doSendDel + updateCIGroupInvitationStatus user gInfo CIGISRejected `catchChatError` \_ -> pure () + -- functions below are called in separate transactions to prevent crashes on android + -- (possibly, race condition on integrity check?) + withStore' $ \db -> deleteGroupConnectionsAndFiles db user gInfo members + withStore' $ \db -> deleteGroupItemsAndMembers db user gInfo members + withStore' $ \db -> deleteGroup db user gInfo + let contactIds = mapMaybe memberContactId members + (errs1, (errs2, connIds)) <- lift $ second unzip . partitionEithers <$> withStoreBatch (\db -> map (deleteUnusedContact db) contactIds) + let errs = errs1 <> mapMaybe (fmap ChatErrorStore) errs2 + unless (null errs) $ toView $ CRChatErrors (Just user) errs + deleteAgentConnectionsAsync user $ concat connIds + pure $ CRGroupDeletedUser user gInfo + where + deleteUnusedContact :: DB.Connection -> ContactId -> IO (Either ChatError (Maybe StoreError, [ConnId])) + deleteUnusedContact db contactId = runExceptT . withExceptT ChatErrorStore $ do + ct <- getContact db vr user contactId + ifM + ((directOrUsed ct ||) . isJust <$> liftIO (checkContactHasGroups db user ct)) + (pure (Nothing, [])) + (getConnections ct) + where + getConnections :: Contact -> ExceptT StoreError IO (Maybe StoreError, [ConnId]) + getConnections ct = do + conns <- liftIO $ getContactConnections db vr userId ct + e_ <- (setContactDeleted db user ct $> Nothing) `catchStoreError` (pure . Just) + pure (e_, map aConnId conns) + CTLocal -> pure $ chatCmdError (Just user) "not supported" + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of + CTDirect -> do + ct <- withFastStore $ \db -> getContact db vr user chatId + filesInfo <- withFastStore' $ \db -> getContactFileInfo db user ct + cancelFilesInProgress user filesInfo + deleteFilesLocally filesInfo + withFastStore' $ \db -> deleteContactCIs db user ct + pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct) + CTGroup -> do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user chatId + filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo + cancelFilesInProgress user filesInfo + deleteFilesLocally filesInfo + withFastStore' $ \db -> deleteGroupChatItemsMessages db user gInfo + membersToDelete <- withFastStore' $ \db -> getGroupMembersForExpiration db vr user gInfo + forM_ membersToDelete $ \m -> withFastStore' $ \db -> deleteGroupMember db user m + pure $ CRChatCleared user (AChatInfo SCTGroup $ GroupChat gInfo) + CTLocal -> do + nf <- withFastStore $ \db -> getNoteFolder db user chatId + filesInfo <- withFastStore' $ \db -> getNoteFolderFileInfo db user nf + deleteFilesLocally filesInfo + withFastStore' $ \db -> deleteNoteFolderFiles db userId nf + withFastStore' $ \db -> deleteNoteFolderCIs db user nf + pure $ CRChatCleared user (AChatInfo SCTLocal $ LocalChat nf) + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + APIAcceptContact incognito connReqId -> withUser $ \_ -> do + userContactLinkId <- withFastStore $ \db -> getUserContactLinkIdByCReq db connReqId + withUserContactLock "acceptContact" userContactLinkId $ do + (user@User {userId}, cReq) <- withFastStore $ \db -> getContactRequest' db connReqId + (ct, conn@Connection {connId}, sqSecured) <- acceptContactRequest user cReq incognito + ucl <- withFastStore $ \db -> getUserContactLinkById db userId userContactLinkId + let contactUsed = (\(_, groupId_, _) -> isNothing groupId_) ucl + ct' <- withStore' $ \db -> do + deleteContactRequestRec db user cReq + updateContactAccepted db user ct contactUsed + conn' <- + if sqSecured + then conn {connStatus = ConnSndReady} <$ updateConnectionStatusFromTo db connId ConnNew ConnSndReady + else pure conn + pure ct {contactUsed, activeConn = Just conn'} + pure $ CRAcceptingContactRequest user ct' + APIRejectContact connReqId -> withUser $ \user -> do + userContactLinkId <- withFastStore $ \db -> getUserContactLinkIdByCReq db connReqId + withUserContactLock "rejectContact" userContactLinkId $ do + cReq@UserContactRequest {agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <- + withFastStore $ \db -> + getContactRequest db user connReqId + `storeFinally` liftIO (deleteContactRequest db user connReqId) + withAgent $ \a -> rejectContact a connId invId + pure $ CRContactRequestRejected user cReq + APISendCallInvitation contactId callType -> withUser $ \user -> do + -- party initiating call + ct <- withFastStore $ \db -> getContact db vr user contactId + assertDirectAllowed user MDSnd ct XCallInv_ + if featureAllowed SCFCalls forUser ct + then do + calls <- asks currentCalls + withContactLock "sendCallInvitation" contactId $ do + g <- asks random + callId <- atomically $ CallId <$> C.randomBytes 16 g + callUUID <- UUID.toText <$> liftIO V4.nextRandom + dhKeyPair <- atomically $ if encryptedCall callType then Just <$> C.generateKeyPair g else pure Nothing + let invitation = CallInvitation {callType, callDhPubKey = fst <$> dhKeyPair} + callState = CallInvitationSent {localCallType = callType, localDhPrivKey = snd <$> dhKeyPair} + (msg, _) <- sendDirectContactMessage user ct (XCallInv callId invitation) + ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndCall CISCallPending 0) + let call' = Call {contactId, callId, callUUID, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci} + call_ <- atomically $ TM.lookupInsert contactId call' calls + forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing + toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] + ok user + else pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFCalls)) + SendCallInvitation cName callType -> withUser $ \user -> do + contactId <- withFastStore $ \db -> getContactIdByName db user cName + processChatCommand $ APISendCallInvitation contactId callType + APIRejectCall contactId -> + -- party accepting call + withCurrentCall contactId $ \user ct Call {chatItemId, callState} -> case callState of + CallInvitationReceived {} -> do + let aciContent = ACIContent SMDRcv $ CIRcvCall CISCallRejected 0 + withFastStore' $ \db -> setDirectChatItemRead db user contactId chatItemId + timed_ <- contactCITimed ct + updateDirectChatItemView user ct chatItemId aciContent False False timed_ Nothing + forM_ (timed_ >>= timedDeleteAt') $ + startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId) + pure Nothing + _ -> throwChatError . CECallState $ callStateTag callState + APISendCallOffer contactId WebRTCCallOffer {callType, rtcSession} -> + -- party accepting call + withCurrentCall contactId $ \user ct call@Call {callId, chatItemId, callState} -> case callState of + CallInvitationReceived {peerCallType, localDhPubKey, sharedKey} -> do + let callDhPubKey = if encryptedCall callType then localDhPubKey else Nothing + offer = CallOffer {callType, rtcSession, callDhPubKey} + callState' = CallOfferSent {localCallType = callType, peerCallType, localCallSession = rtcSession, sharedKey} + aciContent = ACIContent SMDRcv $ CIRcvCall CISCallAccepted 0 + (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XCallOffer callId offer) + withFastStore' $ \db -> setDirectChatItemRead db user contactId chatItemId + updateDirectChatItemView user ct chatItemId aciContent False False Nothing $ Just msgId + pure $ Just call {callState = callState'} + _ -> throwChatError . CECallState $ callStateTag callState + APISendCallAnswer contactId rtcSession -> + -- party initiating call + withCurrentCall contactId $ \user ct call@Call {callId, chatItemId, callState} -> case callState of + CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey} -> do + let callState' = CallNegotiated {localCallType, peerCallType, localCallSession = rtcSession, peerCallSession, sharedKey} + aciContent = ACIContent SMDSnd $ CISndCall CISCallNegotiated 0 + (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XCallAnswer callId CallAnswer {rtcSession}) + updateDirectChatItemView user ct chatItemId aciContent False False Nothing $ Just msgId + pure $ Just call {callState = callState'} + _ -> throwChatError . CECallState $ callStateTag callState + APISendCallExtraInfo contactId rtcExtraInfo -> + -- any call party + withCurrentCall contactId $ \user ct call@Call {callId, callState} -> case callState of + CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey} -> do + -- TODO update the list of ice servers in localCallSession + void . sendDirectContactMessage user ct $ XCallExtra callId CallExtraInfo {rtcExtraInfo} + let callState' = CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey} + pure $ Just call {callState = callState'} + CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} -> do + -- TODO update the list of ice servers in localCallSession + void . sendDirectContactMessage user ct $ XCallExtra callId CallExtraInfo {rtcExtraInfo} + let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} + pure $ Just call {callState = callState'} + _ -> throwChatError . CECallState $ callStateTag callState + APIEndCall contactId -> + -- any call party + withCurrentCall contactId $ \user ct call@Call {callId} -> do + (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XCallEnd callId) + updateCallItemStatus user ct call WCSDisconnected $ Just msgId + pure Nothing + APIGetCallInvitations -> withUser' $ \_ -> lift $ do + calls <- asks currentCalls >>= readTVarIO + let invs = mapMaybe callInvitation $ M.elems calls + rcvCallInvitations <- rights <$> mapM rcvCallInvitation invs + pure $ CRCallInvitations rcvCallInvitations + where + callInvitation Call {contactId, callUUID, callState, callTs} = case callState of + CallInvitationReceived {peerCallType, sharedKey} -> Just (contactId, callUUID, callTs, peerCallType, sharedKey) + _ -> Nothing + rcvCallInvitation (contactId, callUUID, callTs, peerCallType, sharedKey) = runExceptT . withFastStore $ \db -> do + user <- getUserByContactId db contactId + contact <- getContact db vr user contactId + pure RcvCallInvitation {user, contact, callType = peerCallType, sharedKey, callUUID, callTs} + APIGetNetworkStatuses -> withUser $ \_ -> + CRNetworkStatuses Nothing . map (uncurry ConnNetworkStatus) . M.toList <$> chatReadVar connNetworkStatuses + APICallStatus contactId receivedStatus -> + withCurrentCall contactId $ \user ct call -> + updateCallItemStatus user ct call receivedStatus Nothing $> Just call + APIUpdateProfile userId profile -> withUserId userId (`updateProfile` profile) + APISetContactPrefs contactId prefs' -> withUser $ \user -> do + ct <- withFastStore $ \db -> getContact db vr user contactId + updateContactPrefs user ct prefs' + APISetContactAlias contactId localAlias -> withUser $ \user@User {userId} -> do + ct' <- withFastStore $ \db -> do + ct <- getContact db vr user contactId + liftIO $ updateContactAlias db userId ct localAlias + pure $ CRContactAliasUpdated user ct' + APISetConnectionAlias connId localAlias -> withUser $ \user@User {userId} -> do + conn' <- withFastStore $ \db -> do + conn <- getPendingContactConnection db userId connId + liftIO $ updateContactConnectionAlias db userId conn localAlias + pure $ CRConnectionAliasUpdated user conn' + APISetUserUIThemes uId uiThemes -> withUser $ \user@User {userId} -> do + user'@User {userId = uId'} <- withFastStore $ \db -> do + user' <- getUser db uId + liftIO $ setUserUIThemes db user uiThemes + pure user' + when (userId == uId') $ chatWriteVar currentUser $ Just (user :: User) {uiThemes} + ok user' + APISetChatUIThemes (ChatRef cType chatId) uiThemes -> withUser $ \user -> case cType of + CTDirect -> do + withFastStore $ \db -> do + ct <- getContact db vr user chatId + liftIO $ setContactUIThemes db user ct uiThemes + ok user + CTGroup -> do + withFastStore $ \db -> do + g <- getGroupInfo db vr user chatId + liftIO $ setGroupUIThemes db user g uiThemes + ok user + _ -> pure $ chatCmdError (Just user) "not supported" + APIParseMarkdown text -> pure . CRApiParsedMarkdown $ parseMaybeMarkdownList text + APIGetNtfToken -> withUser' $ \_ -> crNtfToken <$> withAgent getNtfToken + APIRegisterToken token mode -> withUser $ \_ -> + CRNtfTokenStatus <$> withAgent (\a -> registerNtfToken a token mode) + APIVerifyToken token nonce code -> withUser $ \_ -> withAgent (\a -> verifyNtfToken a token nonce code) >> ok_ + APIDeleteToken token -> withUser $ \_ -> withAgent (`deleteNtfToken` token) >> ok_ + APIGetNtfConns nonce encNtfInfo -> withUser $ \user -> do + ntfInfos <- withAgent $ \a -> getNotificationConns a nonce encNtfInfo + (errs, ntfMsgs) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (getMsgConn db) (L.toList ntfInfos)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRNtfConns ntfMsgs + where + getMsgConn :: DB.Connection -> NotificationInfo -> IO NtfConn + getMsgConn db NotificationInfo {ntfConnId, ntfMsgMeta = nMsgMeta} = do + let agentConnId = AgentConnId ntfConnId + user_ <- getUserByAConnId db agentConnId + connEntity_ <- + pure user_ $>>= \user -> + eitherToMaybe <$> runExceptT (getConnectionEntity db vr user agentConnId) + pure $ + NtfConn + { user_, + connEntity_, + -- Decrypted ntf meta of the expected message (the one notification was sent for) + expectedMsg_ = expectedMsgInfo <$> nMsgMeta + } + ApiGetConnNtfMessages connIds -> withUser $ \_ -> do + let acIds = L.map (\(AgentConnId acId) -> acId) connIds + msgs <- lift $ withAgent' $ \a -> getConnectionMessages a acIds + let ntfMsgs = L.map (\msg -> receivedMsgInfo <$> msg) msgs + pure $ CRConnNtfMessages ntfMsgs + GetUserProtoServers (AProtocolType p) -> withUser $ \user -> withServerProtocol p $ do + srvs <- withFastStore (`getUserServers` user) + liftIO $ CRUserServers user <$> groupByOperator (protocolServers p srvs) + SetUserProtoServers (AProtocolType (p :: SProtocolType p)) srvs -> withUser $ \user@User {userId} -> withServerProtocol p $ do + userServers_ <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user) + case L.nonEmpty userServers_ of + Nothing -> throwChatError $ CECommandError "no servers" + Just userServers -> case srvs of + [] -> throwChatError $ CECommandError "no servers" + _ -> do + srvs' <- mapM aUserServer srvs + processChatCommand $ APISetUserServers userId $ L.map (updatedServers p srvs') userServers + where + aUserServer :: AProtoServerWithAuth -> CM (AUserServer p) + aUserServer (AProtoServerWithAuth p' srv) = case testEquality p p' of + Just Refl -> pure $ AUS SDBNew $ newUserServer srv + Nothing -> throwChatError $ CECommandError $ "incorrect server protocol: " <> B.unpack (strEncode srv) + APITestProtoServer userId srv@(AProtoServerWithAuth _ server) -> withUserId userId $ \user -> + lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server) + TestProtoServer srv -> withUser $ \User {userId} -> + processChatCommand $ APITestProtoServer userId srv + APIGetServerOperators -> CRServerOperatorConditions <$> withFastStore getServerOperators + APISetServerOperators operators -> do + as <- asks randomAgentServers + (opsConds, srvs) <- withFastStore $ \db -> do + liftIO $ setServerOperators db operators + opsConds <- getServerOperators db + let ops = serverOperators opsConds + ops' = map Just ops <> [Nothing] + opDomains = operatorDomains ops + liftIO $ fmap (opsConds,) . mapM (getServers db as ops' opDomains) =<< getUsers db + lift $ withAgent' $ \a -> forM_ srvs $ \(auId, (smp', xftp')) -> do + setProtocolServers a auId smp' + setProtocolServers a auId xftp' + pure $ CRServerOperatorConditions opsConds + where + getServers :: DB.Connection -> RandomAgentServers -> [Maybe ServerOperator] -> [(Text, ServerOperator)] -> User -> IO (UserId, (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))) + getServers db as ops opDomains user = do + smpSrvs <- getProtocolServers db SPSMP user + xftpSrvs <- getProtocolServers db SPXFTP user + uss <- groupByOperator (ops, smpSrvs, xftpSrvs) + pure $ (aUserId user,) $ useServers as opDomains uss + SetServerOperators operatorsRoles -> do + ops <- serverOperators <$> withFastStore getServerOperators + ops' <- mapM (updateOp ops) operatorsRoles + processChatCommand $ APISetServerOperators ops' + where + updateOp :: [ServerOperator] -> ServerOperatorRoles -> CM ServerOperator + updateOp ops r = + case find (\ServerOperator {operatorId = DBEntityId opId} -> operatorId' r == opId) ops of + Just op -> pure op {enabled = enabled' r, smpRoles = smpRoles' r, xftpRoles = xftpRoles' r} + Nothing -> throwError $ ChatErrorStore $ SEOperatorNotFound $ operatorId' r + APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db -> do + CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user) + APISetUserServers userId userServers -> withUserId userId $ \user -> do + errors <- validateAllUsersServers userId $ L.toList userServers + unless (null errors) $ throwChatError (CECommandError $ "user servers validation error(s): " <> show errors) + uss <- withFastStore $ \db -> do + ts <- liftIO getCurrentTime + mapM (setUserServers db user ts) userServers + as <- asks randomAgentServers + lift $ withAgent' $ \a -> do + let auId = aUserId user + opDomains = operatorDomains $ mapMaybe operator' $ L.toList uss + (smp', xftp') = useServers as opDomains uss + setProtocolServers a auId smp' + setProtocolServers a auId xftp' + ok_ + APIValidateServers userId userServers -> withUserId userId $ \user -> + CRUserServersValidation user <$> validateAllUsersServers userId userServers + APIGetUsageConditions -> do + (usageConditions, acceptedConditions) <- withFastStore $ \db -> do + usageConditions <- getCurrentUsageConditions db + acceptedConditions <- liftIO $ getLatestAcceptedConditions db + pure (usageConditions, acceptedConditions) + -- TODO if db commit is different from source commit, conditionsText should be nothing in response + pure + CRUsageConditions + { usageConditions, + conditionsText = usageConditionsText, + acceptedConditions + } + APISetConditionsNotified condId -> do + currentTs <- liftIO getCurrentTime + withFastStore' $ \db -> setConditionsNotified db condId currentTs + ok_ + APIAcceptConditions condId opIds -> withFastStore $ \db -> do + currentTs <- liftIO getCurrentTime + acceptConditions db condId opIds currentTs + CRServerOperatorConditions <$> getServerOperators db + APISetChatItemTTL userId newTTL_ -> withUserId userId $ \user -> + checkStoreNotChanged $ + withChatLock "setChatItemTTL" $ do + case newTTL_ of + Nothing -> do + withFastStore' $ \db -> setChatItemTTL db user newTTL_ + lift $ setExpireCIFlag user False + Just newTTL -> do + oldTTL <- withFastStore' (`getChatItemTTL` user) + when (maybe True (newTTL <) oldTTL) $ do + lift $ setExpireCIFlag user False + expireChatItems user newTTL True + withFastStore' $ \db -> setChatItemTTL db user newTTL_ + lift $ startExpireCIThread user + lift . whenM chatStarted $ setExpireCIFlag user True + ok user + SetChatItemTTL newTTL_ -> withUser' $ \User {userId} -> do + processChatCommand $ APISetChatItemTTL userId newTTL_ + APIGetChatItemTTL userId -> withUserId' userId $ \user -> do + ttl <- withFastStore' (`getChatItemTTL` user) + pure $ CRChatItemTTL user ttl + GetChatItemTTL -> withUser' $ \User {userId} -> do + processChatCommand $ APIGetChatItemTTL userId + APISetNetworkConfig cfg -> withUser' $ \_ -> lift (withAgent' (`setNetworkConfig` cfg)) >> ok_ + APIGetNetworkConfig -> withUser' $ \_ -> + CRNetworkConfig <$> lift getNetworkConfig + SetNetworkConfig simpleNetCfg -> do + cfg <- (`updateNetworkConfig` simpleNetCfg) <$> lift getNetworkConfig + void . processChatCommand $ APISetNetworkConfig cfg + pure $ CRNetworkConfig cfg + APISetNetworkInfo info -> lift (withAgent' (`setUserNetworkInfo` info)) >> ok_ + ReconnectAllServers -> withUser' $ \_ -> lift (withAgent' reconnectAllServers) >> ok_ + ReconnectServer userId srv -> withUserId userId $ \user -> do + lift (withAgent' $ \a -> reconnectSMPServer a (aUserId user) srv) + ok_ + APISetChatSettings (ChatRef cType chatId) chatSettings -> withUser $ \user -> case cType of + CTDirect -> do + ct <- withFastStore $ \db -> do + ct <- getContact db vr user chatId + liftIO $ updateContactSettings db user chatId chatSettings + pure ct + forM_ (contactConnId ct) $ \connId -> + withAgent $ \a -> toggleConnectionNtfs a connId (chatHasNtfs chatSettings) + ok user + CTGroup -> do + ms <- withFastStore $ \db -> do + Group _ ms <- getGroup db vr user chatId + liftIO $ updateGroupSettings db user chatId chatSettings + pure ms + forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId -> + 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 <- withFastStore $ \db -> do + liftIO $ updateGroupMemberSettings db user gId gMemberId settings + getGroupMember db vr user gId gMemberId + let ntfOn = showMessages $ memberSettings m + toggleNtf user m ntfOn + ok user + APIContactInfo contactId -> withUser $ \user@User {userId} -> do + -- [incognito] print user's incognito profile for this contact + ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId + incognitoProfile <- case activeConn of + Nothing -> pure Nothing + Just Connection {customUserProfileId} -> + forM customUserProfileId $ \profileId -> withFastStore (\db -> getProfileById db userId profileId) + connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct) + pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile) + APIContactQueueInfo contactId -> withUser $ \user -> do + ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId + case activeConn of + Just conn -> getConnQueueInfo user conn + Nothing -> throwChatError $ CEContactNotActive ct + APIGroupInfo gId -> withUser $ \user -> do + (g, s) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> liftIO (getGroupSummary db user gId) + pure $ CRGroupInfo user g s + APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do + (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId + connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m) + pure $ CRGroupMemberInfo user g m connectionStats + APIGroupMemberQueueInfo gId gMemberId -> withUser $ \user -> do + GroupMember {activeConn} <- withFastStore $ \db -> getGroupMember db vr user gId gMemberId + case activeConn of + Just conn -> getConnQueueInfo user conn + Nothing -> throwChatError CEGroupMemberNotActive + APISwitchContact contactId -> withUser $ \user -> do + ct <- withFastStore $ \db -> getContact db vr user contactId + case contactConnId ct of + Just connId -> do + connectionStats <- withAgent $ \a -> switchConnectionAsync a "" connId + pure $ CRContactSwitchStarted user ct connectionStats + Nothing -> throwChatError $ CEContactNotActive ct + APISwitchGroupMember gId gMemberId -> withUser $ \user -> do + (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId + case memberConnId m of + Just connId -> do + connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId) + pure $ CRGroupMemberSwitchStarted user g m connectionStats + _ -> throwChatError CEGroupMemberNotActive + APIAbortSwitchContact contactId -> withUser $ \user -> do + ct <- withFastStore $ \db -> getContact db vr user contactId + case contactConnId ct of + Just connId -> do + connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId + pure $ CRContactSwitchAborted user ct connectionStats + Nothing -> throwChatError $ CEContactNotActive ct + APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do + (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId + case memberConnId m of + Just connId -> do + connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId + pure $ CRGroupMemberSwitchAborted user g m connectionStats + _ -> throwChatError CEGroupMemberNotActive + APISyncContactRatchet contactId force -> withUser $ \user -> withContactLock "syncContactRatchet" contactId $ do + ct <- withFastStore $ \db -> getContact db vr user contactId + case contactConn ct of + Just conn@Connection {pqSupport} -> do + cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a (aConnId conn) pqSupport force + createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCERatchetSync rss Nothing) Nothing + pure $ CRContactRatchetSyncStarted user ct cStats + Nothing -> throwChatError $ CEContactNotActive ct + APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> withGroupLock "syncGroupMemberRatchet" gId $ do + (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId + case memberConnId m of + Just connId -> do + cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId PQSupportOff force + createInternalChatItem user (CDGroupSnd g) (CISndConnEvent . SCERatchetSync rss . Just $ groupMemberRef m) Nothing + pure $ CRGroupMemberRatchetSyncStarted user g m cStats + _ -> throwChatError CEGroupMemberNotActive + APIGetContactCode contactId -> withUser $ \user -> do + ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId + case activeConn of + Just conn@Connection {connId} -> do + code <- getConnectionCode $ aConnId conn + ct' <- case contactSecurityCode ct of + Just SecurityCode {securityCode} + | sameVerificationCode code securityCode -> pure ct + | otherwise -> do + withFastStore' $ \db -> setConnectionVerified db user connId Nothing + pure (ct :: Contact) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} + _ -> pure ct + pure $ CRContactCode user ct' code + Nothing -> throwChatError $ CEContactNotActive ct + APIGetGroupMemberCode gId gMemberId -> withUser $ \user -> do + (g, m@GroupMember {activeConn}) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId + case activeConn of + Just conn@Connection {connId} -> do + code <- getConnectionCode $ aConnId conn + m' <- case memberSecurityCode m of + Just SecurityCode {securityCode} + | sameVerificationCode code securityCode -> pure m + | otherwise -> do + withFastStore' $ \db -> setConnectionVerified db user connId Nothing + pure (m :: GroupMember) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} + _ -> pure m + pure $ CRGroupMemberCode user g m' code + _ -> throwChatError CEGroupMemberNotActive + APIVerifyContact contactId code -> withUser $ \user -> do + ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId + case activeConn of + Just conn -> verifyConnectionCode user conn code + Nothing -> throwChatError $ CEContactNotActive ct + APIVerifyGroupMember gId gMemberId code -> withUser $ \user -> do + GroupMember {activeConn} <- withFastStore $ \db -> getGroupMember db vr user gId gMemberId + case activeConn of + Just conn -> verifyConnectionCode user conn code + _ -> throwChatError CEGroupMemberNotActive + APIEnableContact contactId -> withUser $ \user -> do + ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId + case activeConn of + Just conn -> do + withFastStore' $ \db -> setAuthErrCounter db user conn 0 + ok user + Nothing -> throwChatError $ CEContactNotActive ct + APIEnableGroupMember gId gMemberId -> withUser $ \user -> do + GroupMember {activeConn} <- withFastStore $ \db -> getGroupMember db vr user gId gMemberId + case activeConn of + Just conn -> do + withFastStore' $ \db -> setAuthErrCounter db user conn 0 + ok user + _ -> 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 + gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId + m <- withFastStore $ \db -> getGroupMember db vr user gId mId + let GroupInfo {membership = GroupMember {memberRole = membershipRole}} = gInfo + when (membershipRole >= GRAdmin) $ throwChatError $ CECantBlockMemberForSelf gInfo m showMessages + let settings = (memberSettings m) {showMessages} + processChatCommand $ APISetMemberSettings gId mId settings + ContactInfo cName -> withContactName cName APIContactInfo + ShowGroupInfo gName -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIGroupInfo groupId + GroupMemberInfo gName mName -> withMemberName gName mName APIGroupMemberInfo + ContactQueueInfo cName -> withContactName cName APIContactQueueInfo + GroupMemberQueueInfo gName mName -> withMemberName gName mName APIGroupMemberQueueInfo + SwitchContact cName -> withContactName cName APISwitchContact + SwitchGroupMember gName mName -> withMemberName gName mName APISwitchGroupMember + AbortSwitchContact cName -> withContactName cName APIAbortSwitchContact + AbortSwitchGroupMember gName mName -> withMemberName gName mName APIAbortSwitchGroupMember + SyncContactRatchet cName force -> withContactName cName $ \ctId -> APISyncContactRatchet ctId force + SyncGroupMemberRatchet gName mName force -> withMemberName gName mName $ \gId mId -> APISyncGroupMemberRatchet gId mId force + GetContactCode cName -> withContactName cName APIGetContactCode + GetGroupMemberCode gName mName -> withMemberName gName mName APIGetGroupMemberCode + VerifyContact cName code -> withContactName cName (`APIVerifyContact` code) + VerifyGroupMember gName mName code -> withMemberName gName mName $ \gId mId -> APIVerifyGroupMember gId mId code + EnableContact cName -> withContactName cName APIEnableContact + EnableGroupMember gName mName -> withMemberName gName mName $ \gId mId -> APIEnableGroupMember gId mId + ChatHelp section -> pure $ CRChatHelp section + Welcome -> withUser $ pure . CRWelcome + APIAddContact userId incognito -> withUserId userId $ \user -> procCmd $ do + -- [incognito] generate profile for connection + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + subMode <- chatReadVar subscriptionMode + (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing IKPQOn subMode + -- TODO PQ pass minVersion from the current range + conn <- withFastStore' $ \db -> createDirectConnection db user connId cReq ConnNew incognitoProfile subMode initialChatVersion PQSupportOn + pure $ CRInvitation user cReq conn + AddContact incognito -> withUser $ \User {userId} -> + processChatCommand $ APIAddContact userId incognito + APISetConnectionIncognito connId incognito -> withUser $ \user@User {userId} -> do + conn'_ <- withFastStore $ \db -> do + conn@PendingContactConnection {pccConnStatus, customUserProfileId} <- getPendingContactConnection db userId connId + case (pccConnStatus, customUserProfileId, incognito) of + (ConnNew, Nothing, True) -> liftIO $ do + incognitoProfile <- generateRandomProfile + pId <- createIncognitoProfile db user incognitoProfile + Just <$> updatePCCIncognito db user conn (Just pId) + (ConnNew, Just pId, False) -> liftIO $ do + deletePCCIncognitoProfile db user pId + Just <$> updatePCCIncognito db user conn Nothing + _ -> pure Nothing + case conn'_ of + Just conn' -> pure $ CRConnectionIncognitoUpdated user conn' + Nothing -> throwChatError CEConnectionIncognitoChangeProhibited + APIChangeConnectionUser connId newUserId -> withUser $ \user@User {userId} -> do + conn <- withFastStore $ \db -> getPendingContactConnection db userId connId + let PendingContactConnection {pccConnStatus, connReqInv} = conn + case (pccConnStatus, connReqInv) of + (ConnNew, Just cReqInv) -> do + newUser <- privateGetUser newUserId + conn' <- ifM (canKeepLink cReqInv newUser) (updateConnRecord user conn newUser) (recreateConn user conn newUser) + pure $ CRConnectionUserChanged user conn conn' newUser + _ -> throwChatError CEConnectionUserChangeProhibited + where + canKeepLink :: ConnReqInvitation -> User -> CM Bool + canKeepLink (CRInvitationUri crData _) newUser = do + let ConnReqUriData {crSmpQueues = q :| _} = crData + SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q + newUserServers <- + map protoServer' . L.filter (\ServerCfg {enabled} -> enabled) + <$> getKnownAgentServers SPSMP newUser + pure $ smpServer `elem` newUserServers + updateConnRecord user@User {userId} conn@PendingContactConnection {customUserProfileId} newUser = do + withAgent $ \a -> changeConnectionUser a (aUserId user) (aConnId' conn) (aUserId newUser) + withFastStore' $ \db -> do + conn' <- updatePCCUser db userId conn newUserId + forM_ customUserProfileId $ \profileId -> + deletePCCIncognitoProfile db user profileId + pure conn' + recreateConn user conn@PendingContactConnection {customUserProfileId} newUser = do + subMode <- chatReadVar subscriptionMode + (agConnId, cReq) <- withAgent $ \a -> createConnection a (aUserId newUser) True SCMInvitation Nothing IKPQOn subMode + conn' <- withFastStore' $ \db -> do + deleteConnectionRecord db user connId + forM_ customUserProfileId $ \profileId -> + deletePCCIncognitoProfile db user profileId + createDirectConnection db newUser agConnId cReq ConnNew Nothing subMode initialChatVersion PQSupportOn + deleteAgentConnectionAsync user (aConnId' conn) + pure conn' + APIConnectPlan userId cReqUri -> withUserId userId $ \user -> + CRConnectionPlan user <$> connectPlan user cReqUri + APIConnect userId incognito (Just (ACR SCMInvitation cReq@(CRInvitationUri crData e2e))) -> withUserId userId $ \user -> withInvitationLock "connect" (strEncode cReq) . procCmd $ do + subMode <- chatReadVar subscriptionMode + -- [incognito] generate profile to send + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + let profileToSend = userProfileToSend user incognitoProfile Nothing False + lift (withAgent' $ \a -> connRequestPQSupport a PQSupportOn cReq) >>= \case + Nothing -> throwChatError CEInvalidConnReq + -- TODO PQ the error above should be CEIncompatibleConnReqVersion, also the same API should be called in Plan + Just (agentV, pqSup') -> do + let chatV = agentToChatVersion agentV + dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend + withFastStore' (\db -> getConnectionEntityByConnReq db vr user cReqs) >>= \case + Nothing -> joinNewConn chatV dm + Just (RcvDirectMsgConnection conn@Connection {connId, connStatus, contactConnInitiated} Nothing) + | connStatus == ConnNew && contactConnInitiated -> joinNewConn chatV dm -- own connection link + | connStatus == ConnPrepared -> do + -- retrying join after error + pcc <- withFastStore $ \db -> getPendingContactConnection db userId connId + joinPreparedConn (aConnId conn) pcc dm + Just ent -> throwChatError $ CECommandError $ "connection exists: " <> show (connEntityInfo ent) + where + joinNewConn chatV dm = do + connId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup' + pcc <- withFastStore' $ \db -> createDirectConnection db user connId cReq ConnPrepared (incognitoProfile $> profileToSend) subMode chatV pqSup' + joinPreparedConn connId pcc dm + joinPreparedConn connId pcc@PendingContactConnection {pccConnId} dm = do + void $ withAgent $ \a -> joinConnection a (aUserId user) connId True cReq dm pqSup' subMode + withFastStore' $ \db -> updateConnectionStatusFromTo db pccConnId ConnPrepared ConnJoined + pure $ CRSentConfirmation user pcc {pccConnStatus = ConnJoined} + cReqs = + ( CRInvitationUri crData {crScheme = SSSimplex} e2e, + CRInvitationUri crData {crScheme = simplexChat} e2e + ) + APIConnect userId incognito (Just (ACR SCMContact cReq)) -> withUserId userId $ \user -> connectViaContact user incognito cReq + APIConnect _ _ Nothing -> throwChatError CEInvalidConnReq + Connect incognito aCReqUri@(Just cReqUri) -> withUser $ \user@User {userId} -> do + plan <- connectPlan user cReqUri `catchChatError` const (pure $ CPInvitationLink ILPOk) + unless (connectionPlanProceed plan) $ throwChatError (CEConnectionPlan plan) + case plan of + CPContactAddress (CAPContactViaAddress Contact {contactId}) -> + processChatCommand $ APIConnectContactViaAddress userId incognito contactId + _ -> processChatCommand $ APIConnect userId incognito aCReqUri + Connect _ Nothing -> throwChatError CEInvalidConnReq + APIConnectContactViaAddress userId incognito contactId -> withUserId userId $ \user -> do + ct@Contact {activeConn, profile = LocalProfile {contactLink}} <- withFastStore $ \db -> getContact db vr user contactId + when (isJust activeConn) $ throwChatError (CECommandError "contact already has connection") + case contactLink of + Just cReq -> connectContactViaAddress user incognito ct cReq + Nothing -> throwChatError (CECommandError "no address in contact profile") + ConnectSimplex incognito -> withUser $ \user@User {userId} -> do + let cReqUri = ACR SCMContact adminContactReq + plan <- connectPlan user cReqUri `catchChatError` const (pure $ CPInvitationLink ILPOk) + unless (connectionPlanProceed plan) $ throwChatError (CEConnectionPlan plan) + case plan of + CPContactAddress (CAPContactViaAddress Contact {contactId}) -> + processChatCommand $ APIConnectContactViaAddress userId incognito contactId + _ -> processChatCommand $ APIConnect userId incognito (Just cReqUri) + DeleteContact cName cdm -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId) cdm + ClearContact cName -> withContactName cName $ APIClearChat . ChatRef CTDirect + APIListContacts userId -> withUserId userId $ \user -> + CRContactsList user <$> withFastStore' (\db -> getUserContacts db vr user) + ListContacts -> withUser $ \User {userId} -> + processChatCommand $ APIListContacts userId + APICreateMyAddress userId -> withUserId userId $ \user -> procCmd $ do + subMode <- chatReadVar subscriptionMode + (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact Nothing IKPQOn subMode + withFastStore $ \db -> createUserContactLink db user connId cReq subMode + pure $ CRUserContactLinkCreated user cReq + CreateMyAddress -> withUser $ \User {userId} -> + processChatCommand $ APICreateMyAddress userId + APIDeleteMyAddress userId -> withUserId userId $ \user@User {profile = p} -> do + conns <- withFastStore $ \db -> getUserAddressConnections db vr user + withChatLock "deleteMyAddress" $ do + deleteAgentConnectionsAsync user $ map aConnId conns + withFastStore' (`deleteUserAddress` user) + let p' = (fromLocalProfile p :: Profile) {contactLink = Nothing} + r <- updateProfile_ user p' $ withFastStore' $ \db -> setUserProfileContactLink db user Nothing + let user' = case r of + CRUserProfileUpdated u' _ _ _ -> u' + _ -> user + pure $ CRUserContactLinkDeleted user' + DeleteMyAddress -> withUser $ \User {userId} -> + processChatCommand $ APIDeleteMyAddress userId + APIShowMyAddress userId -> withUserId' userId $ \user -> + CRUserContactLink user <$> withFastStore (`getUserAddress` user) + ShowMyAddress -> withUser' $ \User {userId} -> + processChatCommand $ APIShowMyAddress userId + APISetProfileAddress userId False -> withUserId userId $ \user@User {profile = p} -> do + let p' = (fromLocalProfile p :: Profile) {contactLink = Nothing} + updateProfile_ user p' $ withFastStore' $ \db -> setUserProfileContactLink db user Nothing + APISetProfileAddress userId True -> withUserId userId $ \user@User {profile = p} -> do + ucl@UserContactLink {connReqContact} <- withFastStore (`getUserAddress` user) + let p' = (fromLocalProfile p :: Profile) {contactLink = Just connReqContact} + updateProfile_ user p' $ withFastStore' $ \db -> setUserProfileContactLink db user $ Just ucl + SetProfileAddress onOff -> withUser $ \User {userId} -> + processChatCommand $ APISetProfileAddress userId onOff + APIAddressAutoAccept userId autoAccept_ -> withUserId userId $ \user -> do + forM_ autoAccept_ $ \AutoAccept {businessAddress, acceptIncognito} -> + when (businessAddress && acceptIncognito) $ throwChatError $ CECommandError "requests to business address cannot be accepted incognito" + contactLink <- withFastStore (\db -> updateUserAddressAutoAccept db user autoAccept_) + pure $ CRUserContactLinkUpdated user contactLink + AddressAutoAccept autoAccept_ -> withUser $ \User {userId} -> + processChatCommand $ APIAddressAutoAccept userId autoAccept_ + AcceptContact incognito cName -> withUser $ \User {userId} -> do + connReqId <- withFastStore $ \db -> getContactRequestIdByName db userId cName + processChatCommand $ APIAcceptContact incognito connReqId + RejectContact cName -> withUser $ \User {userId} -> do + connReqId <- withFastStore $ \db -> getContactRequestIdByName db userId cName + processChatCommand $ APIRejectContact connReqId + ForwardMessage toChatName fromContactName forwardedMsg -> withUser $ \user -> do + contactId <- withFastStore $ \db -> getContactIdByName db user fromContactName + forwardedItemId <- withFastStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg + toChatRef <- getChatRef user toChatName + processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId) (forwardedItemId :| []) Nothing + ForwardGroupMessage toChatName fromGroupName fromMemberName_ forwardedMsg -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user fromGroupName + forwardedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId fromMemberName_ forwardedMsg + toChatRef <- getChatRef user toChatName + processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId) (forwardedItemId :| []) Nothing + ForwardLocalMessage toChatName forwardedMsg -> withUser $ \user -> do + folderId <- withFastStore (`getUserNoteFolderId` user) + forwardedItemId <- withFastStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg + toChatRef <- getChatRef user toChatName + processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId) (forwardedItemId :| []) Nothing + SendMessage (ChatName cType name) msg -> withUser $ \user -> do + let mc = MCText msg + case cType of + CTDirect -> + withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case + Right ctId -> do + let chatRef = ChatRef CTDirect ctId + processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) + Left _ -> + withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case + Right [(gInfo, member)] -> do + let GroupInfo {localDisplayName = gName} = gInfo + GroupMember {localDisplayName = mName} = member + processChatCommand $ SendMemberContactMessage gName mName msg + Right (suspectedMember : _) -> + throwChatError $ CEContactNotFound name (Just suspectedMember) + _ -> + throwChatError $ CEContactNotFound name Nothing + CTGroup -> do + gId <- withFastStore $ \db -> getGroupIdByName db user name + let chatRef = ChatRef CTGroup gId + processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) + CTLocal + | name == "" -> do + folderId <- withFastStore (`getUserNoteFolderId` user) + processChatCommand $ APICreateChatItems folderId (ComposedMessage Nothing Nothing mc :| []) + | otherwise -> throwChatError $ CECommandError "not supported" + _ -> throwChatError $ CECommandError "not supported" + SendMemberContactMessage gName mName msg -> withUser $ \user -> do + (gId, mId) <- getGroupAndMemberId user gName mName + m <- withFastStore $ \db -> getGroupMember db vr user gId mId + let mc = MCText msg + case memberContactId m of + Nothing -> do + g <- withFastStore $ \db -> getGroupInfo db vr user gId + unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed" + toView $ CRNoMemberContactCreating user g m + processChatCommand (APICreateMemberContact gId mId) >>= \case + cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do + toView cr + processChatCommand $ APISendMemberContactInvitation contactId (Just mc) + cr -> pure cr + Just ctId -> do + let chatRef = ChatRef CTDirect ctId + processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) + SendLiveMessage chatName msg -> withUser $ \user -> do + chatRef <- getChatRef user chatName + let mc = MCText msg + processChatCommand $ APISendMessages chatRef True Nothing (ComposedMessage Nothing Nothing mc :| []) + SendMessageBroadcast msg -> withUser $ \user -> do + contacts <- withFastStore' $ \db -> getUserContacts db vr user + withChatLock "sendMessageBroadcast" . procCmd $ do + let ctConns_ = L.nonEmpty $ foldr addContactConn [] contacts + case ctConns_ of + Nothing -> do + timestamp <- liftIO getCurrentTime + pure CRBroadcastSent {user, msgContent = mc, successes = 0, failures = 0, timestamp} + Just (ctConns :: NonEmpty (Contact, Connection)) -> do + let idsEvts = L.map ctSndEvent ctConns + sndMsgs <- lift $ createSndMessages idsEvts + let msgReqs_ :: NonEmpty (Either ChatError ChatMsgReq) = L.zipWith (fmap . ctMsgReq) ctConns sndMsgs + (errs, ctSndMsgs :: [(Contact, SndMessage)]) <- + partitionEithers . L.toList . zipWith3' combineResults ctConns sndMsgs <$> deliverMessagesB msgReqs_ + timestamp <- liftIO getCurrentTime + lift . void $ withStoreBatch' $ \db -> map (createCI db user timestamp) ctSndMsgs + pure CRBroadcastSent {user, msgContent = mc, successes = length ctSndMsgs, failures = length errs, timestamp} + where + mc = MCText msg + addContactConn :: Contact -> [(Contact, Connection)] -> [(Contact, Connection)] + addContactConn ct ctConns = case contactSendConn_ ct of + Right conn | directOrUsed ct -> (ct, conn) : ctConns + _ -> ctConns + ctSndEvent :: (Contact, Connection) -> (ConnOrGroupId, ChatMsgEvent 'Json) + ctSndEvent (_, Connection {connId}) = (ConnectionId connId, XMsgNew $ MCSimple (extMsgContent mc Nothing)) + ctMsgReq :: (Contact, Connection) -> SndMessage -> ChatMsgReq + ctMsgReq (_, conn) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgNew_}, msgBody, [msgId]) + zipWith3' :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d + zipWith3' f ~(x :| xs) ~(y :| ys) ~(z :| zs) = f x y z :| zipWith3 f xs ys zs + combineResults :: (Contact, Connection) -> Either ChatError SndMessage -> Either ChatError ([Int64], PQEncryption) -> Either ChatError (Contact, SndMessage) + combineResults (ct, _) (Right msg') (Right _) = Right (ct, msg') + combineResults _ (Left e) _ = Left e + combineResults _ _ (Left e) = Left e + createCI :: DB.Connection -> User -> UTCTime -> (Contact, SndMessage) -> IO () + createCI db user createdAt (ct, sndMsg) = + void $ createNewSndChatItem db user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False createdAt + SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do + contactId <- withFastStore $ \db -> getContactIdByName db user cName + quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg + let mc = MCText msg + processChatCommand $ APISendMessages (ChatRef CTDirect contactId) False Nothing (ComposedMessage Nothing (Just quotedItemId) mc :| []) + DeleteMessage chatName deletedMsg -> withUser $ \user -> do + chatRef <- getChatRef user chatName + deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg + processChatCommand $ APIDeleteChatItem chatRef (deletedItemId :| []) CIDMBroadcast + DeleteMemberMessage gName mName deletedMsg -> withUser $ \user -> do + gId <- withFastStore $ \db -> getGroupIdByName db user gName + deletedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) deletedMsg + processChatCommand $ APIDeleteMemberChatItem gId (deletedItemId :| []) + EditMessage chatName editedMsg msg -> withUser $ \user -> do + chatRef <- getChatRef user chatName + editedItemId <- getSentChatItemIdByText user chatRef editedMsg + let mc = MCText msg + processChatCommand $ APIUpdateChatItem chatRef editedItemId False mc + UpdateLiveMessage chatName chatItemId live msg -> withUser $ \user -> do + chatRef <- getChatRef user chatName + let mc = MCText msg + processChatCommand $ APIUpdateChatItem chatRef chatItemId live mc + ReactToMessage add reaction chatName msg -> withUser $ \user -> do + chatRef <- getChatRef user chatName + chatItemId <- getChatItemIdByText user chatRef msg + processChatCommand $ APIChatItemReaction chatRef chatItemId add reaction + APINewGroup userId incognito gProfile@GroupProfile {displayName} -> withUserId userId $ \user -> do + checkValidName displayName + gVar <- asks random + -- [incognito] generate incognito profile for group membership + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + gInfo <- withFastStore $ \db -> createNewGroup db vr gVar user gProfile incognitoProfile + let cd = CDGroupSnd gInfo + createInternalChatItem user cd (CISndGroupE2EEInfo E2EInfo {pqEnabled = PQEncOff}) Nothing + createGroupFeatureItems user cd CISndGroupFeature gInfo + pure $ CRGroupCreated user gInfo + NewGroup incognito gProfile -> withUser $ \User {userId} -> + processChatCommand $ APINewGroup userId incognito gProfile + APIAddMember groupId contactId memRole -> withUser $ \user -> withGroupLock "addMember" groupId $ do + -- TODO for large groups: no need to load all members to determine if contact is a member + (group, contact) <- withFastStore $ \db -> (,) <$> getGroup db vr user groupId <*> getContact db vr user contactId + assertDirectAllowed user MDSnd contact XGrpInv_ + let Group gInfo members = group + Contact {localDisplayName = cName} = contact + assertUserGroupRole gInfo $ max GRAdmin memRole + -- [incognito] forbid to invite contact to whom user is connected incognito + when (contactConnIncognito contact) $ throwChatError CEContactIncognitoCantInvite + -- [incognito] forbid to invite contacts if user joined the group using an incognito profile + when (incognitoMembership gInfo) $ throwChatError CEGroupIncognitoCantInvite + let sendInvitation = sendGrpInvitation user contact gInfo + case contactMember contact members of + Nothing -> do + gVar <- asks random + subMode <- chatReadVar subscriptionMode + (agentConnId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing IKPQOff subMode + member <- withFastStore $ \db -> createNewContactMember db gVar user gInfo contact memRole agentConnId cReq subMode + sendInvitation member cReq + pure $ CRSentGroupInvitation user gInfo contact member + Just member@GroupMember {groupMemberId, memberStatus, memberRole = mRole} + | memberStatus == GSMemInvited -> do + unless (mRole == memRole) $ withFastStore' $ \db -> updateGroupMemberRole db user member memRole + withFastStore' (\db -> getMemberInvitation db user groupMemberId) >>= \case + Just cReq -> do + sendInvitation member {memberRole = memRole} cReq + pure $ CRSentGroupInvitation user gInfo contact member {memberRole = memRole} + Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName + | otherwise -> throwChatError $ CEGroupDuplicateMember cName + APIJoinGroup groupId -> withUser $ \user@User {userId} -> do + withGroupLock "joinGroup" groupId . procCmd $ do + (invitation, ct) <- withFastStore $ \db -> do + inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId + (inv,) <$> getContactViaMember db vr user fromMember + let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation + GroupMember {memberId = membershipMemId} = membership + Contact {activeConn} = ct + case activeConn of + Just Connection {peerChatVRange} -> do + subMode <- chatReadVar subscriptionMode + dm <- encodeConnInfo $ XGrpAcpt membershipMemId + agentConnId <- case memberConn fromMember of + Nothing -> do + agentConnId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connRequest PQSupportOff + let chatV = vr `peerConnChatVersion` peerChatVRange + void $ withFastStore' $ \db -> createMemberConnection db userId fromMember agentConnId chatV peerChatVRange subMode + pure agentConnId + Just conn -> pure $ aConnId conn + withFastStore' $ \db -> do + updateGroupMemberStatus db userId fromMember GSMemAccepted + updateGroupMemberStatus db userId membership GSMemAccepted + void (withAgent $ \a -> joinConnection a (aUserId user) agentConnId True connRequest dm PQSupportOff subMode) + `catchChatError` \e -> do + withFastStore' $ \db -> do + updateGroupMemberStatus db userId fromMember GSMemInvited + updateGroupMemberStatus db userId membership GSMemInvited + throwError e + updateCIGroupInvitationStatus user g CIGISAccepted `catchChatError` (toView . CRChatError (Just user)) + pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing + Nothing -> throwChatError $ CEContactNotActive ct + APIMemberRole groupId memberId memRole -> withUser $ \user -> do + Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId + if memberId == groupMemberId' membership + then changeMemberRole user gInfo members membership $ SGEUserRole memRole + else case find ((== memberId) . groupMemberId') members of + Just m -> changeMemberRole user gInfo members m $ SGEMemberRole memberId (fromLocalProfile $ memberProfile m) memRole + _ -> throwChatError CEGroupMemberNotFound + where + changeMemberRole user gInfo members m gEvent = do + let GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberContactId, localDisplayName = cName} = m + assertUserGroupRole gInfo $ maximum ([GRAdmin, mRole, memRole] :: [GroupMemberRole]) + withGroupLock "memberRole" groupId . procCmd $ do + unless (mRole == memRole) $ do + withFastStore' $ \db -> updateGroupMemberRole db user m memRole + case mStatus of + GSMemInvited -> do + withFastStore (\db -> (,) <$> mapM (getContact db vr user) memberContactId <*> liftIO (getMemberInvitation db user $ groupMemberId' m)) >>= \case + (Just ct, Just cReq) -> sendGrpInvitation user ct gInfo (m :: GroupMember) {memberRole = memRole} cReq + _ -> throwChatError $ CEGroupCantResendInvitation gInfo cName + _ -> do + msg <- sendGroupMessage user gInfo members $ XGrpMemRole mId memRole + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent gEvent) + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] + pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole} + APIBlockMemberForAll groupId memberId blocked -> withUser $ \user -> do + Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId + when (memberId == groupMemberId' membership) $ throwChatError $ CECommandError "can't block/unblock self" + case splitMember memberId members of + Nothing -> throwChatError $ CEException "expected to find a single blocked member" + Just (bm, remainingMembers) -> do + let GroupMember {memberId = bmMemberId, memberRole = bmRole, memberProfile = bmp} = bm + assertUserGroupRole gInfo $ max GRAdmin bmRole + when (blocked == blockedByAdmin bm) $ throwChatError $ CECommandError $ if blocked then "already blocked" else "already unblocked" + withGroupLock "blockForAll" groupId . procCmd $ do + let mrs = if blocked then MRSBlocked else MRSUnrestricted + event = XGrpMemRestrict bmMemberId MemberRestrictions {restriction = mrs} + msg <- sendGroupMessage' user gInfo remainingMembers event + let ciContent = CISndGroupEvent $ SGEMemberBlocked memberId (fromLocalProfile bmp) blocked + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg ciContent + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] + bm' <- withFastStore $ \db -> do + liftIO $ updateGroupMemberBlocked db user groupId memberId mrs + getGroupMember db vr user groupId memberId + toggleNtf user bm' (not blocked) + pure CRMemberBlockedForAllUser {user, groupInfo = gInfo, member = bm', blocked} + where + splitMember mId ms = case break ((== mId) . groupMemberId') ms of + (_, []) -> Nothing + (ms1, bm : ms2) -> Just (bm, ms1 <> ms2) + APIRemoveMember groupId memberId -> withUser $ \user -> do + Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId + case find ((== memberId) . groupMemberId') members of + Nothing -> throwChatError CEGroupMemberNotFound + Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do + assertUserGroupRole gInfo $ max GRAdmin mRole + withGroupLock "removeMember" groupId . procCmd $ do + case mStatus of + GSMemInvited -> do + deleteMemberConnection user m + withFastStore' $ \db -> deleteGroupMember db user m + _ -> do + msg <- sendGroupMessage user gInfo members $ XGrpMemDel mId + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile)) + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] + deleteMemberConnection' user m True + -- undeleted "member connected" chat item will prevent deletion of member record + deleteOrUpdateMemberRecord user m + pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved} + APILeaveGroup groupId -> withUser $ \user@User {userId} -> do + Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId + filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo + withGroupLock "leaveGroup" groupId . procCmd $ do + cancelFilesInProgress user filesInfo + msg <- sendGroupMessage' user gInfo members XGrpLeave + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] + -- TODO delete direct connections that were unused + deleteGroupLinkIfExists user gInfo + -- member records are not deleted to keep history + deleteMembersConnections' user members True + withFastStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft + pure $ CRLeftMemberUser user gInfo {membership = membership {memberStatus = GSMemLeft}} + APIListMembers groupId -> withUser $ \user -> + CRGroupMembers user <$> withFastStore (\db -> getGroup db vr user groupId) + AddMember gName cName memRole -> withUser $ \user -> do + (groupId, contactId) <- withFastStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName + processChatCommand $ APIAddMember groupId contactId memRole + JoinGroup gName -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIJoinGroup groupId + MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMemberRole gId gMemberId memRole + BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMemberForAll gId gMemberId blocked + RemoveMember gName gMemberName -> withMemberName gName gMemberName APIRemoveMember + LeaveGroup gName -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APILeaveGroup groupId + DeleteGroup gName -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIDeleteChat (ChatRef CTGroup groupId) (CDMFull True) + ClearGroup gName -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIClearChat (ChatRef CTGroup groupId) + ListMembers gName -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIListMembers groupId + APIListGroups userId contactId_ search_ -> withUserId userId $ \user -> + CRGroupsList user <$> withFastStore' (\db -> getUserGroupsWithSummary db vr user contactId_ search_) + ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do + ct_ <- forM cName_ $ \cName -> withFastStore $ \db -> getContactByName db vr user cName + processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_ + APIUpdateGroupProfile groupId p' -> withUser $ \user -> do + g <- withFastStore $ \db -> getGroup db vr user groupId + runUpdateGroupProfile user g p' + UpdateGroupNames gName GroupProfile {displayName, fullName} -> + updateGroupProfileByName gName $ \p -> p {displayName, fullName} + ShowGroupProfile gName -> withUser $ \user -> + CRGroupProfile user <$> withFastStore (\db -> getGroupInfoByName db vr user gName) + UpdateGroupDescription gName description -> + updateGroupProfileByName gName $ \p -> p {description} + ShowGroupDescription gName -> withUser $ \user -> + CRGroupDescription user <$> withFastStore (\db -> getGroupInfoByName db vr user gName) + APICreateGroupLink groupId mRole -> withUser $ \user -> withGroupLock "createGroupLink" groupId $ do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId + assertUserGroupRole gInfo GRAdmin + when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole + groupLinkId <- GroupLinkId <$> drgRandomBytes 16 + subMode <- chatReadVar subscriptionMode + let crClientData = encodeJSON $ CRDataGroup groupLinkId + (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact (Just crClientData) IKPQOff subMode + withFastStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode + pure $ CRGroupLinkCreated user gInfo cReq mRole + APIGroupLinkMemberRole groupId mRole' -> withUser $ \user -> withGroupLock "groupLinkMemberRole" groupId $ do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId + (groupLinkId, groupLink, mRole) <- withFastStore $ \db -> getGroupLink db user gInfo + assertUserGroupRole gInfo GRAdmin + when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole' + when (mRole' /= mRole) $ withFastStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole' + pure $ CRGroupLink user gInfo groupLink mRole' + APIDeleteGroupLink groupId -> withUser $ \user -> withGroupLock "deleteGroupLink" groupId $ do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId + deleteGroupLink' user gInfo + pure $ CRGroupLinkDeleted user gInfo + APIGetGroupLink groupId -> withUser $ \user -> do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId + (_, groupLink, mRole) <- withFastStore $ \db -> getGroupLink db user gInfo + pure $ CRGroupLink user gInfo groupLink mRole + APICreateMemberContact gId gMemberId -> withUser $ \user -> do + (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId + assertUserGroupRole g GRAuthor + unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed" + case memberConn m of + Just mConn@Connection {peerChatVRange} -> do + unless (maxVersion peerChatVRange >= groupDirectInvVersion) $ throwChatError CEPeerChatVRangeIncompatible + when (isJust $ memberContactId m) $ throwChatError $ CECommandError "member contact already exists" + subMode <- chatReadVar subscriptionMode + -- TODO PQ should negotitate contact connection with PQSupportOn? + (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing IKPQOff subMode + -- [incognito] reuse membership incognito profile + ct <- withFastStore' $ \db -> createMemberContact db user connId cReq g m mConn subMode + -- TODO not sure it is correct to set connections status here? + lift $ setContactNetworkStatus ct NSConnected + pure $ CRNewMemberContact user ct g m + _ -> throwChatError CEGroupMemberNotActive + APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do + (g@GroupInfo {groupId}, m, ct, cReq) <- withFastStore $ \db -> getMemberContact db vr user contactId + when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent" + case memberConn m of + Just mConn -> do + let msg = XGrpDirectInv cReq msgContent_ + (sndMsg, _, _) <- sendDirectMemberMessage mConn msg groupId + withFastStore' $ \db -> setContactGrpInvSent db ct True + let ct' = ct {contactGrpInvSent = True} + forM_ msgContent_ $ \mc -> do + ci <- saveSndChatItem user (CDDirectSnd ct') sndMsg (CISndMsgContent mc) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct') ci] + pure $ CRNewMemberContactSentInv user ct' g m + _ -> throwChatError CEGroupMemberNotActive + CreateGroupLink gName mRole -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APICreateGroupLink groupId mRole + GroupLinkMemberRole gName mRole -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIGroupLinkMemberRole groupId mRole + DeleteGroupLink gName -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIDeleteGroupLink groupId + ShowGroupLink gName -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIGetGroupLink groupId + SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + quotedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg + let mc = MCText msg + processChatCommand $ APISendMessages (ChatRef CTGroup groupId) False Nothing (ComposedMessage Nothing (Just quotedItemId) mc :| []) + ClearNoteFolder -> withUser $ \user -> do + folderId <- withFastStore (`getUserNoteFolderId` user) + processChatCommand $ APIClearChat (ChatRef CTLocal folderId) + LastChats count_ -> withUser' $ \user -> do + let count = fromMaybe 5000 count_ + (errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user False (PTLast count) clqNoFilters) + unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs) + pure $ CRChats previews + LastMessages (Just chatName) count search -> withUser $ \user -> do + chatRef <- getChatRef user chatName + chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search + pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp) + LastMessages Nothing count search -> withUser $ \user -> do + chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast count) search + pure $ CRChatItems user Nothing chatItems + LastChatItemId (Just chatName) index -> withUser $ \user -> do + chatRef <- getChatRef user chatName + chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing) + pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp) + LastChatItemId Nothing index -> withUser $ \user -> do + chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast $ index + 1) Nothing + pure $ CRChatItemId user (fmap aChatItemId . listToMaybe $ chatItems) + ShowChatItem (Just itemId) -> withUser $ \user -> do + chatItem <- withFastStore $ \db -> do + chatRef <- getChatRefViaItemId db user itemId + getAChatItem db vr user chatRef itemId + pure $ CRChatItems user Nothing ((: []) chatItem) + ShowChatItem Nothing -> withUser $ \user -> do + chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast 1) Nothing + pure $ CRChatItems user Nothing chatItems + ShowChatItemInfo chatName msg -> withUser $ \user -> do + chatRef <- getChatRef user chatName + itemId <- getChatItemIdByText user chatRef msg + processChatCommand $ APIGetChatItemInfo chatRef itemId + ShowLiveItems on -> withUser $ \_ -> + asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_ + SendFile chatName f -> withUser $ \user -> do + chatRef <- getChatRef user chatName + case chatRef of + ChatRef CTLocal folderId -> processChatCommand $ APICreateChatItems folderId (ComposedMessage (Just f) Nothing (MCFile "") :| []) + _ -> processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage (Just f) Nothing (MCFile "") :| []) + SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do + chatRef <- getChatRef user chatName + filePath <- lift $ toFSFilePath fPath + unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath} + fileSize <- getFileSize filePath + unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath} + -- TODO include file description for preview + processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview) :| []) + ForwardFile chatName fileId -> forwardFile chatName fileId SendFile + ForwardImage chatName fileId -> forwardFile chatName fileId SendImage + SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" + -- TODO to use priority transactions we need a parameter that differentiates manual and automatic acceptance + ReceiveFile fileId userApprovedRelays encrypted_ rcvInline_ filePath_ -> withUser $ \_ -> + withFileLock "receiveFile" fileId . procCmd $ do + (user, ft@RcvFileTransfer {fileStatus}) <- withStore (`getRcvFileTransferById` fileId) + encrypt <- (`fromMaybe` encrypted_) <$> chatReadVar encryptLocalFiles + ft' <- (if encrypt && fileStatus == RFSNew then setFileToEncrypt else pure) ft + receiveFile' user ft' userApprovedRelays rcvInline_ filePath_ + SetFileToReceive fileId userApprovedRelays encrypted_ -> withUser $ \_ -> do + withFileLock "setFileToReceive" fileId . procCmd $ do + encrypt <- (`fromMaybe` encrypted_) <$> chatReadVar encryptLocalFiles + cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing + withStore' $ \db -> setRcvFileToReceive db fileId userApprovedRelays cfArgs + ok_ + CancelFile fileId -> withUser $ \user@User {userId} -> + withFileLock "cancelFile" fileId . procCmd $ + withFastStore (\db -> getFileTransfer db user fileId) >>= \case + FTSnd ftm@FileTransferMeta {xftpSndFile, cancelled} fts + | cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled" + | not (null fts) && all fileCancelledOrCompleteSMP fts -> + throwChatError $ CEFileCancel fileId "file transfer is complete" + | otherwise -> do + fileAgentConnIds <- cancelSndFile user ftm fts True + deleteAgentConnectionsAsync user fileAgentConnIds + withFastStore (\db -> liftIO $ lookupChatRefByFileId db user fileId) >>= \case + Nothing -> pure () + Just (ChatRef CTDirect contactId) -> do + (contact, sharedMsgId) <- withFastStore $ \db -> (,) <$> getContact db vr user contactId <*> getSharedMsgIdByFileId db userId fileId + void . sendDirectContactMessage user contact $ XFileCancel sharedMsgId + Just (ChatRef CTGroup groupId) -> do + (Group gInfo ms, sharedMsgId) <- withFastStore $ \db -> (,) <$> getGroup db vr user groupId <*> getSharedMsgIdByFileId db userId fileId + void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId + Just _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" + ci <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId + pure $ CRSndFileCancelled user ci ftm fts + where + fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} = + s == FSCancelled || (s == FSComplete && isNothing xftpSndFile) + FTRcv ftr@RcvFileTransfer {cancelled, fileStatus, xftpRcvFile} + | cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled" + | rcvFileComplete fileStatus -> throwChatError $ CEFileCancel fileId "file transfer is complete" + | otherwise -> case xftpRcvFile of + Nothing -> do + cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user) + ci <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId + pure $ CRRcvFileCancelled user ci ftr + Just XFTPRcvFile {agentRcvFileId} -> do + forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do + fsFilePath <- lift $ toFSFilePath filePath + liftIO $ removeFile fsFilePath `catchAll_` pure () + lift . forM_ agentRcvFileId $ \(AgentRcvFileId aFileId) -> + withAgent' (`xftpDeleteRcvFile` aFileId) + aci_ <- resetRcvCIFileStatus user fileId CIFSRcvInvitation + pure $ CRRcvFileCancelled user aci_ ftr + FileStatus fileId -> withUser $ \user -> do + withFastStore (\db -> lookupChatItemByFileId db vr user fileId) >>= \case + Nothing -> do + fileStatus <- withFastStore $ \db -> getFileTransferProgress db user fileId + pure $ CRFileTransferStatus user fileStatus + Just ci@(AChatItem _ _ _ ChatItem {file}) -> case file of + Just CIFile {fileProtocol = FPLocal} -> + throwChatError $ CECommandError "not supported for local files" + Just CIFile {fileProtocol = FPXFTP} -> + pure $ CRFileTransferStatusXFTP user ci + _ -> do + fileStatus <- withFastStore $ \db -> getFileTransferProgress db user fileId + pure $ CRFileTransferStatus user fileStatus + ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile) + UpdateProfile displayName fullName -> withUser $ \user@User {profile} -> do + let p = (fromLocalProfile profile :: Profile) {displayName = displayName, fullName = fullName} + updateProfile user p + UpdateProfileImage image -> withUser $ \user@User {profile} -> do + let p = (fromLocalProfile profile :: Profile) {image} + updateProfile user p + ShowProfileImage -> withUser $ \user@User {profile} -> pure $ CRUserProfileImage user $ fromLocalProfile profile + SetUserFeature (ACF f) allowed -> withUser $ \user@User {profile} -> do + let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user} + updateProfile user p + SetContactFeature (ACF f) cName allowed_ -> withUser $ \user -> do + ct@Contact {userPreferences} <- withFastStore $ \db -> getContactByName db vr user cName + let prefs' = setPreference f allowed_ $ Just userPreferences + updateContactPrefs user ct prefs' + SetGroupFeature (AGFNR f) gName enabled -> + updateGroupProfileByName gName $ \p -> + p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p} + SetGroupFeatureRole (AGFR f) gName enabled role -> + updateGroupProfileByName gName $ \p -> + p {groupPreferences = Just . setGroupPreferenceRole f enabled role $ groupPreferences p} + SetUserTimedMessages onOff -> withUser $ \user@User {profile} -> do + let allowed = if onOff then FAYes else FANo + pref = TimedMessagesPreference allowed Nothing + p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference' SCFTimedMessages (Just pref) $ preferences' user} + updateProfile user p + SetContactTimedMessages cName timedMessagesEnabled_ -> withUser $ \user -> do + ct@Contact {userPreferences = userPreferences@Preferences {timedMessages}} <- withFastStore $ \db -> getContactByName db vr user cName + let currentTTL = timedMessages >>= \TimedMessagesPreference {ttl} -> ttl + pref_ = tmeToPref currentTTL <$> timedMessagesEnabled_ + prefs' = setPreference' SCFTimedMessages pref_ $ Just userPreferences + updateContactPrefs user ct prefs' + SetGroupTimedMessages gName ttl_ -> do + let pref = uncurry TimedMessagesGroupPreference $ maybe (FEOff, Just 86400) (\ttl -> (FEOn, Just ttl)) ttl_ + updateGroupProfileByName gName $ \p -> + p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p} + SetLocalDeviceName name -> chatWriteVar localDeviceName name >> ok_ + ListRemoteHosts -> CRRemoteHostList <$> listRemoteHosts + SwitchRemoteHost rh_ -> CRCurrentRemoteHost <$> switchRemoteHost rh_ + StartRemoteHost rh_ ca_ bp_ -> do + (localAddrs, remoteHost_, inv@RCSignedInvitation {invitation = RCInvitation {port}}) <- startRemoteHost rh_ ca_ bp_ + pure CRRemoteHostStarted {remoteHost_, invitation = decodeLatin1 $ strEncode inv, ctrlPort = show port, localAddrs} + StopRemoteHost rh_ -> closeRemoteHost rh_ >> ok_ + DeleteRemoteHost rh -> deleteRemoteHost rh >> ok_ + StoreRemoteFile rh encrypted_ localPath -> CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath + GetRemoteFile rh rf -> getRemoteFile rh rf >> ok_ + ConnectRemoteCtrl inv -> withUser_ $ do + (remoteCtrl_, ctrlAppInfo) <- connectRemoteCtrlURI inv + pure CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion = currentAppVersion} + FindKnownRemoteCtrl -> withUser_ $ findKnownRemoteCtrl >> ok_ + ConfirmRemoteCtrl rcId -> withUser_ $ do + (rc, ctrlAppInfo) <- confirmRemoteCtrl rcId + pure CRRemoteCtrlConnecting {remoteCtrl_ = Just rc, ctrlAppInfo, appVersion = currentAppVersion} + VerifyRemoteCtrlSession sessId -> withUser_ $ CRRemoteCtrlConnected <$> verifyRemoteCtrlSession (execChatCommand Nothing) sessId + StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_ + ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls + DeleteRemoteCtrl rc -> withUser_ $ deleteRemoteCtrl rc >> ok_ + APIUploadStandaloneFile userId file@CryptoFile {filePath} -> withUserId userId $ \user -> do + fsFilePath <- lift $ toFSFilePath filePath + fileSize <- liftIO $ CF.getFileContentsSize file {filePath = fsFilePath} + when (fileSize > toInteger maxFileSizeHard) $ throwChatError $ CEFileSize filePath + (_, _, fileTransferMeta) <- xftpSndFileTransfer_ user file fileSize 1 Nothing + pure CRSndStandaloneFileCreated {user, fileTransferMeta} + APIStandaloneFileInfo FileDescriptionURI {clientData} -> pure . CRStandaloneFileInfo $ clientData >>= J.decodeStrict . encodeUtf8 + APIDownloadStandaloneFile userId uri file -> withUserId userId $ \user -> do + ft <- receiveViaURI user uri file + pure $ CRRcvStandaloneFileCreated user ft + QuitChat -> liftIO exitSuccess + ShowVersion -> do + -- simplexmqCommitQ makes iOS builds crash m( + let versionInfo = coreVersionInfo "" + chatMigrations <- map upMigration <$> withFastStore' (Migrations.getCurrent . DB.conn) + agentMigrations <- withAgent getAgentMigrations + pure $ CRVersionInfo {versionInfo, chatMigrations, agentMigrations} + DebugLocks -> lift $ do + chatLockName <- atomically . tryReadTMVar =<< asks chatLock + chatEntityLocks <- getLocks =<< asks entityLocks + agentLocks <- withAgent' debugAgentLocks + pure CRDebugLocks {chatLockName, chatEntityLocks, agentLocks} + where + getLocks ls = atomically $ M.mapKeys enityLockString . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls) + enityLockString cle = case cle of + CLInvitation bs -> "Invitation " <> B.unpack bs + CLConnection connId -> "Connection " <> show connId + CLContact ctId -> "Contact " <> show ctId + CLGroup gId -> "Group " <> show gId + CLUserContact ucId -> "UserContact " <> show ucId + CLFile fId -> "File " <> show fId + DebugEvent event -> toView event >> ok_ + GetAgentSubsTotal userId -> withUserId userId $ \user -> do + users <- withStore' $ \db -> getUsers db + let userIds = map aUserId $ filter (\u -> isNothing (viewPwdHash u) || aUserId u == aUserId user) users + (subsTotal, hasSession) <- lift $ withAgent' $ \a -> getAgentSubsTotal a userIds + pure $ CRAgentSubsTotal user subsTotal hasSession + GetAgentServersSummary userId -> withUserId userId $ \user -> do + agentServersSummary <- lift $ withAgent' getAgentServersSummary + withStore' $ \db -> do + users <- getUsers db + smpServers <- getServers db user SPSMP + xftpServers <- getServers db user SPXFTP + let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers _defaultNtfServers + pure $ CRAgentServersSummary user presentedServersSummary + where + getServers :: ProtocolTypeI p => DB.Connection -> User -> SProtocolType p -> IO [ProtocolServer p] + getServers db user p = map (\UserServer {server} -> protoServer server) <$> getProtocolServers db p user + ResetAgentServersStats -> withAgent resetAgentServersStats >> ok_ + GetAgentWorkers -> lift $ CRAgentWorkersSummary <$> withAgent' getAgentWorkersSummary + GetAgentWorkersDetails -> lift $ CRAgentWorkersDetails <$> withAgent' getAgentWorkersDetails + GetAgentSubs -> lift $ summary <$> withAgent' getAgentSubscriptions + where + summary SubscriptionsInfo {activeSubscriptions, pendingSubscriptions, removedSubscriptions} = + CRAgentSubs + { activeSubs = foldl' countSubs M.empty activeSubscriptions, + pendingSubs = foldl' countSubs M.empty pendingSubscriptions, + removedSubs = foldl' accSubErrors M.empty removedSubscriptions + } + where + countSubs m SubInfo {server} = M.alter (Just . maybe 1 (+ 1)) server m + accSubErrors m = \case + SubInfo {server, subError = Just e} -> M.alter (Just . maybe [e] (e :)) server m + _ -> m + GetAgentSubsDetails -> lift $ CRAgentSubsDetails <$> withAgent' getAgentSubscriptions + GetAgentQueuesInfo -> lift $ CRAgentQueuesInfo <$> withAgent' getAgentQueuesInfo + -- CustomChatCommand is unsupported, it can be processed in preCmdHook + -- in a modified CLI app or core - the hook should return Either ChatResponse ChatCommand + CustomChatCommand _cmd -> withUser $ \user -> pure $ chatCmdError (Just user) "not supported" + where + -- below code would make command responses asynchronous where they can be slow + -- in View.hs `r'` should be defined as `id` in this case + -- procCmd :: m ChatResponse -> m ChatResponse + -- procCmd action = do + -- ChatController {chatLock = l, smpAgent = a, outputQ = q, random = gVar} <- ask + -- corrId <- liftIO $ SMP.CorrId <$> randomBytes gVar 8 + -- void . forkIO $ + -- withAgentLock a . withLock l name $ + -- (atomically . writeTBQueue q) . (Just corrId,) =<< (action `catchChatError` (pure . CRChatError)) + -- pure $ CRCmdAccepted corrId + -- use function below to make commands "synchronous" + procCmd :: CM ChatResponse -> CM ChatResponse + procCmd = id + ok_ = pure $ CRCmdOk Nothing + ok = pure . CRCmdOk . Just + getChatRef :: User -> ChatName -> CM ChatRef + getChatRef user (ChatName cType name) = + ChatRef cType <$> case cType of + CTDirect -> withFastStore $ \db -> getContactIdByName db user name + CTGroup -> withFastStore $ \db -> getGroupIdByName db user name + CTLocal + | name == "" -> withFastStore (`getUserNoteFolderId` user) + | otherwise -> throwChatError $ CECommandError "not supported" + _ -> throwChatError $ CECommandError "not supported" + checkChatStopped :: CM ChatResponse -> CM ChatResponse + checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped) + setStoreChanged :: CM () + setStoreChanged = asks chatStoreChanged >>= atomically . (`writeTVar` True) + withStoreChanged :: CM () -> CM ChatResponse + withStoreChanged a = checkChatStopped $ a >> setStoreChanged >> ok_ + checkStoreNotChanged :: CM ChatResponse -> CM ChatResponse + checkStoreNotChanged = ifM (asks chatStoreChanged >>= readTVarIO) (throwChatError CEChatStoreChanged) + withUserName :: UserName -> (UserId -> ChatCommand) -> CM ChatResponse + withUserName uName cmd = withFastStore (`getUserIdByName` uName) >>= processChatCommand . cmd + withContactName :: ContactName -> (ContactId -> ChatCommand) -> CM ChatResponse + withContactName cName cmd = withUser $ \user -> + withFastStore (\db -> getContactIdByName db user cName) >>= processChatCommand . cmd + withMemberName :: GroupName -> ContactName -> (GroupId -> GroupMemberId -> ChatCommand) -> CM ChatResponse + withMemberName gName mName cmd = withUser $ \user -> + getGroupAndMemberId user gName mName >>= processChatCommand . uncurry cmd + getConnectionCode :: ConnId -> CM Text + getConnectionCode connId = verificationCode <$> withAgent (`getConnectionRatchetAdHash` connId) + verifyConnectionCode :: User -> Connection -> Maybe Text -> CM ChatResponse + verifyConnectionCode user conn@Connection {connId} (Just code) = do + code' <- getConnectionCode $ aConnId conn + let verified = sameVerificationCode code code' + when verified . withFastStore' $ \db -> setConnectionVerified db user connId $ Just code' + pure $ CRConnectionVerified user verified code' + verifyConnectionCode user conn@Connection {connId} _ = do + code' <- getConnectionCode $ aConnId conn + withFastStore' $ \db -> setConnectionVerified db user connId Nothing + pure $ CRConnectionVerified user False code' + getSentChatItemIdByText :: User -> ChatRef -> Text -> CM Int64 + getSentChatItemIdByText user@User {userId, localDisplayName} (ChatRef cType cId) msg = case cType of + CTDirect -> withFastStore $ \db -> getDirectChatItemIdByText db userId cId SMDSnd msg + CTGroup -> withFastStore $ \db -> getGroupChatItemIdByText db user cId (Just localDisplayName) msg + CTLocal -> withFastStore $ \db -> getLocalChatItemIdByText db user cId SMDSnd msg + _ -> throwChatError $ CECommandError "not supported" + getChatItemIdByText :: User -> ChatRef -> Text -> CM Int64 + getChatItemIdByText user (ChatRef cType cId) msg = case cType of + CTDirect -> withFastStore $ \db -> getDirectChatItemIdByText' db user cId msg + CTGroup -> withFastStore $ \db -> getGroupChatItemIdByText' db user cId msg + CTLocal -> withFastStore $ \db -> getLocalChatItemIdByText' db user cId msg + _ -> throwChatError $ CECommandError "not supported" + connectViaContact :: User -> IncognitoEnabled -> ConnectionRequestUri 'CMContact -> CM ChatResponse + connectViaContact user@User {userId} incognito cReq@(CRContactUri ConnReqUriData {crClientData}) = withInvitationLock "connectViaContact" (strEncode cReq) $ do + let groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli + cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq + case groupLinkId of + -- contact address + Nothing -> + withFastStore' (\db -> getConnReqContactXContactId db vr 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 False + -- group link + Just gLinkId -> + withFastStore' (\db -> getConnReqContactXContactId db vr user cReqHash) >>= \case + (Just _contact, _) -> procCmd $ do + -- allow repeat contact request + newXContactId <- XContactId <$> drgRandomBytes 16 + connect' (Just gLinkId) cReqHash newXContactId True + (_, xContactId_) -> procCmd $ do + let randomXContactId = XContactId <$> drgRandomBytes 16 + xContactId <- maybe randomXContactId pure xContactId_ + connect' (Just gLinkId) cReqHash xContactId True + where + connect' groupLinkId cReqHash xContactId inGroup = do + let pqSup = if inGroup then PQSupportOff else PQSupportOn + (connId, chatV) <- prepareContact user cReq pqSup + -- [incognito] generate profile to send + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + subMode <- chatReadVar subscriptionMode + conn@PendingContactConnection {pccConnId} <- withFastStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile groupLinkId subMode chatV pqSup + joinContact user pccConnId connId cReq incognitoProfile xContactId inGroup pqSup chatV + pure $ CRSentInvitation user conn incognitoProfile + connectContactViaAddress :: User -> IncognitoEnabled -> Contact -> ConnectionRequestUri 'CMContact -> CM ChatResponse + connectContactViaAddress user incognito ct cReq = + withInvitationLock "connectContactViaAddress" (strEncode cReq) $ do + newXContactId <- XContactId <$> drgRandomBytes 16 + let pqSup = PQSupportOn + (connId, chatV) <- prepareContact user cReq pqSup + let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq + -- [incognito] generate profile to send + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + subMode <- chatReadVar subscriptionMode + (pccConnId, ct') <- withFastStore $ \db -> createAddressContactConnection db vr user ct connId cReqHash newXContactId incognitoProfile subMode chatV pqSup + joinContact user pccConnId connId cReq incognitoProfile newXContactId False pqSup chatV + pure $ CRSentInvitationToContact user ct' incognitoProfile + prepareContact :: User -> ConnectionRequestUri 'CMContact -> PQSupport -> CM (ConnId, VersionChat) + prepareContact user cReq pqSup = do + -- 0) toggle disabled - PQSupportOff + -- 1) toggle enabled, address supports PQ (connRequestPQSupport returns Just True) - PQSupportOn, enable support with compression + -- 2) toggle enabled, address doesn't support PQ - PQSupportOn but without compression, with version range indicating support + lift (withAgent' $ \a -> connRequestPQSupport a pqSup cReq) >>= \case + Nothing -> throwChatError CEInvalidConnReq + Just (agentV, _) -> do + let chatV = agentToChatVersion agentV + connId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup + pure (connId, chatV) + joinContact :: User -> Int64 -> ConnId -> ConnectionRequestUri 'CMContact -> Maybe Profile -> XContactId -> Bool -> PQSupport -> VersionChat -> CM () + joinContact user pccConnId connId cReq incognitoProfile xContactId inGroup pqSup chatV = do + let profileToSend = userProfileToSend user incognitoProfile Nothing inGroup + dm <- encodeConnInfoPQ pqSup chatV (XContact profileToSend $ Just xContactId) + subMode <- chatReadVar subscriptionMode + joinPreparedAgentConnection user pccConnId connId cReq dm pqSup subMode + joinPreparedAgentConnection :: User -> Int64 -> ConnId -> ConnectionRequestUri m -> ByteString -> PQSupport -> SubscriptionMode -> CM () + joinPreparedAgentConnection user pccConnId connId cReq connInfo pqSup subMode = do + void (withAgent $ \a -> joinConnection a (aUserId user) connId True cReq connInfo pqSup subMode) + `catchChatError` \e -> do + withFastStore' $ \db -> deleteConnectionRecord db user pccConnId + withAgent $ \a -> deleteConnectionAsync a False connId + throwError e + contactMember :: Contact -> [GroupMember] -> Maybe GroupMember + contactMember Contact {contactId} = + find $ \GroupMember {memberContactId = cId, memberStatus = s} -> + cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft + checkSndFile :: CryptoFile -> CM Integer + checkSndFile (CryptoFile f cfArgs) = do + fsFilePath <- lift $ toFSFilePath f + unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f + fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cfArgs + when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f + pure fileSize + updateProfile :: User -> Profile -> CM ChatResponse + updateProfile user p' = updateProfile_ user p' $ withFastStore $ \db -> updateUserProfile db user p' + updateProfile_ :: User -> Profile -> CM User -> CM ChatResponse + updateProfile_ user@User {profile = p@LocalProfile {displayName = n}} p'@Profile {displayName = n'} updateUser + | p' == fromLocalProfile p = pure $ CRUserProfileNoChange user + | otherwise = do + when (n /= n') $ checkValidName n' + -- read contacts before user update to correctly merge preferences + contacts <- withFastStore' $ \db -> getUserContacts db vr user + user' <- updateUser + asks currentUser >>= atomically . (`writeTVar` Just user') + withChatLock "updateProfile" . procCmd $ do + let changedCts_ = L.nonEmpty $ foldr (addChangedProfileContact user') [] contacts + summary <- case changedCts_ of + Nothing -> pure $ UserProfileUpdateSummary 0 0 [] + Just changedCts -> do + let idsEvts = L.map ctSndEvent changedCts + msgReqs_ <- lift $ L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts + (errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_ + unless (null errs) $ toView $ CRChatErrors (Just user) errs + let changedCts' = filter (\ChangedProfileContact {ct, ct'} -> directOrUsed ct' && mergedPreferences ct' /= mergedPreferences ct) cts + lift $ createContactsSndFeatureItems user' changedCts' + pure + UserProfileUpdateSummary + { updateSuccesses = length cts, + updateFailures = length errs, + changedContacts = map (\ChangedProfileContact {ct'} -> ct') changedCts' + } + pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary + where + -- [incognito] filter out contacts with whom user has incognito connections + addChangedProfileContact :: User -> Contact -> [ChangedProfileContact] -> [ChangedProfileContact] + addChangedProfileContact user' ct changedCts = case contactSendConn_ ct' of + Right conn + | not (connIncognito conn) && mergedProfile' /= mergedProfile -> + ChangedProfileContact ct ct' mergedProfile' conn : changedCts + _ -> changedCts + where + mergedProfile = userProfileToSend user Nothing (Just ct) False + ct' = updateMergedPreferences user' ct + mergedProfile' = userProfileToSend user' Nothing (Just ct') False + ctSndEvent :: ChangedProfileContact -> (ConnOrGroupId, ChatMsgEvent 'Json) + ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = (ConnectionId connId, XInfo mergedProfile') + ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq + ctMsgReq ChangedProfileContact {conn} = + fmap $ \SndMessage {msgId, msgBody} -> + (conn, MsgFlags {notification = hasNotification XInfo_}, msgBody, [msgId]) + updateContactPrefs :: User -> Contact -> Preferences -> CM ChatResponse + updateContactPrefs _ ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotActive ct + updateContactPrefs user@User {userId} ct@Contact {activeConn = Just Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs' + | contactUserPrefs == contactUserPrefs' = pure $ CRContactPrefsUpdated user ct ct + | otherwise = do + assertDirectAllowed user MDSnd ct XInfo_ + ct' <- withStore' $ \db -> updateContactUserPreferences db user ct contactUserPrefs' + incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId + let mergedProfile = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct) False + mergedProfile' = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct') False + when (mergedProfile' /= mergedProfile) $ + withContactLock "updateProfile" (contactId' ct) $ do + void (sendDirectContactMessage user ct' $ XInfo mergedProfile') `catchChatError` (toView . CRChatError (Just user)) + lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct' + pure $ CRContactPrefsUpdated user ct ct' + runUpdateGroupProfile :: User -> Group -> GroupProfile -> CM ChatResponse + runUpdateGroupProfile user (Group g@GroupInfo {businessChat, groupProfile = p@GroupProfile {displayName = n}} ms) p'@GroupProfile {displayName = n'} = do + assertUserGroupRole g GROwner + when (n /= n') $ checkValidName n' + g' <- withStore $ \db -> updateGroupProfile db user g p' + msg <- case businessChat of + Just BusinessChatInfo {businessId} -> do + let (newMs, oldMs) = partition (\m -> maxVersion (memberChatVRange m) >= businessChatPrefsVersion) ms + -- this is a fallback to send the members with the old version correct profile of the business when preferences change + unless (null oldMs) $ do + GroupMember {memberProfile = LocalProfile {displayName, fullName, image}} <- + withStore $ \db -> getGroupMemberByMemberId db vr user g businessId + let p'' = p' {displayName, fullName, image} :: GroupProfile + void $ sendGroupMessage user g' oldMs (XGrpInfo p'') + let ps' = fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' + sendGroupMessage user g' newMs $ XGrpPrefs ps' + Nothing -> sendGroupMessage user g' ms (XGrpInfo p') + let cd = CDGroupSnd g' + unless (sameGroupProfileInfo p p') $ do + ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p') + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat g') ci] + createGroupFeatureChangedItems user cd CISndGroupFeature g g' + pure $ CRGroupUpdated user g g' Nothing + checkValidName :: GroupName -> CM () + checkValidName displayName = do + when (T.null displayName) $ throwChatError CEInvalidDisplayName {displayName, validName = ""} + let validName = T.pack $ mkValidName $ T.unpack displayName + when (displayName /= validName) $ throwChatError CEInvalidDisplayName {displayName, validName} + assertUserGroupRole :: GroupInfo -> GroupMemberRole -> CM () + assertUserGroupRole g@GroupInfo {membership} requiredRole = do + let GroupMember {memberRole = membershipMemRole} = membership + when (membershipMemRole < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole + when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g) + when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved + unless (memberActive membership) $ throwChatError CEGroupMemberNotActive + delGroupChatItems :: User -> GroupInfo -> [CChatItem 'CTGroup] -> Maybe GroupMember -> CM ChatResponse + delGroupChatItems user gInfo items byGroupMember = do + deletedTs <- liftIO getCurrentTime + if groupFeatureAllowed SGFFullDelete gInfo + then deleteGroupCIs user gInfo items True False byGroupMember deletedTs + else markGroupCIsDeleted user gInfo items True byGroupMember deletedTs + updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> CM ChatResponse + updateGroupProfileByName gName update = withUser $ \user -> do + g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> + getGroupIdByName db user gName >>= getGroup db vr user + runUpdateGroupProfile user g $ update p + withCurrentCall :: ContactId -> (User -> Contact -> Call -> CM (Maybe Call)) -> CM ChatResponse + withCurrentCall ctId action = do + (user, ct) <- withStore $ \db -> do + user <- getUserByContactId db ctId + (user,) <$> getContact db vr user ctId + calls <- asks currentCalls + withContactLock "currentCall" ctId $ + atomically (TM.lookup ctId calls) >>= \case + Nothing -> throwChatError CENoCurrentCall + Just call@Call {contactId} + | ctId == contactId -> do + call_ <- action user ct call + case call_ of + Just call' -> do + unless (isRcvInvitation call') $ withStore' $ \db -> deleteCalls db user ctId + atomically $ TM.insert ctId call' calls + _ -> do + withStore' $ \db -> deleteCalls db user ctId + atomically $ TM.delete ctId calls + ok user + | otherwise -> throwChatError $ CECallContact contactId + withServerProtocol :: ProtocolTypeI p => SProtocolType p -> (UserProtocol p => CM a) -> CM a + withServerProtocol p action = case userProtocol p of + Just Dict -> action + _ -> throwChatError $ CEServerProtocol $ AProtocolType p + validateAllUsersServers :: UserServersClass u => Int64 -> [u] -> CM [UserServersError] + validateAllUsersServers currUserId userServers = withFastStore $ \db -> do + users' <- filter (\User {userId} -> userId /= currUserId) <$> liftIO (getUsers db) + others <- mapM (getUserOperatorServers db) users' + pure $ validateUserServers userServers others + where + getUserOperatorServers :: DB.Connection -> User -> ExceptT StoreError IO (User, [UserOperatorServers]) + getUserOperatorServers db user = do + uss <- liftIO . groupByOperator =<< getUserServers db user + pure (user, map updatedUserSrvs uss) + updatedUserSrvs uss = uss {operator = updatedOp <$> operator' uss} :: UserOperatorServers + updatedOp op = fromMaybe op $ find matchingOp $ mapMaybe operator' userServers + where + matchingOp op' = operatorId op' == operatorId op + forwardFile :: ChatName -> FileTransferId -> (ChatName -> CryptoFile -> ChatCommand) -> CM ChatResponse + forwardFile chatName fileId sendCommand = withUser $ \user -> do + withStore (\db -> getFileTransfer db user fileId) >>= \case + FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}, cryptoArgs} -> forward filePath cryptoArgs + FTSnd {fileTransferMeta = FileTransferMeta {filePath, xftpSndFile}} -> forward filePath $ xftpSndFile >>= \XFTPSndFile {cryptoArgs} -> cryptoArgs + _ -> throwChatError CEFileNotReceived {fileId} + where + forward path cfArgs = processChatCommand . sendCommand chatName $ CryptoFile path cfArgs + getGroupAndMemberId :: User -> GroupName -> ContactName -> CM (GroupId, GroupMemberId) + getGroupAndMemberId user gName groupMemberName = + withStore $ \db -> do + groupId <- getGroupIdByName db user gName + groupMemberId <- getGroupMemberIdByName db user groupId groupMemberName + pure (groupId, groupMemberId) + sendGrpInvitation :: User -> Contact -> GroupInfo -> GroupMember -> ConnReqInvitation -> CM () + sendGrpInvitation user ct@Contact {contactId, localDisplayName} gInfo@GroupInfo {groupId, groupProfile, membership, businessChat} GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do + currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo + let GroupMember {memberRole = userRole, memberId = userMemberId} = membership + groupInv = + GroupInvitation + { fromMember = MemberIdRole userMemberId userRole, + invitedMember = MemberIdRole memberId memRole, + connRequest = cReq, + groupProfile, + business = businessChat, + groupLinkId = Nothing, + groupSize = Just currentMemCount + } + (msg, _) <- sendDirectContactMessage user ct $ XGrpInv groupInv + let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole + timed_ <- contactCITimed ct + ci <- saveSndChatItem' user (CDDirectSnd ct) msg content Nothing Nothing Nothing timed_ False + toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] + forM_ (timed_ >>= timedDeleteAt') $ + startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) + drgRandomBytes :: Int -> CM ByteString + drgRandomBytes n = asks random >>= atomically . C.randomBytes n + privateGetUser :: UserId -> CM User + privateGetUser userId = + tryChatError (withStore (`getUser` userId)) >>= \case + Left _ -> throwChatError CEUserUnknown + Right user -> pure user + validateUserPassword :: User -> User -> Maybe UserPwd -> CM () + validateUserPassword = validateUserPassword_ . Just + validateUserPassword_ :: Maybe User -> User -> Maybe UserPwd -> CM () + validateUserPassword_ user_ User {userId = userId', viewPwdHash} viewPwd_ = + forM_ viewPwdHash $ \pwdHash -> + let userId_ = (\User {userId} -> userId) <$> user_ + pwdOk = case viewPwd_ of + Nothing -> userId_ == Just userId' + Just (UserPwd viewPwd) -> validPassword viewPwd pwdHash + in unless pwdOk $ throwChatError CEUserUnknown + validPassword :: Text -> UserPwdHash -> Bool + validPassword pwd UserPwdHash {hash = B64UrlByteString hash, salt = B64UrlByteString salt} = + hash == C.sha512Hash (encodeUtf8 pwd <> salt) + setUserNotifications :: UserId -> Bool -> CM ChatResponse + setUserNotifications userId' showNtfs = withUser $ \user -> do + user' <- privateGetUser userId' + case viewPwdHash user' of + Just _ -> throwChatError $ CEHiddenUserAlwaysMuted userId' + _ -> setUserPrivacy user user' {showNtfs} + setUserPrivacy :: User -> User -> CM ChatResponse + setUserPrivacy user@User {userId} user'@User {userId = userId'} + | userId == userId' = do + asks currentUser >>= atomically . (`writeTVar` Just user') + withFastStore' (`updateUserPrivacy` user') + pure $ CRUserPrivacy {user = user', updatedUser = user'} + | otherwise = do + withFastStore' (`updateUserPrivacy` user') + pure $ CRUserPrivacy {user, updatedUser = user'} + checkDeleteChatUser :: User -> CM () + checkDeleteChatUser user@User {userId} = do + users <- withFastStore' getUsers + let otherVisible = filter (\User {userId = userId', viewPwdHash} -> userId /= userId' && isNothing viewPwdHash) users + when (activeUser user && length otherVisible > 0) $ throwChatError (CECantDeleteActiveUser userId) + deleteChatUser :: User -> Bool -> CM ChatResponse + deleteChatUser user delSMPQueues = do + filesInfo <- withFastStore' (`getUserFileInfo` user) + cancelFilesInProgress user filesInfo + deleteFilesLocally filesInfo + withAgent (\a -> deleteUser a (aUserId user) delSMPQueues) + `catchChatError` \case + e@(ChatErrorAgent NO_USER _) -> toView $ CRChatError (Just user) e + e -> throwError e + withFastStore' (`deleteUserRecord` user) + when (activeUser user) $ chatWriteVar currentUser Nothing + ok_ + updateChatSettings :: ChatName -> (ChatSettings -> ChatSettings) -> CM ChatResponse + updateChatSettings (ChatName cType name) updateSettings = withUser $ \user -> do + (chatId, chatSettings) <- case cType of + CTDirect -> withFastStore $ \db -> do + ctId <- getContactIdByName db user name + Contact {chatSettings} <- getContact db vr user ctId + pure (ctId, chatSettings) + CTGroup -> + withFastStore $ \db -> do + gId <- getGroupIdByName db user name + GroupInfo {chatSettings} <- getGroupInfo db vr user gId + pure (gId, chatSettings) + _ -> throwChatError $ CECommandError "not supported" + processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings + connectPlan :: User -> AConnectionRequestUri -> CM ConnectionPlan + connectPlan user (ACR SCMInvitation (CRInvitationUri crData e2e)) = do + withFastStore' (\db -> getConnectionEntityByConnReq db vr user cReqSchemas) >>= \case + Nothing -> pure $ CPInvitationLink ILPOk + Just (RcvDirectMsgConnection Connection {connStatus = ConnPrepared} 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" + where + cReqSchemas :: (ConnReqInvitation, ConnReqInvitation) + cReqSchemas = + ( CRInvitationUri crData {crScheme = SSSimplex} e2e, + CRInvitationUri crData {crScheme = simplexChat} e2e + ) + connectPlan user (ACR SCMContact (CRContactUri crData)) = do + let ConnReqUriData {crClientData} = crData + groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli + case groupLinkId of + -- contact address + Nothing -> + withFastStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case + Just _ -> pure $ CPContactAddress CAPOwnLink + Nothing -> + withFastStore' (\db -> getContactConnEntityByConnReqHash db vr user cReqHashes) >>= \case + Nothing -> + withFastStore' (\db -> getContactWithoutConnViaAddress db vr user cReqSchemas) >>= \case + Nothing -> pure $ CPContactAddress CAPOk + Just ct -> pure $ CPContactAddress (CAPContactViaAddress ct) + Just (RcvDirectMsgConnection _conn Nothing) -> pure $ CPContactAddress CAPConnectingConfirmReconnect + Just (RcvDirectMsgConnection _ (Just ct)) + | not (contactReady ct) && contactActive ct -> pure $ CPContactAddress (CAPConnectingProhibit ct) + | contactDeleted ct -> pure $ CPContactAddress CAPOk + | otherwise -> pure $ CPContactAddress (CAPKnown ct) + Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo + Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection or RcvGroupMsgConnection" + -- group link + Just _ -> + withFastStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case + Just g -> pure $ CPGroupLink (GLPOwnLink g) + Nothing -> do + connEnt_ <- withFastStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes + gInfo_ <- withFastStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes + case (gInfo_, connEnt_) of + (Nothing, Nothing) -> pure $ CPGroupLink GLPOk + (Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> pure $ CPGroupLink GLPConnectingConfirmReconnect + (Nothing, Just (RcvDirectMsgConnection _ (Just ct))) + | not (contactReady ct) && contactActive ct -> pure $ CPGroupLink (GLPConnectingProhibit gInfo_) + | otherwise -> pure $ CPGroupLink GLPOk + (Nothing, Just _) -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" + (Just gInfo, _) -> groupPlan gInfo + where + groupPlan gInfo@GroupInfo {membership} + | not (memberActive membership) && not (memberRemoved membership) = + pure $ CPGroupLink (GLPConnectingProhibit $ Just gInfo) + | memberActive membership = pure $ CPGroupLink (GLPKnown gInfo) + | otherwise = pure $ CPGroupLink GLPOk + cReqSchemas :: (ConnReqContact, ConnReqContact) + cReqSchemas = + ( CRContactUri crData {crScheme = SSSimplex}, + CRContactUri crData {crScheme = simplexChat} + ) + cReqHashes :: (ConnReqUriHash, ConnReqUriHash) + cReqHashes = bimap hash hash cReqSchemas + hash = ConnReqUriHash . C.sha256Hash . strEncode + updateCIGroupInvitationStatus user GroupInfo {groupId} newStatus = do + AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withFastStore $ \db -> getChatItemByGroupId db vr user groupId + case (cInfo, content) of + (DirectChat ct@Contact {contactId}, CIRcvGroupInvitation ciGroupInv@CIGroupInvitation {status} memRole) + | status == CIGISPending -> do + let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = newStatus} memRole + timed_ <- contactCITimed ct + updateDirectChatItemView user ct itemId aciContent False False timed_ Nothing + forM_ (timed_ >>= timedDeleteAt') $ + startProximateTimedItemThread user (ChatRef CTDirect contactId, itemId) + _ -> pure () -- prohibited + sendContactContentMessages :: User -> ContactId -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse + sendContactContentMessages user contactId live itemTTL cmrs = do + assertMultiSendable live cmrs + ct@Contact {contactUsed} <- withFastStore $ \db -> getContact db vr user contactId + assertDirectAllowed user MDSnd ct XMsgNew_ + assertVoiceAllowed ct + unless contactUsed $ withFastStore' $ \db -> updateContactUsed db user ct + processComposedMessages ct + where + assertVoiceAllowed :: Contact -> CM () + assertVoiceAllowed ct = + when (not (featureAllowed SCFVoice forUser ct) && any (\(ComposedMessage {msgContent}, _) -> isVoice msgContent) cmrs) $ + throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFVoice)) + processComposedMessages :: Contact -> CM ChatResponse + processComposedMessages ct = do + (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers + timed_ <- sndContactCITimed live ct itemTTL + (msgContainers, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ + msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers + let itemsData = prepareSndItemsData msgs_ cmrs ciFiles_ quotedItems_ + when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch" + r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live + processSendErrs user r + forM_ (timed_ >>= timedDeleteAt') $ \deleteAt -> + forM_ cis $ \ci -> + startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) deleteAt + pure $ CRNewChatItems user (map (AChatItem SCTDirect SMDSnd (DirectChat ct)) cis) + where + setupSndFileTransfers :: CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd))) + setupSndFileTransfers = + forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> case file_ of + Just file -> do + fileSize <- checkSndFile file + (fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 $ CGContact ct + pure (Just fInv, Just ciFile) + Nothing -> pure (Nothing, Nothing) + prepareMsgs :: NonEmpty (ComposeMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect))) + prepareMsgs cmsFileInvs timed_ = + forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded), fInv_) -> + case (quotedItemId, itemForwarded) of + (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + (Just qiId, Nothing) -> do + CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- + withFastStore $ \db -> getDirectChatItem db user contactId qiId + (origQmc, qd, sent) <- quoteData qci + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} + qmc = quoteContent mc origQmc file + quotedItem = CIQuote {chatDir = qd, itemId = Just qiId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) + (Just _, Just _) -> throwChatError CEInvalidQuote + where + quoteData :: ChatItem c d -> CM (MsgContent, CIQDirection 'CTDirect, Bool) + quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote + quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True) + quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) + quoteData _ = throwChatError CEInvalidQuote + sendGroupContentMessages :: User -> GroupId -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse + sendGroupContentMessages user groupId live itemTTL cmrs = do + assertMultiSendable live cmrs + g@(Group gInfo _) <- withFastStore $ \db -> getGroup db vr user groupId + assertUserGroupRole gInfo GRAuthor + assertGroupContentAllowed gInfo + processComposedMessages g + where + assertGroupContentAllowed :: GroupInfo -> CM () + assertGroupContentAllowed gInfo@GroupInfo {membership} = + case findProhibited (L.toList cmrs) of + Just f -> throwChatError (CECommandError $ "feature not allowed " <> T.unpack (groupFeatureNameText f)) + Nothing -> pure () + where + findProhibited :: [ComposeMessageReq] -> Maybe GroupFeature + findProhibited = + foldr' + (\(ComposedMessage {fileSource, msgContent = mc}, _) acc -> prohibitedGroupContent gInfo membership mc fileSource <|> acc) + Nothing + processComposedMessages :: Group -> CM ChatResponse + processComposedMessages g@(Group gInfo ms) = do + (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length $ filter memberCurrent ms) + timed_ <- sndGroupCITimed live gInfo itemTTL + (msgContainers, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ + (msgs_, gsr) <- sendGroupMessages user gInfo ms $ L.map XMsgNew msgContainers + let itemsData = prepareSndItemsData (L.toList msgs_) cmrs ciFiles_ quotedItems_ + cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData timed_ live + when (length itemsData /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch" + createMemberSndStatuses cis_ msgs_ gsr + let r@(_, cis) = partitionEithers cis_ + processSendErrs user r + forM_ (timed_ >>= timedDeleteAt') $ \deleteAt -> + forM_ cis $ \ci -> + startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) deleteAt + pure $ CRNewChatItems user (map (AChatItem SCTGroup SMDSnd (GroupChat gInfo)) cis) + where + setupSndFileTransfers :: Int -> CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd))) + setupSndFileTransfers n = + forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> case file_ of + Just file -> do + fileSize <- checkSndFile file + (fInv, ciFile) <- xftpSndFileTransfer user file fileSize n $ CGGroup g + pure (Just fInv, Just ciFile) + Nothing -> pure (Nothing, Nothing) + prepareMsgs :: NonEmpty (ComposeMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTGroup))) + prepareMsgs cmsFileInvs timed_ = + forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded), fInv_) -> + prepareGroupMsg user gInfo mc quotedItemId itemForwarded fInv_ timed_ live + createMemberSndStatuses :: + [Either ChatError (ChatItem 'CTGroup 'MDSnd)] -> + NonEmpty (Either ChatError SndMessage) -> + GroupSndResult -> + CM () + createMemberSndStatuses cis_ msgs_ GroupSndResult {sentTo, pending, forwarded} = do + let msgToItem = mapMsgToItem + withFastStore' $ \db -> do + forM_ sentTo (processSentTo db msgToItem) + forM_ forwarded (processForwarded db) + forM_ pending (processPending db msgToItem) + where + mapMsgToItem :: Map MessageId ChatItemId + mapMsgToItem = foldr' addItem M.empty (zip (L.toList msgs_) cis_) + where + addItem (Right SndMessage {msgId}, Right ci) m = M.insert msgId (chatItemId' ci) m + addItem _ m = m + processSentTo :: DB.Connection -> Map MessageId ChatItemId -> (GroupMemberId, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption)) -> IO () + processSentTo db msgToItem (mId, msgIds_, deliveryResult) = forM_ msgIds_ $ \msgIds -> do + let ciIds = mapMaybe (`M.lookup` msgToItem) msgIds + status = case deliveryResult of + Right _ -> GSSNew + Left e -> GSSError $ SndErrOther $ tshow e + forM_ ciIds $ \ciId -> createGroupSndStatus db ciId mId status + processForwarded :: DB.Connection -> GroupMember -> IO () + processForwarded db GroupMember {groupMemberId} = + forM_ cis_ $ \ci_ -> + forM_ ci_ $ \ci -> createGroupSndStatus db (chatItemId' ci) groupMemberId GSSForwarded + processPending :: DB.Connection -> Map MessageId ChatItemId -> (GroupMemberId, Either ChatError MessageId, Either ChatError ()) -> IO () + processPending db msgToItem (mId, msgId_, pendingResult) = forM_ msgId_ $ \msgId -> do + let ciId_ = M.lookup msgId msgToItem + status = case pendingResult of + Right _ -> GSSInactive + Left e -> GSSError $ SndErrOther $ tshow e + forM_ ciId_ $ \ciId -> createGroupSndStatus db ciId mId status + assertMultiSendable :: Bool -> NonEmpty ComposeMessageReq -> CM () + assertMultiSendable live cmrs + | length cmrs == 1 = pure () + | otherwise = + -- When sending multiple messages only single quote is allowed. + -- This is to support case of sending multiple attachments while also quoting another message. + -- UI doesn't allow composing with multiple quotes, so api prohibits it as well, and doesn't bother + -- batching retrieval of quoted messages (prepareMsgs). + when (live || length (L.filter (\(ComposedMessage {quotedItemId}, _) -> isJust quotedItemId) cmrs) > 1) $ + throwChatError (CECommandError "invalid multi send: live and more than one quote not supported") + xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd) + xftpSndFileTransfer user file fileSize n contactOrGroup = do + (fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup + case contactOrGroup of + CGContact Contact {activeConn} -> forM_ activeConn $ \conn -> + withFastStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr + CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user)) + where + -- we are not sending files to pending members, same as with inline files + saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} = + when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $ + withFastStore' $ + \db -> createSndFTDescrXFTP db user (Just m) conn ft dummyFileDescr + saveMemberFD _ = pure () + pure (fInv, ciFile) + prepareSndItemsData :: + [Either ChatError SndMessage] -> + NonEmpty ComposeMessageReq -> + NonEmpty (Maybe (CIFile 'MDSnd)) -> + NonEmpty (Maybe (CIQuote c)) -> + [Either ChatError (NewSndChatItemData c)] + prepareSndItemsData msgs_ cmrs' ciFiles_ quotedItems_ = + [ ( case msg_ of + Right msg -> Right $ NewSndChatItemData msg (CISndMsgContent msgContent) f q itemForwarded + Left e -> Left e -- step over original error + ) + | (msg_, (ComposedMessage {msgContent}, itemForwarded), f, q) <- + zipWith4 (,,,) msgs_ (L.toList cmrs') (L.toList ciFiles_) (L.toList quotedItems_) + ] + processSendErrs :: User -> ([ChatError], [ChatItem c d]) -> CM () + processSendErrs user = \case + -- no errors + ([], _) -> pure () + -- at least one item is successfully created + (errs, _ci : _) -> toView $ CRChatErrors (Just user) errs + -- single error + ([err], []) -> throwError err + -- multiple errors + (errs@(err : _), []) -> do + toView $ CRChatErrors (Just user) errs + throwError err + getCommandDirectChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (Contact, [CChatItem 'CTDirect]) + getCommandDirectChatItems user ctId itemIds = do + ct <- withFastStore $ \db -> getContact db vr user ctId + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getDirectCI db) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure (ct, items) + where + getDirectCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTDirect)) + getDirectCI db itemId = runExceptT . withExceptT ChatErrorStore $ getDirectChatItem db user ctId itemId + getCommandGroupChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (GroupInfo, [CChatItem 'CTGroup]) + getCommandGroupChatItems user gId itemIds = do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure (gInfo, items) + where + getGroupCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup)) + getGroupCI db itemId = runExceptT . withExceptT ChatErrorStore $ getGroupChatItem db user gId itemId + getCommandLocalChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (NoteFolder, [CChatItem 'CTLocal]) + getCommandLocalChatItems user nfId itemIds = do + nf <- withStore $ \db -> getNoteFolder db user nfId + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getLocalCI db) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure (nf, items) + where + getLocalCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTLocal)) + getLocalCI db itemId = runExceptT . withExceptT ChatErrorStore $ getLocalChatItem db user nfId itemId + forwardMsgContent :: ChatItem c d -> CM (Maybe MsgContent) + forwardMsgContent ChatItem {meta = CIMeta {itemDeleted = Just _}} = pure Nothing -- this can be deleted after selection + forwardMsgContent ChatItem {content = CISndMsgContent fmc} = pure $ Just fmc + forwardMsgContent ChatItem {content = CIRcvMsgContent fmc} = pure $ Just fmc + forwardMsgContent _ = throwChatError CEInvalidForward + createNoteFolderContentItems :: User -> NoteFolderId -> NonEmpty ComposeMessageReq -> CM ChatResponse + createNoteFolderContentItems user folderId cmrs = do + assertNoQuotes + nf <- withFastStore $ \db -> getNoteFolder db user folderId + createdAt <- liftIO getCurrentTime + ciFiles_ <- createLocalFiles nf createdAt + let itemsData = prepareLocalItemsData cmrs ciFiles_ + cis <- createLocalChatItems user (CDLocalSnd nf) itemsData createdAt + pure $ CRNewChatItems user (map (AChatItem SCTLocal SMDSnd (LocalChat nf)) cis) + where + assertNoQuotes :: CM () + assertNoQuotes = + when (any (\(ComposedMessage {quotedItemId}, _) -> isJust quotedItemId) cmrs) $ + throwChatError (CECommandError "createNoteFolderContentItems: quotes not supported") + createLocalFiles :: NoteFolder -> UTCTime -> CM (NonEmpty (Maybe (CIFile 'MDSnd))) + createLocalFiles nf createdAt = + forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> + forM file_ $ \cf@CryptoFile {filePath, cryptoArgs} -> do + fsFilePath <- lift $ toFSFilePath filePath + fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs + chunkSize <- asks $ fileChunkSize . config + withFastStore' $ \db -> do + fileId <- createLocalFile CIFSSndStored db user nf createdAt cf fileSize chunkSize + pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal} + prepareLocalItemsData :: + NonEmpty ComposeMessageReq -> + NonEmpty (Maybe (CIFile 'MDSnd)) -> + [(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom)] + prepareLocalItemsData cmrs' ciFiles_ = + [ (CISndMsgContent mc, f, itemForwarded) + | ((ComposedMessage {msgContent = mc}, itemForwarded), f) <- zip (L.toList cmrs') (L.toList ciFiles_) + ] + getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do + msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId) + CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId) + +protocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) +protocolServers p (operators, smpServers, xftpServers) = case p of + SPSMP -> (operators, smpServers, []) + SPXFTP -> (operators, [], xftpServers) + +-- disable preset and replace custom servers (groupByOperator always adds custom) +updatedServers :: forall p. UserProtocol p => SProtocolType p -> [AUserServer p] -> UserOperatorServers -> UpdatedUserOperatorServers +updatedServers p' srvs UserOperatorServers {operator, smpServers, xftpServers} = case p' of + SPSMP -> u (updateSrvs smpServers, map (AUS SDBStored) xftpServers) + SPXFTP -> u (map (AUS SDBStored) smpServers, updateSrvs xftpServers) + where + u = uncurry $ UpdatedUserOperatorServers operator + updateSrvs :: [UserServer p] -> [AUserServer p] + updateSrvs pSrvs = map disableSrv pSrvs <> maybe srvs (const []) operator + disableSrv srv@UserServer {preset} = + AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True} + +type ComposeMessageReq = (ComposedMessage, Maybe CIForwardedFrom) + +data ChangedProfileContact = ChangedProfileContact + { ct :: Contact, + ct' :: Contact, + mergedProfile' :: Profile, + conn :: Connection + } + +createContactsSndFeatureItems :: User -> [ChangedProfileContact] -> CM' () +createContactsSndFeatureItems user cts = + createContactsFeatureItems user cts' CDDirectSnd CISndChatFeature CISndChatPreference getPref + where + cts' = map (\ChangedProfileContact {ct, ct'} -> (ct, ct')) cts + getPref ContactUserPreference {userPreference} = case userPreference of + CUPContact {preference} -> preference + CUPUser {preference} -> preference + +assertDirectAllowed :: User -> MsgDirection -> Contact -> CMEventTag e -> CM () +assertDirectAllowed user dir ct event = + unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $ + throwChatError (CEDirectMessagesProhibited dir ct) + where + directMessagesAllowed = any (uncurry $ groupFeatureMemberAllowed' SGFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct) + allowedChatEvent = case event of + XMsgNew_ -> False + XMsgUpdate_ -> False + XMsgDel_ -> False + XFile_ -> False + XGrpInv_ -> False + XCallInv_ -> False + _ -> True + +startExpireCIThread :: User -> CM' () +startExpireCIThread user@User {userId} = do + expireThreads <- asks expireCIThreads + atomically (TM.lookup userId expireThreads) >>= \case + Nothing -> do + a <- Just <$> async runExpireCIs + atomically $ TM.insert userId a expireThreads + _ -> pure () + where + runExpireCIs = do + delay <- asks (initialCleanupManagerDelay . config) + liftIO $ threadDelay' delay + interval <- asks $ ciExpirationInterval . config + forever $ do + flip catchChatError' (toView' . CRChatError (Just user)) $ do + expireFlags <- asks expireCIFlags + atomically $ TM.lookup userId expireFlags >>= \b -> unless (b == Just True) retry + lift waitChatStartedAndActivated + ttl <- withStore' (`getChatItemTTL` user) + forM_ ttl $ \t -> expireChatItems user t False + liftIO $ threadDelay' interval + +setExpireCIFlag :: User -> Bool -> CM' () +setExpireCIFlag User {userId} b = do + expireFlags <- asks expireCIFlags + atomically $ TM.insert userId b expireFlags + +setAllExpireCIFlags :: Bool -> CM' () +setAllExpireCIFlags b = do + expireFlags <- asks expireCIFlags + atomically $ do + keys <- M.keys <$> readTVar expireFlags + forM_ keys $ \k -> TM.insert k b expireFlags + +agentSubscriber :: CM' () +agentSubscriber = do + q <- asks $ subQ . smpAgent + forever (atomically (readTBQueue q) >>= process) + `E.catchAny` \e -> do + toView' $ CRChatError Nothing $ ChatErrorAgent (CRITICAL True $ "Message reception stopped: " <> show e) Nothing + E.throwIO e + where + process :: (ACorrId, AEntityId, AEvt) -> CM' () + process (corrId, entId, AEvt e msg) = run $ case e of + SAENone -> processAgentMessageNoConn msg + SAEConn -> processAgentMessage corrId entId msg + SAERcvFile -> processAgentMsgRcvFile corrId entId msg + SAESndFile -> processAgentMsgSndFile corrId entId msg + where + run action = action `catchChatError'` (toView' . CRChatError Nothing) + +type AgentBatchSubscribe = AgentClient -> [ConnId] -> ExceptT AgentErrorType IO (Map ConnId (Either AgentErrorType ())) + +subscribeUserConnections :: VersionRangeChat -> Bool -> AgentBatchSubscribe -> User -> CM () +subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do + -- get user connections + ce <- asks $ subscriptionEvents . config + (conns, cts, ucs, gs, ms, sfts, rfts, pcs) <- + if onlyNeeded + then do + (conns, entities) <- withStore' (`getConnectionsToSubscribe` vr) + let (cts, ucs, ms, sfts, rfts, pcs) = foldl' addEntity (M.empty, M.empty, M.empty, M.empty, M.empty, M.empty) entities + pure (conns, cts, ucs, [], ms, sfts, rfts, pcs) + else do + withStore' unsetConnectionToSubscribe + (ctConns, cts) <- getContactConns + (ucConns, ucs) <- getUserContactLinkConns + (gs, mConns, ms) <- getGroupMemberConns + (sftConns, sfts) <- getSndFileTransferConns + (rftConns, rfts) <- getRcvFileTransferConns + (pcConns, pcs) <- getPendingContactConns + let conns = concat ([ctConns, ucConns, mConns, sftConns, rftConns, pcConns] :: [[ConnId]]) + pure (conns, cts, ucs, gs, ms, sfts, rfts, pcs) + -- subscribe using batched commands + rs <- withAgent $ \a -> agentBatchSubscribe a conns + -- send connection events to view + contactSubsToView rs cts ce + -- TODO possibly, we could either disable these events or replace with less noisy for API + contactLinkSubsToView rs ucs + groupSubsToView rs gs ms ce + sndFileSubsToView rs sfts + rcvFileSubsToView rs rfts + pendingConnSubsToView rs pcs + where + addEntity (cts, ucs, ms, sfts, rfts, pcs) = \case + RcvDirectMsgConnection c (Just ct) -> let cts' = addConn c ct cts in (cts', ucs, ms, sfts, rfts, pcs) + RcvDirectMsgConnection c Nothing -> let pcs' = addConn c (toPCC c) pcs in (cts, ucs, ms, sfts, rfts, pcs') + RcvGroupMsgConnection c _g m -> let ms' = addConn c m ms in (cts, ucs, ms', sfts, rfts, pcs) + SndFileConnection c sft -> let sfts' = addConn c sft sfts in (cts, ucs, ms, sfts', rfts, pcs) + RcvFileConnection c rft -> let rfts' = addConn c rft rfts in (cts, ucs, ms, sfts, rfts', pcs) + UserContactConnection c uc -> let ucs' = addConn c uc ucs in (cts, ucs', ms, sfts, rfts, pcs) + addConn :: Connection -> a -> Map ConnId a -> Map ConnId a + addConn = M.insert . aConnId + toPCC Connection {connId, agentConnId, connStatus, viaUserContactLink, groupLinkId, customUserProfileId, localAlias, createdAt} = + PendingContactConnection + { pccConnId = connId, + pccAgentConnId = agentConnId, + pccConnStatus = connStatus, + viaContactUri = False, + viaUserContactLink, + groupLinkId, + customUserProfileId, + connReqInv = Nothing, + localAlias, + createdAt, + updatedAt = createdAt + } + getContactConns :: CM ([ConnId], Map ConnId Contact) + getContactConns = do + cts <- withStore_ (`getUserContacts` vr) + let cts' = mapMaybe (\ct -> (,ct) <$> contactConnId ct) $ filter contactActive cts + pure (map fst cts', M.fromList cts') + getUserContactLinkConns :: CM ([ConnId], Map ConnId UserContact) + getUserContactLinkConns = do + (cs, ucs) <- unzip <$> withStore_ (`getUserContactLinks` vr) + let connIds = map aConnId cs + pure (connIds, M.fromList $ zip connIds ucs) + getGroupMemberConns :: CM ([Group], [ConnId], Map ConnId GroupMember) + getGroupMemberConns = do + gs <- withStore_ (`getUserGroups` vr) + let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) (filter (not . memberRemoved) ms)) gs + pure (gs, map fst mPairs, M.fromList mPairs) + getSndFileTransferConns :: CM ([ConnId], Map ConnId SndFileTransfer) + getSndFileTransferConns = do + sfts <- withStore_ getLiveSndFileTransfers + let connIds = map sndFileTransferConnId sfts + pure (connIds, M.fromList $ zip connIds sfts) + getRcvFileTransferConns :: CM ([ConnId], Map ConnId RcvFileTransfer) + getRcvFileTransferConns = do + rfts <- withStore_ getLiveRcvFileTransfers + let rftPairs = mapMaybe (\ft -> (,ft) <$> liveRcvFileTransferConnId ft) rfts + pure (map fst rftPairs, M.fromList rftPairs) + getPendingContactConns :: CM ([ConnId], Map ConnId PendingContactConnection) + getPendingContactConns = do + pcs <- withStore_ getPendingContactConnections + let connIds = map aConnId' pcs + pure (connIds, M.fromList $ zip connIds pcs) + contactSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId Contact -> Bool -> CM () + contactSubsToView rs cts ce = do + chatModifyVar connNetworkStatuses $ M.union (M.fromList statuses) + ifM (asks $ coreApi . config) (notifyAPI statuses) notifyCLI + where + notifyCLI = do + let cRs = resultsFor rs cts + cErrors = sortOn (\(Contact {localDisplayName = n}, _) -> n) $ filterErrors cRs + toView . CRContactSubSummary user $ map (uncurry ContactSubStatus) cRs + when ce $ mapM_ (toView . uncurry (CRContactSubError user)) cErrors + notifyAPI = toView . CRNetworkStatuses (Just user) . map (uncurry ConnNetworkStatus) + statuses = M.foldrWithKey' addStatus [] cts + where + addStatus :: ConnId -> Contact -> [(AgentConnId, NetworkStatus)] -> [(AgentConnId, NetworkStatus)] + addStatus _ Contact {activeConn = Nothing} nss = nss + addStatus connId Contact {activeConn = Just Connection {agentConnId}} nss = + let ns = (agentConnId, netStatus $ resultErr connId rs) + in ns : nss + netStatus :: Maybe ChatError -> NetworkStatus + netStatus = maybe NSConnected $ NSError . errorNetworkStatus + errorNetworkStatus :: ChatError -> String + errorNetworkStatus = \case + ChatErrorAgent (BROKER _ NETWORK) _ -> "network" + ChatErrorAgent (SMP _ SMP.AUTH) _ -> "contact deleted" + e -> show e + -- TODO possibly below could be replaced with less noisy events for API + contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> CM () + contactLinkSubsToView rs = toView . CRUserContactSubSummary user . map (uncurry UserContactSubStatus) . resultsFor rs + groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> CM () + groupSubsToView rs gs ms ce = do + mapM_ groupSub $ + sortOn (\(Group GroupInfo {localDisplayName = g} _) -> g) gs + toView . CRMemberSubSummary user $ map (uncurry MemberSubStatus) mRs + where + mRs = resultsFor rs ms + groupSub :: Group -> CM () + groupSub (Group g@GroupInfo {membership, groupId = gId} members) = do + when ce $ mapM_ (toView . uncurry (CRMemberSubError user g)) mErrors + toView groupEvent + where + mErrors :: [(GroupMember, ChatError)] + mErrors = + sortOn (\(GroupMember {localDisplayName = n}, _) -> n) + . filterErrors + $ filter (\(GroupMember {groupId}, _) -> groupId == gId) mRs + groupEvent :: ChatResponse + groupEvent + | memberStatus membership == GSMemInvited = CRGroupInvitation user g + | all (\GroupMember {activeConn} -> isNothing activeConn) members = + if memberActive membership + then CRGroupEmpty user g + else CRGroupRemoved user g + | otherwise = CRGroupSubscribed user g + sndFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId SndFileTransfer -> CM () + sndFileSubsToView rs sfts = do + let sftRs = resultsFor rs sfts + forM_ sftRs $ \(ft@SndFileTransfer {fileId, fileStatus}, err_) -> do + forM_ err_ $ toView . CRSndFileSubError user ft + void . forkIO $ do + threadDelay 1000000 + when (fileStatus == FSConnected) . unlessM (isFileActive fileId sndFiles) . withChatLock "subscribe sendFileChunk" $ + sendFileChunk user ft + rcvFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId RcvFileTransfer -> CM () + rcvFileSubsToView rs = mapM_ (toView . uncurry (CRRcvFileSubError user)) . filterErrors . resultsFor rs + pendingConnSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId PendingContactConnection -> CM () + pendingConnSubsToView rs = toView . CRPendingSubSummary user . map (uncurry PendingSubStatus) . resultsFor rs + withStore_ :: (DB.Connection -> User -> IO [a]) -> CM [a] + withStore_ a = withStore' (`a` user) `catchChatError` \e -> toView (CRChatError (Just user) e) $> [] + filterErrors :: [(a, Maybe ChatError)] -> [(a, ChatError)] + filterErrors = mapMaybe (\(a, e_) -> (a,) <$> e_) + resultsFor :: Map ConnId (Either AgentErrorType ()) -> Map ConnId a -> [(a, Maybe ChatError)] + resultsFor rs = M.foldrWithKey' addResult [] + where + addResult :: ConnId -> a -> [(a, Maybe ChatError)] -> [(a, Maybe ChatError)] + addResult connId = (:) . (,resultErr connId rs) + resultErr :: ConnId -> Map ConnId (Either AgentErrorType ()) -> Maybe ChatError + resultErr connId rs = case M.lookup connId rs of + Just (Left e) -> Just $ ChatErrorAgent e Nothing + Just _ -> Nothing + _ -> Just . ChatError . CEAgentNoSubResult $ AgentConnId connId + +cleanupManager :: CM () +cleanupManager = do + interval <- asks (cleanupManagerInterval . config) + runWithoutInitialDelay interval + initialDelay <- asks (initialCleanupManagerDelay . config) + liftIO $ threadDelay' initialDelay + stepDelay <- asks (cleanupManagerStepDelay . config) + forever $ do + flip catchChatError (toView . CRChatError Nothing) $ do + lift waitChatStartedAndActivated + users <- withStore' getUsers + let (us, us') = partition activeUser users + forM_ us $ cleanupUser interval stepDelay + forM_ us' $ cleanupUser interval stepDelay + cleanupMessages `catchChatError` (toView . CRChatError Nothing) + -- TODO possibly, also cleanup async commands + cleanupProbes `catchChatError` (toView . CRChatError Nothing) + liftIO $ threadDelay' $ diffToMicroseconds interval + where + runWithoutInitialDelay cleanupInterval = flip catchChatError (toView . CRChatError Nothing) $ do + lift waitChatStartedAndActivated + users <- withStore' getUsers + let (us, us') = partition activeUser users + forM_ us $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` (toView . CRChatError (Just u)) + forM_ us' $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` (toView . CRChatError (Just u)) + cleanupUser cleanupInterval stepDelay user = do + cleanupTimedItems cleanupInterval user `catchChatError` (toView . CRChatError (Just user)) + liftIO $ threadDelay' stepDelay + cleanupDeletedContacts user `catchChatError` (toView . CRChatError (Just user)) + liftIO $ threadDelay' stepDelay + cleanupTimedItems cleanupInterval user = do + ts <- liftIO getCurrentTime + let startTimedThreadCutoff = addUTCTime cleanupInterval ts + timedItems <- withStore' $ \db -> getTimedItems db user startTimedThreadCutoff + forM_ timedItems $ \(itemRef, deleteAt) -> startTimedItemThread user itemRef deleteAt `catchChatError` const (pure ()) + cleanupDeletedContacts user = do + vr <- chatVersionRange + contacts <- withStore' $ \db -> getDeletedContacts db vr user + forM_ contacts $ \ct -> + withStore (\db -> deleteContactWithoutGroups db user ct) + `catchChatError` (toView . CRChatError (Just user)) + cleanupMessages = do + ts <- liftIO getCurrentTime + let cutoffTs = addUTCTime (-(30 * nominalDay)) ts + withStore' (`deleteOldMessages` cutoffTs) + cleanupProbes = do + ts <- liftIO getCurrentTime + let cutoffTs = addUTCTime (-(14 * nominalDay)) ts + withStore' (`deleteOldProbes` cutoffTs) + +expireChatItems :: User -> Int64 -> Bool -> CM () +expireChatItems user@User {userId} ttl sync = do + currentTs <- liftIO getCurrentTime + vr <- chatVersionRange + let expirationDate = addUTCTime (-1 * fromIntegral ttl) currentTs + -- this is to keep group messages created during last 12 hours even if they're expired according to item_ts + createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs + lift waitChatStartedAndActivated + contacts <- withStore' $ \db -> getUserContacts db vr user + loop contacts $ processContact expirationDate + lift waitChatStartedAndActivated + groups <- withStore' $ \db -> getUserGroupDetails db vr user Nothing Nothing + loop groups $ processGroup vr expirationDate createdAtCutoff + where + loop :: [a] -> (a -> CM ()) -> CM () + loop [] _ = pure () + loop (a : as) process = continue $ do + process a `catchChatError` (toView . CRChatError (Just user)) + loop as process + continue :: CM () -> CM () + continue a = + if sync + then a + else do + expireFlags <- asks expireCIFlags + expire <- atomically $ TM.lookup userId expireFlags + when (expire == Just True) $ threadDelay 100000 >> a + processContact :: UTCTime -> Contact -> CM () + processContact expirationDate ct = do + lift waitChatStartedAndActivated + filesInfo <- withStore' $ \db -> getContactExpiredFileInfo db user ct expirationDate + cancelFilesInProgress user filesInfo + deleteFilesLocally filesInfo + withStore' $ \db -> deleteContactExpiredCIs db user ct expirationDate + processGroup :: VersionRangeChat -> UTCTime -> UTCTime -> GroupInfo -> CM () + processGroup vr expirationDate createdAtCutoff gInfo = do + lift waitChatStartedAndActivated + filesInfo <- withStore' $ \db -> getGroupExpiredFileInfo db user gInfo expirationDate createdAtCutoff + cancelFilesInProgress user filesInfo + deleteFilesLocally filesInfo + withStore' $ \db -> deleteGroupExpiredCIs db user gInfo expirationDate createdAtCutoff + membersToDelete <- withStore' $ \db -> getGroupMembersForExpiration db vr user gInfo + forM_ membersToDelete $ \m -> withStore' $ \db -> deleteGroupMember db user m + +chatCommandP :: Parser ChatCommand +chatCommandP = + choice + [ "/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, + "/_user " *> (APISetActiveUser <$> A.decimal <*> optional (A.space *> jsonP)), + ("/user " <|> "/u ") *> (SetActiveUser <$> displayName <*> optional (A.space *> pwdP)), + "/set receipts all " *> (SetAllContactReceipts <$> onOffP), + "/_set receipts contacts " *> (APISetUserContactReceipts <$> A.decimal <* A.space <*> receiptSettings), + "/set receipts contacts " *> (SetUserContactReceipts <$> receiptSettings), + "/_set receipts groups " *> (APISetUserGroupReceipts <$> A.decimal <* A.space <*> receiptSettings), + "/set receipts groups " *> (SetUserGroupReceipts <$> receiptSettings), + "/_hide user " *> (APIHideUser <$> A.decimal <* A.space <*> jsonP), + "/_unhide user " *> (APIUnhideUser <$> A.decimal <* A.space <*> jsonP), + "/_mute user " *> (APIMuteUser <$> A.decimal), + "/_unmute user " *> (APIUnmuteUser <$> A.decimal), + "/hide user " *> (HideUser <$> pwdP), + "/unhide user " *> (UnhideUser <$> pwdP), + "/mute user" $> MuteUser, + "/unmute user" $> UnmuteUser, + "/_delete user " *> (APIDeleteUser <$> A.decimal <* " del_smp=" <*> onOffP <*> optional (A.space *> jsonP)), + "/delete user " *> (DeleteUser <$> displayName <*> pure True <*> optional (A.space *> pwdP)), + ("/user" <|> "/u") $> ShowActiveUser, + "/_start " *> do + mainApp <- "main=" *> onOffP + enableSndFiles <- " snd_files=" *> onOffP <|> pure mainApp + pure StartChat {mainApp, enableSndFiles}, + "/_start" $> StartChat True True, + "/_check running" $> CheckChatRunning, + "/_stop" $> APIStopChat, + "/_app activate restore=" *> (APIActivateChat <$> onOffP), + "/_app activate" $> APIActivateChat True, + "/_app suspend " *> (APISuspendChat <$> A.decimal), + "/_resubscribe all" $> ResubscribeAllConnections, + -- deprecated, use /set file paths + "/_temp_folder " *> (SetTempFolder <$> filePath), + -- /_files_folder deprecated, use /set file paths + ("/_files_folder " <|> "/files_folder ") *> (SetFilesFolder <$> filePath), + -- deprecated, use /set file paths + "/remote_hosts_folder " *> (SetRemoteHostsFolder <$> filePath), + "/set file paths " *> (APISetAppFilePaths <$> jsonP), + "/_files_encrypt " *> (APISetEncryptLocalFiles <$> onOffP), + "/contact_merge " *> (SetContactMergeEnabled <$> onOffP), + "/_db export " *> (APIExportArchive <$> jsonP), + "/db export" $> ExportArchive, + "/_db import " *> (APIImportArchive <$> jsonP), + "/_db delete" $> APIDeleteStorage, + "/_db encryption " *> (APIStorageEncryption <$> jsonP), + "/db encrypt " *> (APIStorageEncryption . dbEncryptionConfig "" <$> dbKeyP), + "/db key " *> (APIStorageEncryption <$> (dbEncryptionConfig <$> dbKeyP <* A.space <*> dbKeyP)), + "/db decrypt " *> (APIStorageEncryption . (`dbEncryptionConfig` "") <$> dbKeyP), + "/db test key " *> (TestStorageEncryption <$> dbKeyP), + "/_save app settings" *> (APISaveAppSettings <$> jsonP), + "/_get app settings" *> (APIGetAppSettings <$> optional (A.space *> jsonP)), + "/sql chat " *> (ExecChatStoreSQL <$> textP), + "/sql agent " *> (ExecAgentStoreSQL <$> textP), + "/sql slow" $> SlowSQLQueries, + "/_get tags " *> (APIGetChatTags <$> A.decimal), + "/_get chats " + *> ( APIGetChats + <$> A.decimal + <*> (" pcc=on" $> True <|> " pcc=off" $> False <|> pure False) + <*> (A.space *> paginationByTimeP <|> pure (PTLast 5000)) + <*> (A.space *> jsonP <|> pure clqNoFilters) + ), + "/_get chat " *> (APIGetChat <$> chatRefP <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)), + "/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)), + "/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal), + "/_send " *> (APISendMessages <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), + "/_create tag " *> (APICreateChatTag <$> jsonP), + "/_tags " *> (APISetChatTags <$> chatRefP <*> optional _strP), + "/_delete tag " *> (APIDeleteChatTag <$> A.decimal), + "/_update tag " *> (APIUpdateChatTag <$> A.decimal <* A.space <*> jsonP), + "/_reorder tags " *> (APIReorderChatTags <$> strP), + "/_create *" *> (APICreateChatItems <$> A.decimal <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), + "/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP), + "/_delete item " *> (APIDeleteChatItem <$> chatRefP <*> _strP <* A.space <*> ciDeleteMode), + "/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <*> _strP), + "/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP), + "/_reaction members " *> (APIGetReactionMembers <$> A.decimal <* " #" <*> A.decimal <* A.space <*> A.decimal <* A.space <*> jsonP), + "/_forward plan " *> (APIPlanForwardChatItems <$> chatRefP <*> _strP), + "/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP), + "/_read user " *> (APIUserRead <$> A.decimal), + "/read user" $> UserRead, + "/_read chat " *> (APIChatRead <$> chatRefP), + "/_read chat items " *> (APIChatItemsRead <$> chatRefP <*> _strP), + "/_unread chat " *> (APIChatUnread <$> chatRefP <* A.space <*> onOffP), + "/_delete " *> (APIDeleteChat <$> chatRefP <*> chatDeleteMode), + "/_clear chat " *> (APIClearChat <$> chatRefP), + "/_accept" *> (APIAcceptContact <$> incognitoOnOffP <* A.space <*> A.decimal), + "/_reject " *> (APIRejectContact <$> A.decimal), + "/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP), + "/call " *> char_ '@' *> (SendCallInvitation <$> displayName <*> pure defaultCallType), + "/_call reject @" *> (APIRejectCall <$> A.decimal), + "/_call offer @" *> (APISendCallOffer <$> A.decimal <* A.space <*> jsonP), + "/_call answer @" *> (APISendCallAnswer <$> A.decimal <* A.space <*> jsonP), + "/_call extra @" *> (APISendCallExtraInfo <$> A.decimal <* A.space <*> jsonP), + "/_call end @" *> (APIEndCall <$> A.decimal), + "/_call status @" *> (APICallStatus <$> A.decimal <* A.space <*> strP), + "/_call get" $> APIGetCallInvitations, + "/_network_statuses" $> APIGetNetworkStatuses, + "/_profile " *> (APIUpdateProfile <$> A.decimal <* A.space <*> jsonP), + "/_set alias @" *> (APISetContactAlias <$> A.decimal <*> (A.space *> textP <|> pure "")), + "/_set alias :" *> (APISetConnectionAlias <$> A.decimal <*> (A.space *> textP <|> pure "")), + "/_set prefs @" *> (APISetContactPrefs <$> A.decimal <* A.space <*> jsonP), + "/_set theme user " *> (APISetUserUIThemes <$> A.decimal <*> optional (A.space *> jsonP)), + "/_set theme " *> (APISetChatUIThemes <$> chatRefP <*> optional (A.space *> jsonP)), + "/_parse " *> (APIParseMarkdown . safeDecodeUtf8 <$> A.takeByteString), + "/_ntf get" $> APIGetNtfToken, + "/_ntf register " *> (APIRegisterToken <$> strP_ <*> strP), + "/_ntf verify " *> (APIVerifyToken <$> strP <* A.space <*> strP <* A.space <*> strP), + "/_ntf delete " *> (APIDeleteToken <$> strP), + "/_ntf conns " *> (APIGetNtfConns <$> strP <* A.space <*> strP), + "/_ntf conn messages " *> (ApiGetConnNtfMessages <$> strP), + "/_add #" *> (APIAddMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole), + "/_join #" *> (APIJoinGroup <$> A.decimal), + "/_member role #" *> (APIMemberRole <$> A.decimal <* A.space <*> A.decimal <*> memberRole), + "/_block #" *> (APIBlockMemberForAll <$> A.decimal <* A.space <*> A.decimal <* A.space <* "blocked=" <*> onOffP), + "/_remove #" *> (APIRemoveMember <$> A.decimal <* A.space <*> A.decimal), + "/_leave #" *> (APILeaveGroup <$> A.decimal), + "/_members #" *> (APIListMembers <$> A.decimal), + "/_server test " *> (APITestProtoServer <$> A.decimal <* A.space <*> strP), + "/smp test " *> (TestProtoServer . AProtoServerWithAuth SPSMP <$> strP), + "/xftp test " *> (TestProtoServer . AProtoServerWithAuth SPXFTP <$> strP), + "/ntf test " *> (TestProtoServer . AProtoServerWithAuth SPNTF <$> strP), + "/smp " *> (SetUserProtoServers (AProtocolType SPSMP) . map (AProtoServerWithAuth SPSMP) <$> protocolServersP), + "/xftp " *> (SetUserProtoServers (AProtocolType SPXFTP) . map (AProtoServerWithAuth SPXFTP) <$> protocolServersP), + "/smp" $> GetUserProtoServers (AProtocolType SPSMP), + "/xftp" $> GetUserProtoServers (AProtocolType SPXFTP), + "/_operators" $> APIGetServerOperators, + "/_operators " *> (APISetServerOperators <$> jsonP), + "/operators " *> (SetServerOperators . L.fromList <$> operatorRolesP `A.sepBy1` A.char ','), + "/_servers " *> (APIGetUserServers <$> A.decimal), + "/_servers " *> (APISetUserServers <$> A.decimal <* A.space <*> jsonP), + "/_validate_servers " *> (APIValidateServers <$> A.decimal <* A.space <*> jsonP), + "/_conditions" $> APIGetUsageConditions, + "/_conditions_notified " *> (APISetConditionsNotified <$> A.decimal), + "/_accept_conditions " *> (APIAcceptConditions <$> A.decimal <*> _strP), + "/_ttl " *> (APISetChatItemTTL <$> A.decimal <* A.space <*> ciTTLDecimal), + "/ttl " *> (SetChatItemTTL <$> ciTTL), + "/_ttl " *> (APIGetChatItemTTL <$> A.decimal), + "/ttl" $> GetChatItemTTL, + "/_network info " *> (APISetNetworkInfo <$> jsonP), + "/_network " *> (APISetNetworkConfig <$> jsonP), + ("/network " <|> "/net ") *> (SetNetworkConfig <$> netCfgP), + ("/network" <|> "/net") $> APIGetNetworkConfig, + "/reconnect " *> (ReconnectServer <$> A.decimal <* A.space <*> strP), + "/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), + ("/info #" <|> "/i #") *> (GroupMemberInfo <$> displayName <* A.space <* char_ '@' <*> displayName), + ("/info #" <|> "/i #") *> (ShowGroupInfo <$> displayName), + ("/info " <|> "/i ") *> char_ '@' *> (ContactInfo <$> displayName), + "/_queue info #" *> (APIGroupMemberQueueInfo <$> A.decimal <* A.space <*> A.decimal), + "/_queue info @" *> (APIContactQueueInfo <$> A.decimal), + ("/queue info #" <|> "/qi #") *> (GroupMemberQueueInfo <$> displayName <* A.space <* char_ '@' <*> displayName), + ("/queue info " <|> "/qi ") *> char_ '@' *> (ContactQueueInfo <$> displayName), + "/_switch #" *> (APISwitchGroupMember <$> A.decimal <* A.space <*> A.decimal), + "/_switch @" *> (APISwitchContact <$> A.decimal), + "/_abort switch #" *> (APIAbortSwitchGroupMember <$> A.decimal <* A.space <*> A.decimal), + "/_abort switch @" *> (APIAbortSwitchContact <$> A.decimal), + "/_sync #" *> (APISyncGroupMemberRatchet <$> A.decimal <* A.space <*> A.decimal <*> (" force=on" $> True <|> pure False)), + "/_sync @" *> (APISyncContactRatchet <$> A.decimal <*> (" force=on" $> True <|> pure False)), + "/switch #" *> (SwitchGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName), + "/switch " *> char_ '@' *> (SwitchContact <$> displayName), + "/abort switch #" *> (AbortSwitchGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName), + "/abort switch " *> char_ '@' *> (AbortSwitchContact <$> displayName), + "/sync #" *> (SyncGroupMemberRatchet <$> displayName <* A.space <* char_ '@' <*> displayName <*> (" force=on" $> True <|> pure False)), + "/sync " *> char_ '@' *> (SyncContactRatchet <$> displayName <*> (" force=on" $> True <|> pure False)), + "/_get code @" *> (APIGetContactCode <$> A.decimal), + "/_get code #" *> (APIGetGroupMemberCode <$> A.decimal <* A.space <*> A.decimal), + "/_verify code @" *> (APIVerifyContact <$> A.decimal <*> optional (A.space *> verifyCodeP)), + "/_verify code #" *> (APIVerifyGroupMember <$> A.decimal <* A.space <*> A.decimal <*> optional (A.space *> verifyCodeP)), + "/_enable @" *> (APIEnableContact <$> A.decimal), + "/_enable #" *> (APIEnableGroupMember <$> A.decimal <* A.space <*> A.decimal), + "/code " *> char_ '@' *> (GetContactCode <$> displayName), + "/code #" *> (GetGroupMemberCode <$> displayName <* A.space <* char_ '@' <*> displayName), + "/verify " *> char_ '@' *> (VerifyContact <$> displayName <*> optional (A.space *> verifyCodeP)), + "/verify #" *> (VerifyGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> optional (A.space *> verifyCodeP)), + "/enable " *> char_ '@' *> (EnableContact <$> displayName), + "/enable #" *> (EnableGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName), + ("/help files" <|> "/help file" <|> "/hf") $> ChatHelp HSFiles, + ("/help groups" <|> "/help group" <|> "/hg") $> ChatHelp HSGroups, + ("/help contacts" <|> "/help contact" <|> "/hc") $> ChatHelp HSContacts, + ("/help address" <|> "/ha") $> ChatHelp HSMyAddress, + ("/help incognito" <|> "/hi") $> ChatHelp HSIncognito, + ("/help messages" <|> "/hm") $> ChatHelp HSMessages, + ("/help remote" <|> "/hr") $> ChatHelp HSRemote, + ("/help settings" <|> "/hs") $> ChatHelp HSSettings, + ("/help db" <|> "/hd") $> ChatHelp HSDatabase, + ("/help" <|> "/h") $> ChatHelp HSMain, + ("/group" <|> "/g") *> (NewGroup <$> incognitoP <* A.space <* char_ '#' <*> groupProfile), + "/_group " *> (APINewGroup <$> A.decimal <*> incognitoOnOffP <* A.space <*> jsonP), + ("/add " <|> "/a ") *> char_ '#' *> (AddMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> (memberRole <|> pure GRMember)), + ("/join " <|> "/j ") *> char_ '#' *> (JoinGroup <$> displayName), + ("/member role " <|> "/mr ") *> char_ '#' *> (MemberRole <$> displayName <* A.space <* char_ '@' <*> displayName <*> memberRole), + "/block for all #" *> (BlockForAll <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure True), + "/unblock for all #" *> (BlockForAll <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure False), + ("/remove " <|> "/rm ") *> char_ '#' *> (RemoveMember <$> displayName <* A.space <* char_ '@' <*> displayName), + ("/leave " <|> "/l ") *> char_ '#' *> (LeaveGroup <$> displayName), + ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName), + ("/delete " <|> "/d ") *> char_ '@' *> (DeleteContact <$> displayName <*> chatDeleteMode), + "/clear *" $> ClearNoteFolder, + "/clear #" *> (ClearGroup <$> displayName), + "/clear " *> char_ '@' *> (ClearContact <$> displayName), + ("/members " <|> "/ms ") *> char_ '#' *> (ListMembers <$> displayName), + "/_groups" *> (APIListGroups <$> A.decimal <*> optional (" @" *> A.decimal) <*> optional (A.space *> stringP)), + ("/groups" <|> "/gs") *> (ListGroups <$> optional (" @" *> displayName) <*> optional (A.space *> stringP)), + "/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP), + ("/group_profile " <|> "/gp ") *> char_ '#' *> (UpdateGroupNames <$> displayName <* A.space <*> groupProfile), + ("/group_profile " <|> "/gp ") *> char_ '#' *> (ShowGroupProfile <$> displayName), + "/group_descr " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> optional (A.space *> msgTextP)), + "/set welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayName <* A.space <*> (Just <$> msgTextP)), + "/delete welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> pure Nothing), + "/show welcome " *> char_ '#' *> (ShowGroupDescription <$> displayName), + "/_create link #" *> (APICreateGroupLink <$> A.decimal <*> (memberRole <|> pure GRMember)), + "/_set link role #" *> (APIGroupLinkMemberRole <$> A.decimal <*> memberRole), + "/_delete link #" *> (APIDeleteGroupLink <$> A.decimal), + "/_get link #" *> (APIGetGroupLink <$> A.decimal), + "/create link #" *> (CreateGroupLink <$> displayName <*> (memberRole <|> pure GRMember)), + "/set link role #" *> (GroupLinkMemberRole <$> displayName <*> memberRole), + "/delete link #" *> (DeleteGroupLink <$> displayName), + "/show link #" *> (ShowGroupLink <$> displayName), + "/_create member contact #" *> (APICreateMemberContact <$> A.decimal <* A.space <*> A.decimal), + "/_invite member contact @" *> (APISendMemberContactInvitation <$> A.decimal <*> optional (A.space *> msgContentP)), + (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> msgTextP), + (">#" <|> "> #") *> (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), + "/_set conn user :" *> (APIChangeConnectionUser <$> A.decimal <* A.space <*> A.decimal), + ("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeTill isSpace $> Nothing)), + ("/connect" <|> "/c") *> (AddContact <$> incognitoP), + ForwardMessage <$> chatNameP <* " <- @" <*> displayName <* A.space <*> msgTextP, + ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayName <* A.space <* A.char '@' <*> (Just <$> displayName) <* A.space <*> msgTextP, + ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayName <*> pure Nothing <* A.space <*> msgTextP, + ForwardLocalMessage <$> chatNameP <* " <- * " <*> msgTextP, + SendMessage <$> chatNameP <* A.space <*> msgTextP, + "/* " *> (SendMessage (ChatName CTLocal "") <$> msgTextP), + "@#" *> (SendMemberContactMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> msgTextP), + "/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> msgTextP <|> pure "")), + (">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv), + (">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd), + ("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> textP), + ("\\\\ #" <|> "\\\\#") *> (DeleteMemberMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> textP), + ("! " <|> "!") *> (EditMessage <$> chatNameP <* A.space <*> (quotedMsg <|> pure "") <*> msgTextP), + ReactToMessage <$> (("+" $> True) <|> ("-" $> False)) <*> reactionP <* A.space <*> chatNameP' <* A.space <*> textP, + "/feed " *> (SendMessageBroadcast <$> msgTextP), + ("/chats" <|> "/cs") *> (LastChats <$> (" all" $> Nothing <|> Just <$> (A.space *> A.decimal <|> pure 20))), + ("/tail" <|> "/t") *> (LastMessages <$> optional (A.space *> chatNameP) <*> msgCountP <*> pure Nothing), + ("/search" <|> "/?") *> (LastMessages <$> optional (A.space *> chatNameP) <*> msgCountP <*> (Just <$> (A.space *> stringP))), + "/last_item_id" *> (LastChatItemId <$> optional (A.space *> chatNameP) <*> (A.space *> A.decimal <|> pure 0)), + "/show" *> (ShowLiveItems <$> (A.space *> onOffP <|> pure True)), + "/show " *> (ShowChatItem . Just <$> A.decimal), + "/item info " *> (ShowChatItemInfo <$> chatNameP <* A.space <*> msgTextP), + ("/file " <|> "/f ") *> (SendFile <$> chatNameP' <* A.space <*> cryptoFileP), + ("/image " <|> "/img ") *> (SendImage <$> chatNameP' <* A.space <*> cryptoFileP), + ("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal), + ("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal), + ("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath), + ("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> (" approved_relays=" *> onOffP <|> pure False) <*> optional (" encrypt=" *> onOffP) <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)), + "/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal <*> (" approved_relays=" *> onOffP <|> pure False) <*> optional (" encrypt=" *> onOffP)), + ("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal), + ("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal), + "/_connect contact " *> (APIConnectContactViaAddress <$> A.decimal <*> incognitoOnOffP <* A.space <*> A.decimal), + "/simplex" *> (ConnectSimplex <$> incognitoP), + "/_address " *> (APICreateMyAddress <$> A.decimal), + ("/address" <|> "/ad") $> CreateMyAddress, + "/_delete_address " *> (APIDeleteMyAddress <$> A.decimal), + ("/delete_address" <|> "/da") $> DeleteMyAddress, + "/_show_address " *> (APIShowMyAddress <$> A.decimal), + ("/show_address" <|> "/sa") $> ShowMyAddress, + "/_profile_address " *> (APISetProfileAddress <$> A.decimal <* A.space <*> onOffP), + ("/profile_address " <|> "/pa ") *> (SetProfileAddress <$> onOffP), + "/_auto_accept " *> (APIAddressAutoAccept <$> A.decimal <* A.space <*> autoAcceptP), + "/auto_accept " *> (AddressAutoAccept <$> autoAcceptP), + ("/accept" <|> "/ac") *> (AcceptContact <$> incognitoP <* A.space <* char_ '@' <*> displayName), + ("/reject " <|> "/rc ") *> char_ '@' *> (RejectContact <$> displayName), + ("/markdown" <|> "/m") $> ChatHelp HSMarkdown, + ("/welcome" <|> "/w") $> Welcome, + "/set profile image " *> (UpdateProfileImage . Just . ImageData <$> imageP), + "/delete profile image" $> UpdateProfileImage Nothing, + "/show profile image" $> ShowProfileImage, + ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> profileNames), + ("/profile" <|> "/p") $> ShowProfile, + "/set voice #" *> (SetGroupFeatureRole (AGFR SGFVoice) <$> displayName <*> _strP <*> optional memberRole), + "/set voice @" *> (SetContactFeature (ACF SCFVoice) <$> displayName <*> optional (A.space *> strP)), + "/set voice " *> (SetUserFeature (ACF SCFVoice) <$> strP), + "/set files #" *> (SetGroupFeatureRole (AGFR SGFFiles) <$> displayName <*> _strP <*> optional memberRole), + "/set history #" *> (SetGroupFeature (AGFNR SGFHistory) <$> displayName <*> (A.space *> strP)), + "/set reactions #" *> (SetGroupFeature (AGFNR SGFReactions) <$> displayName <*> (A.space *> strP)), + "/set calls @" *> (SetContactFeature (ACF SCFCalls) <$> displayName <*> optional (A.space *> strP)), + "/set calls " *> (SetUserFeature (ACF SCFCalls) <$> strP), + "/set delete #" *> (SetGroupFeature (AGFNR SGFFullDelete) <$> displayName <*> (A.space *> strP)), + "/set delete @" *> (SetContactFeature (ACF SCFFullDelete) <$> displayName <*> optional (A.space *> strP)), + "/set delete " *> (SetUserFeature (ACF SCFFullDelete) <$> strP), + "/set direct #" *> (SetGroupFeatureRole (AGFR SGFDirectMessages) <$> displayName <*> _strP <*> optional memberRole), + "/set disappear #" *> (SetGroupTimedMessages <$> displayName <*> (A.space *> timedTTLOnOffP)), + "/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)), + "/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))), + "/set links #" *> (SetGroupFeatureRole (AGFR SGFSimplexLinks) <$> displayName <*> _strP <*> optional memberRole), + ("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito, + "/set device name " *> (SetLocalDeviceName <$> textP), + "/list remote hosts" $> ListRemoteHosts, + "/switch remote host " *> (SwitchRemoteHost <$> ("local" $> Nothing <|> (Just <$> A.decimal))), + "/start remote host " *> (StartRemoteHost <$> ("new" $> Nothing <|> (Just <$> ((,) <$> A.decimal <*> (" multicast=" *> onOffP <|> pure False)))) <*> optional (A.space *> rcCtrlAddressP) <*> optional (" port=" *> A.decimal)), + "/stop remote host " *> (StopRemoteHost <$> ("new" $> RHNew <|> RHId <$> A.decimal)), + "/delete remote host " *> (DeleteRemoteHost <$> A.decimal), + "/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath), + "/get remote file " *> (GetRemoteFile <$> A.decimal <* A.space <*> jsonP), + ("/connect remote ctrl " <|> "/crc ") *> (ConnectRemoteCtrl <$> strP), + "/find remote ctrl" $> FindKnownRemoteCtrl, + "/confirm remote ctrl " *> (ConfirmRemoteCtrl <$> A.decimal), + "/verify remote ctrl " *> (VerifyRemoteCtrlSession <$> textP), + "/list remote ctrls" $> ListRemoteCtrls, + "/stop remote ctrl" $> StopRemoteCtrl, + "/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal), + "/_upload " *> (APIUploadStandaloneFile <$> A.decimal <* A.space <*> cryptoFileP), + "/_download info " *> (APIStandaloneFileInfo <$> strP), + "/_download " *> (APIDownloadStandaloneFile <$> A.decimal <* A.space <*> strP_ <*> cryptoFileP), + ("/quit" <|> "/q" <|> "/exit") $> QuitChat, + ("/version" <|> "/v") $> ShowVersion, + "/debug locks" $> DebugLocks, + "/debug event " *> (DebugEvent <$> jsonP), + "/get subs total " *> (GetAgentSubsTotal <$> A.decimal), + "/get servers summary " *> (GetAgentServersSummary <$> A.decimal), + "/reset servers stats" $> ResetAgentServersStats, + "/get subs" $> GetAgentSubs, + "/get subs details" $> GetAgentSubsDetails, + "/get workers" $> GetAgentWorkers, + "/get workers details" $> GetAgentWorkersDetails, + "/get queues" $> GetAgentQueuesInfo, + "//" *> (CustomChatCommand <$> A.takeByteString) + ] + where + choice = A.choice . map (\p -> p <* A.takeWhile (== ' ') <* A.endOfInput) + incognitoP = (A.space *> ("incognito" <|> "i")) $> True <|> pure False + incognitoOnOffP = (A.space *> "incognito=" *> onOffP) <|> pure False + imagePrefix = (<>) <$> "data:" <*> ("image/png;base64," <|> "image/jpg;base64,") + imageP = safeDecodeUtf8 <$> ((<>) <$> imagePrefix <*> (B64.encode <$> base64P)) + chatTypeP = A.char '@' $> CTDirect <|> A.char '#' $> CTGroup <|> A.char '*' $> CTLocal <|> A.char ':' $> CTContactConnection + chatPaginationP = + (CPLast <$ "count=" <*> A.decimal) + <|> (CPAfter <$ "after=" <*> A.decimal <* A.space <* "count=" <*> A.decimal) + <|> (CPBefore <$ "before=" <*> A.decimal <* A.space <* "count=" <*> A.decimal) + <|> (CPAround <$ "around=" <*> A.decimal <* A.space <* "count=" <*> A.decimal) + <|> (CPInitial <$ "initial=" <*> A.decimal) + paginationByTimeP = + (PTLast <$ "count=" <*> A.decimal) + <|> (PTAfter <$ "after=" <*> strP <* A.space <* "count=" <*> A.decimal) + <|> (PTBefore <$ "before=" <*> strP <* A.space <* "count=" <*> A.decimal) + mcTextP = MCText . safeDecodeUtf8 <$> A.takeByteString + msgContentP = "text " *> mcTextP <|> "json " *> jsonP + ciDeleteMode = "broadcast" $> CIDMBroadcast <|> "internal" $> CIDMInternal + chatDeleteMode = + A.choice + [ " full" *> (CDMFull <$> notifyP), + " entity" *> (CDMEntity <$> notifyP), + " messages" $> CDMMessages, + CDMFull <$> notifyP -- backwards compatible + ] + where + notifyP = " notify=" *> onOffP <|> pure True + displayName = safeDecodeUtf8 <$> (quoted "'" <|> takeNameTill isSpace) + where + takeNameTill p = + A.peekChar' >>= \c -> + if refChar c then A.takeTill p else fail "invalid first character in display name" + quoted cs = A.choice [A.char c *> takeNameTill (== c) <* A.char c | c <- cs] + refChar c = c > ' ' && c /= '#' && c /= '@' + sendMsgQuote msgDir = SendMessageQuote <$> displayName <* A.space <*> pure msgDir <*> quotedMsg <*> msgTextP + quotedMsg = safeDecodeUtf8 <$> (A.char '(' *> A.takeTill (== ')') <* A.char ')') <* optional A.space + reactionP = MREmoji <$> (mrEmojiChar <$?> (toEmoji <$> A.anyChar)) + toEmoji = \case + '1' -> '👍' + '+' -> '👍' + '-' -> '👎' + ')' -> '😀' + ',' -> '😢' + '*' -> head "❤️" + '^' -> '🚀' + c -> c + composedMessagesTextP = do + text <- mcTextP + pure $ (ComposedMessage Nothing Nothing text) :| [] + liveMessageP = " live=" *> onOffP <|> pure False + sendMessageTTLP = " ttl=" *> ((Just <$> A.decimal) <|> ("default" $> Nothing)) <|> pure Nothing + receiptSettings = do + enable <- onOffP + clearOverrides <- (" clear_overrides=" *> onOffP) <|> pure False + pure UserMsgReceiptSettings {enable, clearOverrides} + onOffP = ("on" $> True) <|> ("off" $> False) + profileNames = (,) <$> displayName <*> fullNameP + newUserP = do + (cName, fullName) <- profileNames + let profile = Just Profile {displayName = cName, fullName, image = Nothing, contactLink = Nothing, preferences = Nothing} + pure NewUser {profile, pastTimestamp = False} + jsonP :: J.FromJSON a => Parser a + jsonP = J.eitherDecodeStrict' <$?> A.takeByteString + groupProfile = do + (gName, fullName) <- profileNames + let groupPreferences = + Just + (emptyGroupPrefs :: GroupPreferences) + { directMessages = Just DirectMessagesGroupPreference {enable = FEOn, role = Nothing}, + history = Just HistoryGroupPreference {enable = FEOn} + } + pure GroupProfile {displayName = gName, fullName, description = Nothing, image = Nothing, groupPreferences} + fullNameP = A.space *> textP <|> pure "" + textP = safeDecodeUtf8 <$> A.takeByteString + pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' ')) + verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ') + msgTextP = jsonP <|> textP + stringP = T.unpack . safeDecodeUtf8 <$> A.takeByteString + filePath = stringP + cryptoFileP = do + cfArgs <- optional $ CFArgs <$> (" key=" *> strP <* A.space) <*> (" nonce=" *> strP) + path <- filePath + pure $ CryptoFile path cfArgs + memberRole = + A.choice + [ " owner" $> GROwner, + " admin" $> GRAdmin, + " member" $> GRMember, + " observer" $> GRObserver + ] + chatNameP = + chatTypeP >>= \case + CTLocal -> pure $ ChatName CTLocal "" + ct -> ChatName ct <$> displayName + chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayName + chatRefP = ChatRef <$> chatTypeP <*> A.decimal + msgCountP = A.space *> A.decimal <|> pure 10 + ciTTLDecimal = ("none" $> Nothing) <|> (Just <$> A.decimal) + ciTTL = + ("day" $> Just 86400) + <|> ("week" $> Just (7 * 86400)) + <|> ("month" $> Just (30 * 86400)) + <|> ("none" $> Nothing) + timedTTLP = + ("30s" $> 30) + <|> ("5min" $> 300) + <|> ("1h" $> 3600) + <|> ("8h" $> (8 * 3600)) + <|> ("day" $> 86400) + <|> ("week" $> (7 * 86400)) + <|> ("month" $> (30 * 86400)) + <|> A.decimal + timedTTLOnOffP = + optional ("on" *> A.space) *> (Just <$> timedTTLP) + <|> ("off" $> Nothing) + timedMessagesEnabledP = + optional ("yes" *> A.space) *> (TMEEnableSetTTL <$> timedTTLP) + <|> ("yes" $> TMEEnableKeepTTL) + <|> ("no" $> TMEDisableKeepTTL) + operatorRolesP = do + operatorId' <- A.decimal + enabled' <- A.char ':' *> onOffP + smpRoles' <- (":smp=" *> srvRolesP) <|> pure allRoles + xftpRoles' <- (":xftp=" *> srvRolesP) <|> pure allRoles + pure ServerOperatorRoles {operatorId', enabled', smpRoles', xftpRoles'} + srvRolesP = srvRoles <$?> A.takeTill (\c -> c == ':' || c == ',') + where + srvRoles = \case + "off" -> Right $ ServerRoles False False + "proxy" -> Right ServerRoles {storage = False, proxy = True} + "storage" -> Right ServerRoles {storage = True, proxy = False} + "on" -> Right allRoles + _ -> Left "bad ServerRoles" + netCfgP = do + socksProxy <- "socks=" *> ("off" $> Nothing <|> "on" $> Just defaultSocksProxyWithAuth <|> Just <$> strP) + socksMode <- " socks-mode=" *> strP <|> pure SMAlways + hostMode <- " host-mode=" *> (textToHostMode . safeDecodeUtf8 <$?> A.takeTill (== ' ')) <|> pure (defaultHostMode socksProxy) + requiredHostMode <- (" required-host-mode" $> True) <|> pure False + smpProxyMode_ <- optional $ " smp-proxy=" *> strP + smpProxyFallback_ <- optional $ " smp-proxy-fallback=" *> strP + smpWebPort <- (" smp-web-port" $> True) <|> pure False + t_ <- optional $ " timeout=" *> A.decimal + logTLSErrors <- " log=" *> onOffP <|> pure False + let tcpTimeout_ = (1000000 *) <$> t_ + pure $ SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} + dbKeyP = nonEmptyKey <$?> strP + nonEmptyKey k@(DBEncryptionKey s) = if BA.null s then Left "empty key" else Right k + dbEncryptionConfig currentKey newKey = DBEncryptionConfig {currentKey, newKey, keepKey = Just False} + autoAcceptP = ifM onOffP (Just <$> (businessAA <|> addressAA)) (pure Nothing) + where + addressAA = AutoAccept False <$> (" incognito=" *> onOffP <|> pure False) <*> autoReply + businessAA = AutoAccept True <$> (" business" *> pure False) <*> autoReply + autoReply = optional (A.space *> msgContentP) + rcCtrlAddressP = RCCtrlAddress <$> ("addr=" *> strP) <*> (" iface=" *> (jsonP <|> text1P)) + text1P = safeDecodeUtf8 <$> A.takeTill (== ' ') + char_ = optional . A.char + +mkValidName :: String -> String +mkValidName = reverse . dropWhile isSpace . fst3 . foldl' addChar ("", '\NUL', 0 :: Int) + where + fst3 (x, _, _) = x + addChar (r, prev, punct) c = if validChar then (c' : r, c', punct') else (r, prev, punct) + where + c' = if isSpace c then ' ' else c + punct' + | isPunctuation c = punct + 1 + | isSpace c = punct + | otherwise = 0 + validChar + | c == '\'' = False + | prev == '\NUL' = c > ' ' && c /= '#' && c /= '@' && validFirstChar + | isSpace prev = validFirstChar || (punct == 0 && isPunctuation c) + | isPunctuation prev = validFirstChar || isSpace c || (punct < 3 && isPunctuation c) + | otherwise = validFirstChar || isSpace c || isMark c || isPunctuation c + validFirstChar = isLetter c || isNumber c || isSymbol c diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs new file mode 100644 index 0000000000..cfb15daca4 --- /dev/null +++ b/src/Simplex/Chat/Library/Internal.hs @@ -0,0 +1,1919 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +module Simplex.Chat.Library.Internal where + +import Control.Applicative ((<|>)) +import Control.Concurrent.STM (retry) +import Control.Logger.Simple +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Unlift +import Control.Monad.Reader +import Crypto.Random (ChaChaDRG) +import Data.Bifunctor (first) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Either (partitionEithers, rights) +import Data.Fixed (div') +import Data.Foldable (foldr') +import Data.Functor (($>)) +import Data.Functor.Identity +import Data.Int (Int64) +import Data.List (find, mapAccumL, partition) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as L +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time (addUTCTime) +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds) +import Simplex.Chat.Call +import Simplex.Chat.Controller +import Simplex.Chat.Files +import Simplex.Chat.Markdown +import Simplex.Chat.Messages +import Simplex.Chat.Messages.Batch (MsgBatch (..), batchMessages) +import Simplex.Chat.Messages.CIContent +import Simplex.Chat.Messages.CIContent.Events +import Simplex.Chat.Operators +import Simplex.Chat.ProfileGenerator (generateRandomProfile) +import Simplex.Chat.Protocol +import Simplex.Chat.Store +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Files +import Simplex.Chat.Store.Groups +import Simplex.Chat.Store.Messages +import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences +import Simplex.Chat.Types.Shared +import Simplex.Chat.Util (encryptFile, shuffle) +import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription) +import qualified Simplex.FileTransfer.Description as FD +import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI) +import Simplex.FileTransfer.Types (RcvFileId, SndFileId) +import Simplex.Messaging.Agent as Agent +import Simplex.Messaging.Agent.Client (getFastNetworkConfig, ipAddressProtected, withLockMap) +import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..)) +import Simplex.Messaging.Agent.Lock (withLock) +import Simplex.Messaging.Agent.Protocol +import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) +import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB +import Simplex.Messaging.Client (NetworkConfig (..)) +import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) +import qualified Simplex.Messaging.Crypto.File as CF +import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) +import qualified Simplex.Messaging.Crypto.Ratchet as CR +import Simplex.Messaging.Encoding +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (MsgBody, MsgFlags (..), ProtoServerWithAuth (..), ProtocolServer, ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer) +import qualified Simplex.Messaging.Protocol as SMP +import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Util +import Simplex.Messaging.Version +import System.FilePath (takeFileName, ()) +import System.IO (Handle, IOMode (..), SeekMode (..), hFlush) +import UnliftIO.Concurrent (forkFinally, mkWeakThreadId) +import UnliftIO.Directory +import UnliftIO.IO (hClose, hSeek, hTell, openFile) +import UnliftIO.STM + +maxMsgReactions :: Int +maxMsgReactions = 3 + +withChatLock :: String -> CM a -> CM a +withChatLock name action = asks chatLock >>= \l -> withLock l name action + +withEntityLock :: String -> ChatLockEntity -> CM a -> CM a +withEntityLock name entity action = do + chatLock <- asks chatLock + ls <- asks entityLocks + atomically $ unlessM (isEmptyTMVar chatLock) retry + withLockMap ls entity name action + +withInvitationLock :: String -> ByteString -> CM a -> CM a +withInvitationLock name = withEntityLock name . CLInvitation +{-# INLINE withInvitationLock #-} + +withConnectionLock :: String -> Int64 -> CM a -> CM a +withConnectionLock name = withEntityLock name . CLConnection +{-# INLINE withConnectionLock #-} + +withContactLock :: String -> ContactId -> CM a -> CM a +withContactLock name = withEntityLock name . CLContact +{-# INLINE withContactLock #-} + +withGroupLock :: String -> GroupId -> CM a -> CM a +withGroupLock name = withEntityLock name . CLGroup +{-# INLINE withGroupLock #-} + +withUserContactLock :: String -> Int64 -> CM a -> CM a +withUserContactLock name = withEntityLock name . CLUserContact +{-# INLINE withUserContactLock #-} + +withFileLock :: String -> Int64 -> CM a -> CM a +withFileLock name = withEntityLock name . CLFile +{-# INLINE withFileLock #-} + +useServerCfgs :: forall p. UserProtocol p => SProtocolType p -> RandomAgentServers -> [(Text, ServerOperator)] -> [UserServer p] -> NonEmpty (ServerCfg p) +useServerCfgs p RandomAgentServers {smpServers, xftpServers} opDomains = + fromMaybe (rndAgentServers p) . L.nonEmpty . agentServerCfgs p opDomains + where + rndAgentServers :: SProtocolType p -> NonEmpty (ServerCfg p) + rndAgentServers = \case + SPSMP -> smpServers + SPXFTP -> xftpServers + +contactCITimed :: Contact -> CM (Maybe CITimed) +contactCITimed ct = sndContactCITimed False ct Nothing + +sndContactCITimed :: Bool -> Contact -> Maybe Int -> CM (Maybe CITimed) +sndContactCITimed live = sndCITimed_ live . contactTimedTTL + +sndGroupCITimed :: Bool -> GroupInfo -> Maybe Int -> CM (Maybe CITimed) +sndGroupCITimed live = sndCITimed_ live . groupTimedTTL + +sndCITimed_ :: Bool -> Maybe (Maybe Int) -> Maybe Int -> CM (Maybe CITimed) +sndCITimed_ live chatTTL itemTTL = + forM (chatTTL >>= (itemTTL <|>)) $ \ttl -> + CITimed ttl + <$> if live + then pure Nothing + else Just . addUTCTime (realToFrac ttl) <$> liftIO getCurrentTime + +callTimed :: Contact -> ACIContent -> CM (Maybe CITimed) +callTimed ct aciContent = + case aciContentCallStatus aciContent of + Just callStatus + | callComplete callStatus -> do + contactCITimed ct + _ -> pure Nothing + where + aciContentCallStatus :: ACIContent -> Maybe CICallStatus + aciContentCallStatus (ACIContent _ (CISndCall st _)) = Just st + aciContentCallStatus (ACIContent _ (CIRcvCall st _)) = Just st + aciContentCallStatus _ = Nothing + +toggleNtf :: User -> GroupMember -> Bool -> CM () +toggleNtf user m ntfOn = + when (memberActive m) $ + forM_ (memberConnId m) $ \connId -> + withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user)) + +prepareGroupMsg :: User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> CM (MsgContainer, Maybe (CIQuote 'CTGroup)) +prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of + (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + (Just quotedItemId, Nothing) -> do + CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- + withStore $ \db -> getGroupChatItem db user groupId quotedItemId + (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} + qmc = quoteContent mc origQmc file + quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) + (Just _, Just _) -> throwChatError CEInvalidQuote + where + quoteData :: ChatItem c d -> GroupMember -> CM (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) + quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote + quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership') + quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m) + quoteData _ _ = throwChatError CEInvalidQuote + +quoteContent :: forall d. MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent +quoteContent mc qmc ciFile_ + | replaceContent = MCText qTextOrFile + | otherwise = case qmc of + MCImage _ image -> MCImage qTextOrFile image + MCFile _ -> MCFile qTextOrFile + -- consider same for voice messages + -- MCVoice _ voice -> MCVoice qTextOrFile voice + _ -> qmc + where + -- if the message we're quoting with is one of the "large" MsgContents + -- we replace the quote's content with MCText + replaceContent = case mc of + MCText _ -> False + MCFile _ -> False + MCLink {} -> True + MCImage {} -> True + MCVideo {} -> True + MCVoice {} -> False + MCUnknown {} -> True + qText = msgContentText qmc + getFileName :: CIFile d -> String + getFileName CIFile {fileName} = fileName + qFileName = maybe qText (T.pack . getFileName) ciFile_ + qTextOrFile = if T.null qText then qFileName else qText + +prohibitedGroupContent :: GroupInfo -> GroupMember -> MsgContent -> Maybe f -> Maybe GroupFeature +prohibitedGroupContent gInfo m mc file_ + | isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) = Just GFVoice + | not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles + | prohibitedSimplexLinks gInfo m mc = Just GFSimplexLinks + | otherwise = Nothing + +prohibitedSimplexLinks :: GroupInfo -> GroupMember -> MsgContent -> Bool +prohibitedSimplexLinks gInfo m mc = + not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo) + && maybe False (any ftIsSimplexLink) (parseMaybeMarkdownList $ msgContentText mc) + where + ftIsSimplexLink :: FormattedText -> Bool + ftIsSimplexLink FormattedText {format} = maybe False isSimplexLink format + +roundedFDCount :: Int -> Int +roundedFDCount n + | n <= 0 = 4 + | otherwise = max 4 $ fromIntegral $ (2 :: Integer) ^ (ceiling (logBase 2 (fromIntegral n) :: Double) :: Integer) + +xftpSndFileTransfer_ :: User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta) +xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ = do + let fileName = takeFileName filePath + fInv = xftpFileInvitation fileName fileSize dummyFileDescr + fsFilePath <- lift $ toFSFilePath filePath + let srcFile = CryptoFile fsFilePath cfArgs + aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n) + -- TODO CRSndFileStart event for XFTP + chSize <- asks $ fileChunkSize . config + ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup_ file fInv (AgentSndFileId aFileId) Nothing chSize + let fileSource = Just $ CryptoFile filePath cfArgs + ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP} + pure (fInv, ciFile, ft) + +xftpSndFileRedirect :: User -> FileTransferId -> ValidFileDescription 'FRecipient -> CM FileTransferMeta +xftpSndFileRedirect user ftId vfd = do + let fileName = "redirect.yaml" + file = CryptoFile fileName Nothing + fInv = xftpFileInvitation fileName (fromIntegral $ B.length $ strEncode vfd) dummyFileDescr + aFileId <- withAgent $ \a -> xftpSendDescription a (aUserId user) vfd (roundedFDCount 1) + chSize <- asks $ fileChunkSize . config + withStore' $ \db -> createSndFileTransferXFTP db user Nothing file fInv (AgentSndFileId aFileId) (Just ftId) chSize + +dummyFileDescr :: FileDescr +dummyFileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} + +cancelFilesInProgress :: User -> [CIFileInfo] -> CM () +cancelFilesInProgress user filesInfo = do + let filesInfo' = filter (not . fileEnded) filesInfo + (sfs, rfs) <- lift $ splitFTTypes <$> withStoreBatch (\db -> map (getFT db) filesInfo') + forM_ rfs $ \RcvFileTransfer {fileId} -> lift (closeFileHandle fileId rcvFiles) `catchChatError` \_ -> pure () + lift . void . withStoreBatch' $ \db -> map (updateSndFileCancelled db) sfs + lift . void . withStoreBatch' $ \db -> map (updateRcvFileCancelled db) rfs + let xsfIds = mapMaybe (\(FileTransferMeta {fileId, xftpSndFile}, _) -> (,fileId) <$> xftpSndFile) sfs + xrfIds = mapMaybe (\RcvFileTransfer {fileId, xftpRcvFile} -> (,fileId) <$> xftpRcvFile) rfs + lift $ agentXFTPDeleteSndFilesRemote user xsfIds + lift $ agentXFTPDeleteRcvFiles xrfIds + let smpSFConnIds = concatMap (\(ft, sfts) -> mapMaybe (smpSndFileConnId ft) sfts) sfs + smpRFConnIds = mapMaybe smpRcvFileConnId rfs + deleteAgentConnectionsAsync user smpSFConnIds + deleteAgentConnectionsAsync user smpRFConnIds + where + fileEnded CIFileInfo {fileStatus} = case fileStatus of + Just (AFS _ status) -> ciFileEnded status + Nothing -> True + getFT :: DB.Connection -> CIFileInfo -> IO (Either ChatError FileTransfer) + getFT db CIFileInfo {fileId} = runExceptT . withExceptT ChatErrorStore $ getFileTransfer db user fileId + updateSndFileCancelled :: DB.Connection -> (FileTransferMeta, [SndFileTransfer]) -> IO () + updateSndFileCancelled db (FileTransferMeta {fileId}, sfts) = do + updateFileCancelled db user fileId CIFSSndCancelled + forM_ sfts updateSndFTCancelled + where + updateSndFTCancelled :: SndFileTransfer -> IO () + updateSndFTCancelled ft = unless (sndFTEnded ft) $ do + updateSndFileStatus db ft FSCancelled + deleteSndFileChunks db ft + updateRcvFileCancelled :: DB.Connection -> RcvFileTransfer -> IO () + updateRcvFileCancelled db ft@RcvFileTransfer {fileId} = do + updateFileCancelled db user fileId CIFSRcvCancelled + updateRcvFileStatus db fileId FSCancelled + deleteRcvFileChunks db ft + splitFTTypes :: [Either ChatError FileTransfer] -> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer]) + splitFTTypes = foldr addFT ([], []) . rights + where + addFT f (sfs, rfs) = case f of + FTSnd ft@FileTransferMeta {cancelled} sfts | not cancelled -> ((ft, sfts) : sfs, rfs) + FTRcv ft@RcvFileTransfer {cancelled} | not cancelled -> (sfs, ft : rfs) + _ -> (sfs, rfs) + smpSndFileConnId :: FileTransferMeta -> SndFileTransfer -> Maybe ConnId + smpSndFileConnId FileTransferMeta {xftpSndFile} sft@SndFileTransfer {agentConnId = AgentConnId acId, fileInline} + | isNothing xftpSndFile && isNothing fileInline && not (sndFTEnded sft) = Just acId + | otherwise = Nothing + smpRcvFileConnId :: RcvFileTransfer -> Maybe ConnId + smpRcvFileConnId ft@RcvFileTransfer {xftpRcvFile, rcvFileInline} + | isNothing xftpRcvFile && isNothing rcvFileInline = liveRcvFileTransferConnId ft + | otherwise = Nothing + sndFTEnded SndFileTransfer {fileStatus} = fileStatus == FSCancelled || fileStatus == FSComplete + +deleteFilesLocally :: [CIFileInfo] -> CM () +deleteFilesLocally files = + withFilesFolder $ \filesFolder -> + liftIO . forM_ files $ \CIFileInfo {filePath} -> + mapM_ (delete . (filesFolder )) filePath + where + delete :: FilePath -> IO () + delete fPath = + removeFile fPath `catchAll` \_ -> + removePathForcibly fPath `catchAll_` pure () + -- perform an action only if filesFolder is set (i.e. on mobile devices) + withFilesFolder :: (FilePath -> CM ()) -> CM () + withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action + +deleteDirectCIs :: User -> Contact -> [CChatItem 'CTDirect] -> Bool -> Bool -> CM ChatResponse +deleteDirectCIs user ct items byUser timed = do + let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items + deleteCIFiles user ciFilesInfo + (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRChatItemsDeleted user deletions byUser timed + where + deleteItem db (CChatItem md ci) = do + deleteDirectChatItem db user ct ci + pure $ contactDeletion md ct ci Nothing + +deleteGroupCIs :: User -> GroupInfo -> [CChatItem 'CTGroup] -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> CM ChatResponse +deleteGroupCIs user gInfo items byUser timed byGroupMember_ deletedTs = do + let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items + deleteCIFiles user ciFilesInfo + (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRChatItemsDeleted user deletions byUser timed + where + deleteItem :: DB.Connection -> CChatItem 'CTGroup -> IO ChatItemDeletion + deleteItem db (CChatItem md ci) = do + ci' <- case byGroupMember_ of + Just m -> Just <$> updateGroupChatItemModerated db user gInfo ci m deletedTs + Nothing -> Nothing <$ deleteGroupChatItem db user gInfo ci + pure $ groupDeletion md gInfo ci ci' + +deleteLocalCIs :: User -> NoteFolder -> [CChatItem 'CTLocal] -> Bool -> Bool -> CM ChatResponse +deleteLocalCIs user nf items byUser timed = do + let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items + deleteFilesLocally ciFilesInfo + (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRChatItemsDeleted user deletions byUser timed + where + deleteItem db (CChatItem md ci) = do + deleteLocalChatItem db user nf ci + pure $ ChatItemDeletion (nfItem md ci) Nothing + nfItem :: MsgDirectionI d => SMsgDirection d -> ChatItem 'CTLocal d -> AChatItem + nfItem md = AChatItem SCTLocal md (LocalChat nf) + +deleteCIFiles :: User -> [CIFileInfo] -> CM () +deleteCIFiles user filesInfo = do + cancelFilesInProgress user filesInfo + deleteFilesLocally filesInfo + +markDirectCIsDeleted :: User -> Contact -> [CChatItem 'CTDirect] -> Bool -> UTCTime -> CM ChatResponse +markDirectCIsDeleted user ct items byUser deletedTs = do + let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items + cancelFilesInProgress user ciFilesInfo + (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRChatItemsDeleted user deletions byUser False + where + markDeleted db (CChatItem md ci) = do + ci' <- markDirectChatItemDeleted db user ct ci deletedTs + pure $ contactDeletion md ct ci (Just ci') + +markGroupCIsDeleted :: User -> GroupInfo -> [CChatItem 'CTGroup] -> Bool -> Maybe GroupMember -> UTCTime -> CM ChatResponse +markGroupCIsDeleted user gInfo items byUser byGroupMember_ deletedTs = do + let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items + cancelFilesInProgress user ciFilesInfo + (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRChatItemsDeleted user deletions byUser False + where + markDeleted db (CChatItem md ci) = do + ci' <- markGroupChatItemDeleted db user gInfo ci byGroupMember_ deletedTs + pure $ groupDeletion md gInfo ci (Just ci') + +groupDeletion :: MsgDirectionI d => SMsgDirection d -> GroupInfo -> ChatItem 'CTGroup d -> Maybe (ChatItem 'CTGroup d) -> ChatItemDeletion +groupDeletion md g ci ci' = ChatItemDeletion (gItem ci) (gItem <$> ci') + where + gItem = AChatItem SCTGroup md (GroupChat g) + +contactDeletion :: MsgDirectionI d => SMsgDirection d -> Contact -> ChatItem 'CTDirect d -> Maybe (ChatItem 'CTDirect d) -> ChatItemDeletion +contactDeletion md ct ci ci' = ChatItemDeletion (ctItem ci) (ctItem <$> ci') + where + ctItem = AChatItem SCTDirect md (DirectChat ct) + +updateCallItemStatus :: User -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> CM () +updateCallItemStatus user ct@Contact {contactId} Call {chatItemId} receivedStatus msgId_ = do + aciContent_ <- callStatusItemContent user ct chatItemId receivedStatus + forM_ aciContent_ $ \aciContent -> do + timed_ <- callTimed ct aciContent + updateDirectChatItemView user ct chatItemId aciContent False False timed_ msgId_ + forM_ (timed_ >>= timedDeleteAt') $ + startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId) + +updateDirectChatItemView :: User -> Contact -> ChatItemId -> ACIContent -> Bool -> Bool -> Maybe CITimed -> Maybe MessageId -> CM () +updateDirectChatItemView user ct chatItemId (ACIContent msgDir ciContent) edited live timed_ msgId_ = do + ci' <- withStore $ \db -> updateDirectChatItem db user ct chatItemId ciContent edited live timed_ msgId_ + toView $ CRChatItemUpdated user (AChatItem SCTDirect msgDir (DirectChat ct) ci') + +callStatusItemContent :: User -> Contact -> ChatItemId -> WebRTCCallStatus -> CM (Maybe ACIContent) +callStatusItemContent user Contact {contactId} chatItemId receivedStatus = do + CChatItem msgDir ChatItem {meta = CIMeta {updatedAt}, content} <- + withStore $ \db -> getDirectChatItem db user contactId chatItemId + ts <- liftIO getCurrentTime + let callDuration :: Int = nominalDiffTimeToSeconds (ts `diffUTCTime` updatedAt) `div'` 1 + callStatus = case content of + CISndCall st _ -> Just st + CIRcvCall st _ -> Just st + _ -> Nothing + newState_ = case (callStatus, receivedStatus) of + (Just CISCallProgress, WCSConnected) -> Nothing -- if call in-progress received connected -> no change + (Just CISCallProgress, WCSDisconnected) -> Just (CISCallEnded, callDuration) -- calculate in-progress duration + (Just CISCallProgress, WCSFailed) -> Just (CISCallEnded, callDuration) -- whether call disconnected or failed + (Just CISCallPending, WCSDisconnected) -> Just (CISCallMissed, 0) + (Just CISCallEnded, _) -> Nothing -- if call already ended or failed -> no change + (Just CISCallError, _) -> Nothing + (Just _, WCSConnecting) -> Just (CISCallNegotiated, 0) + (Just _, WCSConnected) -> Just (CISCallProgress, 0) -- if call ended that was never connected, duration = 0 + (Just _, WCSDisconnected) -> Just (CISCallEnded, 0) + (Just _, WCSFailed) -> Just (CISCallError, 0) + (Nothing, _) -> Nothing -- some other content - we should never get here, but no exception is thrown + pure $ aciContent msgDir <$> newState_ + where + aciContent :: forall d. SMsgDirection d -> (CICallStatus, Int) -> ACIContent + aciContent msgDir (callStatus', duration) = case msgDir of + SMDSnd -> ACIContent SMDSnd $ CISndCall callStatus' duration + SMDRcv -> ACIContent SMDRcv $ CIRcvCall callStatus' duration + +-- mobile clients use file paths relative to app directory (e.g. for the reason ios app directory changes on updates), +-- so we have to differentiate between the file path stored in db and communicated with frontend, and the file path +-- used during file transfer for actual operations with file system +toFSFilePath :: FilePath -> CM' FilePath +toFSFilePath f = + maybe f ( f) <$> (chatReadVar' filesFolder) + +setFileToEncrypt :: RcvFileTransfer -> CM RcvFileTransfer +setFileToEncrypt ft@RcvFileTransfer {fileId} = do + cfArgs <- atomically . CF.randomArgs =<< asks random + withStore' $ \db -> setFileCryptoArgs db fileId cfArgs + pure (ft :: RcvFileTransfer) {cryptoArgs = Just cfArgs} + +receiveFile' :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM ChatResponse +receiveFile' user ft userApprovedRelays rcvInline_ filePath_ = do + (CRRcvFileAccepted user <$> acceptFileReceive user ft userApprovedRelays rcvInline_ filePath_) `catchChatError` processError + where + processError = \case + -- TODO AChatItem in Cancelled events + ChatErrorAgent (SMP _ SMP.AUTH) _ -> pure $ CRRcvFileAcceptedSndCancelled user ft + ChatErrorAgent (CONN DUPLICATE) _ -> pure $ CRRcvFileAcceptedSndCancelled user ft + e -> throwError e + +acceptFileReceive :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM AChatItem +acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId, cryptoArgs} userApprovedRelays rcvInline_ filePath_ = do + unless (fileStatus == RFSNew) $ case fileStatus of + RFSCancelled _ -> throwChatError $ CEFileCancelled fName + _ -> throwChatError $ CEFileAlreadyReceiving fName + vr <- chatVersionRange + case (xftpRcvFile, fileConnReq) of + -- direct file protocol + (Nothing, Just connReq) -> do + subMode <- chatReadVar subscriptionMode + dm <- encodeConnInfo $ XFileAcpt fName + connIds <- joinAgentConnectionAsync user True connReq dm subMode + filePath <- getRcvFilePath fileId filePath_ fName True + withStore $ \db -> acceptRcvFileTransfer db vr user fileId connIds ConnJoined filePath subMode + -- XFTP + (Just XFTPRcvFile {userApprovedRelays = approvedBeforeReady}, _) -> do + let userApproved = approvedBeforeReady || userApprovedRelays + filePath <- getRcvFilePath fileId filePath_ fName False + (ci, rfd) <- withStore $ \db -> do + -- marking file as accepted and reading description in the same transaction + -- to prevent race condition with appending description + ci <- xftpAcceptRcvFT db vr user fileId filePath userApproved + rfd <- getRcvFileDescrByRcvFileId db fileId + pure (ci, rfd) + receiveViaCompleteFD user fileId rfd userApproved cryptoArgs + pure ci + -- group & direct file protocol + _ -> do + chatRef <- withStore $ \db -> getChatRefByFileId db user fileId + case (chatRef, grpMemberId) of + (ChatRef CTDirect contactId, Nothing) -> do + ct <- withStore $ \db -> getContact db vr user contactId + acceptFile CFCreateConnFileInvDirect $ \msg -> void $ sendDirectContactMessage user ct msg + (ChatRef CTGroup groupId, Just memId) -> do + GroupMember {activeConn} <- withStore $ \db -> getGroupMember db vr user groupId memId + case activeConn of + Just conn -> do + acceptFile CFCreateConnFileInvGroup $ \msg -> void $ sendDirectMemberMessage conn msg groupId + _ -> throwChatError $ CEFileInternal "member connection not active" + _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" + where + acceptFile :: CommandFunction -> (ChatMsgEvent 'Json -> CM ()) -> CM AChatItem + acceptFile cmdFunction send = do + filePath <- getRcvFilePath fileId filePath_ fName True + inline <- receiveInline + vr <- chatVersionRange + if + | inline -> do + -- accepting inline + ci <- withStore $ \db -> acceptRcvInlineFT db vr user fileId filePath + sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId + send $ XFileAcptInv sharedMsgId Nothing fName + pure ci + | fileInline == Just IFMSent -> throwChatError $ CEFileAlreadyReceiving fName + | otherwise -> do + -- accepting via a new connection + subMode <- chatReadVar subscriptionMode + connIds <- createAgentConnectionAsync user cmdFunction True SCMInvitation subMode + withStore $ \db -> acceptRcvFileTransfer db vr user fileId connIds ConnNew filePath subMode + receiveInline :: CM Bool + receiveInline = do + ChatConfig {fileChunkSize, inlineFiles = InlineFilesConfig {receiveChunks, offerChunks}} <- asks config + pure $ + rcvInline_ /= Just False + && fileInline == Just IFMOffer + && ( fileSize <= fileChunkSize * receiveChunks + || (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks) + ) + +receiveViaCompleteFD :: User -> FileTransferId -> RcvFileDescr -> Bool -> Maybe CryptoFileArgs -> CM () +receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} userApprovedRelays cfArgs = + when fileDescrComplete $ do + rd <- parseFileDescription fileDescrText + if userApprovedRelays + then receive' rd True + else do + let srvs = fileServers rd + unknownSrvs <- getUnknownSrvs srvs + let approved = null unknownSrvs + ifM + ((approved ||) <$> ipProtectedForSrvs srvs) + (receive' rd approved) + (relaysNotApproved unknownSrvs) + where + receive' :: ValidFileDescription 'FRecipient -> Bool -> CM () + receive' rd approved = do + aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd cfArgs approved + startReceivingFile user fileId + withStore' $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId) + fileServers :: ValidFileDescription 'FRecipient -> [XFTPServer] + fileServers (FD.ValidFileDescription FD.FileDescription {chunks}) = + S.toList $ S.fromList $ concatMap (\FD.FileChunk {replicas} -> map (\FD.FileChunkReplica {server} -> server) replicas) chunks + getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer] + getUnknownSrvs srvs = do + knownSrvs <- L.map protoServer' <$> getKnownAgentServers SPXFTP user + pure $ filter (`notElem` knownSrvs) srvs + ipProtectedForSrvs :: [XFTPServer] -> CM Bool + ipProtectedForSrvs srvs = do + netCfg <- lift getNetworkConfig + pure $ all (ipAddressProtected netCfg) srvs + relaysNotApproved :: [XFTPServer] -> CM () + relaysNotApproved unknownSrvs = do + aci_ <- resetRcvCIFileStatus user fileId CIFSRcvInvitation + forM_ aci_ $ \aci -> do + cleanupACIFile aci + toView $ CRChatItemUpdated user aci + throwChatError $ CEFileNotApproved fileId unknownSrvs + +cleanupACIFile :: AChatItem -> CM () +cleanupACIFile (AChatItem _ _ _ ChatItem {file = Just CIFile {fileSource = Just CryptoFile {filePath}}}) = do + fsFilePath <- lift $ toFSFilePath filePath + removeFile fsFilePath `catchChatError` \_ -> pure () +cleanupACIFile _ = pure () + +getKnownAgentServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> User -> CM (NonEmpty (ServerCfg p)) +getKnownAgentServers p user = do + as <- asks randomAgentServers + withStore $ \db -> do + opDomains <- operatorDomains . serverOperators <$> getServerOperators db + srvs <- liftIO $ getProtocolServers db p user + pure $ useServerCfgs p as opDomains srvs + +protoServer' :: ServerCfg p -> ProtocolServer p +protoServer' ServerCfg {server} = protoServer server + +getNetworkConfig :: CM' NetworkConfig +getNetworkConfig = withAgent' $ liftIO . getFastNetworkConfig + +resetRcvCIFileStatus :: User -> FileTransferId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem) +resetRcvCIFileStatus user fileId ciFileStatus = do + vr <- chatVersionRange + withStore $ \db -> do + liftIO $ do + updateCIFileStatus db user fileId ciFileStatus + updateRcvFileStatus db fileId FSNew + updateRcvFileAgentId db fileId Nothing + lookupChatItemByFileId db vr user fileId + +receiveViaURI :: User -> FileDescriptionURI -> CryptoFile -> CM RcvFileTransfer +receiveViaURI user@User {userId} FileDescriptionURI {description} cf@CryptoFile {cryptoArgs} = do + fileId <- withStore $ \db -> createRcvStandaloneFileTransfer db userId cf fileSize chunkSize + -- currently the only use case is user migrating via their configured servers, so we pass approvedRelays = True + aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) description cryptoArgs True + withStore $ \db -> do + liftIO $ do + updateRcvFileStatus db fileId FSConnected + updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1 + updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId) + getRcvFileTransfer db user fileId + where + FD.ValidFileDescription FD.FileDescription {size = FD.FileSize fileSize, chunkSize = FD.FileSize chunkSize} = description + +startReceivingFile :: User -> FileTransferId -> CM () +startReceivingFile user fileId = do + vr <- chatVersionRange + ci <- withStore $ \db -> do + liftIO $ updateRcvFileStatus db fileId FSConnected + liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1 + getChatItemByFileId db vr user fileId + toView $ CRRcvFileStart user ci + +getRcvFilePath :: FileTransferId -> Maybe FilePath -> String -> Bool -> CM FilePath +getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of + Nothing -> + chatReadVar filesFolder >>= \case + Nothing -> do + defaultFolder <- lift getDefaultFilesFolder + fPath <- liftIO $ defaultFolder `uniqueCombine` fn + createEmptyFile fPath $> fPath + Just filesFolder -> do + fPath <- liftIO $ filesFolder `uniqueCombine` fn + createEmptyFile fPath + pure $ takeFileName fPath + Just fPath -> + ifM + (doesDirectoryExist fPath) + (createInPassedDirectory fPath) + $ ifM + (doesFileExist fPath) + (throwChatError $ CEFileAlreadyExists fPath) + (createEmptyFile fPath $> fPath) + where + createInPassedDirectory :: FilePath -> CM FilePath + createInPassedDirectory fPathDir = do + fPath <- liftIO $ fPathDir `uniqueCombine` fn + createEmptyFile fPath $> fPath + createEmptyFile :: FilePath -> CM () + createEmptyFile fPath = emptyFile `catchThrow` (ChatError . CEFileWrite fPath . show) + where + emptyFile :: CM () + emptyFile + | keepHandle = do + h <- getFileHandle fileId fPath rcvFiles AppendMode + liftIO $ B.hPut h "" >> hFlush h + | otherwise = liftIO $ B.writeFile fPath "" + +acceptContactRequest :: User -> UserContactRequest -> IncognitoEnabled -> CM (Contact, Connection, SndQueueSecured) +acceptContactRequest user@User {userId} UserContactRequest {agentInvitationId = AgentInvId invId, contactId_, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId, xContactId, pqSupport} incognito = do + subMode <- chatReadVar subscriptionMode + let pqSup = PQSupportOn + pqSup' = pqSup `CR.pqSupportAnd` pqSupport + vr <- chatVersionRange + let chatV = vr `peerConnChatVersion` cReqChatVRange + (ct, conn, incognitoProfile) <- case contactId_ of + Nothing -> do + incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing + connId <- withAgent $ \a -> prepareConnectionToAccept a True invId pqSup' + (ct, conn) <- withStore' $ \db -> createAcceptedContact db user connId chatV cReqChatVRange cName profileId cp userContactLinkId xContactId incognitoProfile subMode pqSup' False + pure (ct, conn, incognitoProfile) + Just contactId -> do + ct <- withFastStore $ \db -> getContact db vr user contactId + case contactConn ct of + Nothing -> throwChatError $ CECommandError "contact has no connection" + Just conn@Connection {customUserProfileId} -> do + incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId + pure (ct, conn, ExistingIncognito <$> incognitoProfile) + let profileToSend = profileToSendOnAccept user incognitoProfile False + dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend + (ct,conn,) <$> withAgent (\a -> acceptContact a (aConnId conn) True invId dm pqSup' subMode) + +acceptContactRequestAsync :: User -> UserContactRequest -> Maybe IncognitoProfile -> Bool -> PQSupport -> CM Contact +acceptContactRequestAsync user cReq@UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} incognitoProfile contactUsed pqSup = do + subMode <- chatReadVar subscriptionMode + let profileToSend = profileToSendOnAccept user incognitoProfile False + vr <- chatVersionRange + let chatV = vr `peerConnChatVersion` cReqChatVRange + (cmdId, acId) <- agentAcceptContactAsync user True invId (XInfo profileToSend) subMode pqSup chatV + withStore' $ \db -> do + (ct, Connection {connId}) <- createAcceptedContact db user acId chatV cReqChatVRange cName profileId p userContactLinkId xContactId incognitoProfile subMode pqSup contactUsed + deleteContactRequestRec db user cReq + setCommandConnId db user cmdId connId + pure ct + +acceptGroupJoinRequestAsync :: User -> GroupInfo -> UserContactRequest -> GroupMemberRole -> Maybe IncognitoProfile -> CM GroupMember +acceptGroupJoinRequestAsync + user + gInfo@GroupInfo {groupProfile, membership, businessChat} + ucr@UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange} + gLinkMemRole + incognitoProfile = do + gVar <- asks random + (groupMemberId, memberId) <- withStore $ \db -> do + liftIO $ deleteContactRequestRec db user ucr + createAcceptedMember db gVar user gInfo ucr gLinkMemRole + currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo + let Profile {displayName} = profileToSendOnAccept user incognitoProfile True + GroupMember {memberRole = userRole, memberId = userMemberId} = membership + msg = + XGrpLinkInv $ + GroupLinkInvitation + { fromMember = MemberIdRole userMemberId userRole, + fromMemberName = displayName, + invitedMember = MemberIdRole memberId gLinkMemRole, + groupProfile, + business = businessChat, + groupSize = Just currentMemCount + } + subMode <- chatReadVar subscriptionMode + vr <- chatVersionRange + let chatV = vr `peerConnChatVersion` cReqChatVRange + connIds <- agentAcceptContactAsync user True invId msg subMode PQSupportOff chatV + withStore $ \db -> do + liftIO $ createAcceptedMemberConnection db user connIds chatV ucr groupMemberId subMode + getGroupMemberById db vr user groupMemberId + +acceptBusinessJoinRequestAsync :: User -> UserContactRequest -> CM GroupInfo +acceptBusinessJoinRequestAsync + user + ucr@UserContactRequest {contactRequestId, agentInvitationId = AgentInvId invId, cReqChatVRange} = do + vr <- chatVersionRange + gVar <- asks random + let userProfile@Profile {displayName, preferences} = profileToSendOnAccept user Nothing True + groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs preferences + (gInfo, clientMember) <- withStore $ \db -> do + liftIO $ deleteContactRequest db user contactRequestId + createBusinessRequestGroup db vr gVar user ucr groupPreferences + let GroupInfo {membership} = gInfo + GroupMember {memberRole = userRole, memberId = userMemberId} = membership + GroupMember {groupMemberId, memberId} = clientMember + msg = + XGrpLinkInv $ + GroupLinkInvitation + { fromMember = MemberIdRole userMemberId userRole, + fromMemberName = displayName, + invitedMember = MemberIdRole memberId GRMember, + groupProfile = businessGroupProfile userProfile groupPreferences, + -- This refers to the "title member" that defines the group name and profile. + -- This coincides with fromMember to be current user when accepting the connecting user, + -- but it will be different when inviting somebody else. + business = Just $ BusinessChatInfo {chatType = BCBusiness, businessId = userMemberId, customerId = memberId}, + groupSize = Just 1 + } + subMode <- chatReadVar subscriptionMode + let chatV = vr `peerConnChatVersion` cReqChatVRange + connIds <- agentAcceptContactAsync user True invId msg subMode PQSupportOff chatV + withStore' $ \db -> createAcceptedMemberConnection db user connIds chatV ucr groupMemberId subMode + let cd = CDGroupSnd gInfo + createInternalChatItem user cd (CISndGroupE2EEInfo E2EInfo {pqEnabled = PQEncOff}) Nothing + createGroupFeatureItems user cd CISndGroupFeature gInfo + pure gInfo + where + businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile + businessGroupProfile Profile {displayName, fullName, image} groupPreferences = + GroupProfile {displayName, fullName, description = Nothing, image, groupPreferences = Just groupPreferences} + +profileToSendOnAccept :: User -> Maybe IncognitoProfile -> Bool -> Profile +profileToSendOnAccept user ip = userProfileToSend user (getIncognitoProfile <$> ip) Nothing + where + getIncognitoProfile = \case + NewIncognito p -> p + ExistingIncognito lp -> fromLocalProfile lp + +deleteGroupLink' :: User -> GroupInfo -> CM () +deleteGroupLink' user gInfo = do + vr <- chatVersionRange + conn <- withStore $ \db -> getGroupLinkConnection db vr user gInfo + deleteGroupLink_ user gInfo conn + +deleteGroupLinkIfExists :: User -> GroupInfo -> CM () +deleteGroupLinkIfExists user gInfo = do + vr <- chatVersionRange + conn_ <- eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupLinkConnection db vr user gInfo) + mapM_ (deleteGroupLink_ user gInfo) conn_ + +deleteGroupLink_ :: User -> GroupInfo -> Connection -> CM () +deleteGroupLink_ user gInfo conn = do + deleteAgentConnectionAsync user $ aConnId conn + withStore' $ \db -> deleteGroupLink db user gInfo + +startProximateTimedItemThread :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM () +startProximateTimedItemThread user itemRef deleteAt = do + interval <- asks (cleanupManagerInterval . config) + ts <- liftIO getCurrentTime + when (diffUTCTime deleteAt ts <= interval) $ + startTimedItemThread user itemRef deleteAt + +startTimedItemThread :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM () +startTimedItemThread user itemRef deleteAt = do + itemThreads <- asks timedItemThreads + threadTVar_ <- atomically $ do + exists <- TM.member itemRef itemThreads + if not exists + then do + threadTVar <- newTVar Nothing + TM.insert itemRef threadTVar itemThreads + pure $ Just threadTVar + else pure Nothing + forM_ threadTVar_ $ \threadTVar -> do + tId <- mkWeakThreadId =<< deleteTimedItem user itemRef deleteAt `forkFinally` const (atomically $ TM.delete itemRef itemThreads) + atomically $ writeTVar threadTVar (Just tId) + +deleteTimedItem :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM () +deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do + ts <- liftIO getCurrentTime + liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts + lift waitChatStartedAndActivated + vr <- chatVersionRange + case cType of + CTDirect -> do + (ct, ci) <- withStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId + deleteDirectCIs user ct [ci] True True >>= toView + CTGroup -> do + (gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId + deletedTs <- liftIO getCurrentTime + deleteGroupCIs user gInfo [ci] True True Nothing deletedTs >>= toView + _ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType" + +startUpdatedTimedItemThread :: User -> ChatRef -> ChatItem c d -> ChatItem c d -> CM () +startUpdatedTimedItemThread user chatRef ci ci' = + case (chatItemTimed ci >>= timedDeleteAt', chatItemTimed ci' >>= timedDeleteAt') of + (Nothing, Just deleteAt') -> + startProximateTimedItemThread user (chatRef, chatItemId' ci') deleteAt' + _ -> pure () + +metaBrokerTs :: MsgMeta -> UTCTime +metaBrokerTs MsgMeta {broker = (_, brokerTs)} = brokerTs + +sameMemberId :: MemberId -> GroupMember -> Bool +sameMemberId memId GroupMember {memberId} = memId == memberId + +createContactPQSndItem :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection) +createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' = + flip catchChatError (const $ pure (ct, conn)) $ case (pqSndEnabled, pqSndEnabled') of + (Just b, b') | b' /= b -> createPQItem $ CISndConnEvent (SCEPqEnabled pqSndEnabled') + (Nothing, PQEncOn) -> createPQItem $ CISndDirectE2EEInfo (E2EInfo pqSndEnabled') + _ -> pure (ct, conn) + where + createPQItem ciContent = do + let conn' = conn {pqSndEnabled = Just pqSndEnabled'} :: Connection + ct' = ct {activeConn = Just conn'} :: Contact + when (contactPQEnabled ct /= contactPQEnabled ct') $ do + createInternalChatItem user (CDDirectSnd ct') ciContent Nothing + toView $ CRContactPQEnabled user ct' pqSndEnabled' + pure (ct', conn') + +updateContactPQRcv :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection) +updateContactPQRcv user ct conn@Connection {connId, pqRcvEnabled} pqRcvEnabled' = + flip catchChatError (const $ pure (ct, conn)) $ case (pqRcvEnabled, pqRcvEnabled') of + (Just b, b') | b' /= b -> updatePQ $ CIRcvConnEvent (RCEPqEnabled pqRcvEnabled') + (Nothing, PQEncOn) -> updatePQ $ CIRcvDirectE2EEInfo (E2EInfo pqRcvEnabled') + _ -> pure (ct, conn) + where + updatePQ ciContent = do + withStore' $ \db -> updateConnPQRcvEnabled db connId pqRcvEnabled' + let conn' = conn {pqRcvEnabled = Just pqRcvEnabled'} :: Connection + ct' = ct {activeConn = Just conn'} :: Contact + when (contactPQEnabled ct /= contactPQEnabled ct') $ do + createInternalChatItem user (CDDirectRcv ct') ciContent Nothing + toView $ CRContactPQEnabled user ct' pqRcvEnabled' + pure (ct', conn') + +updatePeerChatVRange :: Connection -> VersionRangeChat -> CM Connection +updatePeerChatVRange conn@Connection {connId, connChatVersion = v, peerChatVRange, connType, pqSupport, pqEncryption} msgVRange = do + v' <- lift $ upgradedConnVersion v msgVRange + conn' <- + if msgVRange /= peerChatVRange || v' /= v + then do + withStore' $ \db -> setPeerChatVRange db connId v' msgVRange + pure conn {connChatVersion = v', peerChatVRange = msgVRange} + else pure conn + -- TODO v6.0 remove/review: for contacts only version upgrade should trigger enabling PQ support/encryption + if connType == ConnContact && v' >= pqEncryptionCompressionVersion && (pqSupport /= PQSupportOn || pqEncryption /= PQEncOn) + then do + withStore' $ \db -> updateConnSupportPQ db connId PQSupportOn PQEncOn + pure conn' {pqSupport = PQSupportOn, pqEncryption = PQEncOn} + else pure conn' + +updateMemberChatVRange :: GroupMember -> Connection -> VersionRangeChat -> CM (GroupMember, Connection) +updateMemberChatVRange mem@GroupMember {groupMemberId} conn@Connection {connId, connChatVersion = v, peerChatVRange} msgVRange = do + v' <- lift $ upgradedConnVersion v msgVRange + if msgVRange /= peerChatVRange || v' /= v + then do + withStore' $ \db -> do + setPeerChatVRange db connId v' msgVRange + setMemberChatVRange db groupMemberId msgVRange + let conn' = conn {connChatVersion = v', peerChatVRange = msgVRange} + pure (mem {memberChatVRange = msgVRange, activeConn = Just conn'}, conn') + else pure (mem, conn) + +upgradedConnVersion :: VersionChat -> VersionRangeChat -> CM' VersionChat +upgradedConnVersion v peerVR = do + vr <- chatVersionRange' + -- don't allow reducing agreed connection version + pure $ maybe v (\(Compatible v') -> max v v') $ vr `compatibleVersion` peerVR + +parseFileDescription :: FilePartyI p => Text -> CM (ValidFileDescription p) +parseFileDescription = + liftEither . first (ChatError . CEInvalidFileDescription) . (strDecode . encodeUtf8) + +sendDirectFileInline :: User -> Contact -> FileTransferMeta -> SharedMsgId -> CM () +sendDirectFileInline user ct ft sharedMsgId = do + msgDeliveryId <- sendFileInline_ ft sharedMsgId $ sendDirectContactMessage user ct + withStore $ \db -> updateSndDirectFTDelivery db ct ft msgDeliveryId + +sendMemberFileInline :: GroupMember -> Connection -> FileTransferMeta -> SharedMsgId -> CM () +sendMemberFileInline m@GroupMember {groupId} conn ft sharedMsgId = do + msgDeliveryId <- sendFileInline_ ft sharedMsgId $ \msg -> do + (sndMsg, msgDeliveryId, _) <- sendDirectMemberMessage conn msg groupId + pure (sndMsg, msgDeliveryId) + withStore' $ \db -> updateSndGroupFTDelivery db m conn ft msgDeliveryId + +sendFileInline_ :: FileTransferMeta -> SharedMsgId -> (ChatMsgEvent 'Binary -> CM (SndMessage, Int64)) -> CM Int64 +sendFileInline_ FileTransferMeta {filePath, chunkSize} sharedMsgId sendMsg = + sendChunks 1 =<< liftIO . B.readFile =<< lift (toFSFilePath filePath) + where + sendChunks chunkNo bytes = do + let (chunk, rest) = B.splitAt chSize bytes + (_, msgDeliveryId) <- sendMsg $ BFileChunk sharedMsgId $ FileChunk chunkNo chunk + if B.null rest + then pure msgDeliveryId + else sendChunks (chunkNo + 1) rest + chSize = fromIntegral chunkSize + +parseChatMessage :: Connection -> ByteString -> CM (ChatMessage 'Json) +parseChatMessage conn s = do + case parseChatMessages s of + [msg] -> liftEither . first (ChatError . errType) $ (\(ACMsg _ m) -> checkEncoding m) =<< msg + _ -> throwChatError $ CEException "parseChatMessage: single message is expected" + where + errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s) +{-# INLINE parseChatMessage #-} + +sendFileChunk :: User -> SndFileTransfer -> CM () +sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} = + unless (fileStatus == FSComplete || fileStatus == FSCancelled) $ do + vr <- chatVersionRange + withStore' (`createSndFileChunk` ft) >>= \case + Just chunkNo -> sendFileChunkNo ft chunkNo + Nothing -> do + ci <- withStore $ \db -> do + liftIO $ updateSndFileStatus db ft FSComplete + liftIO $ deleteSndFileChunks db ft + updateDirectCIFileStatus db vr user fileId CIFSSndComplete + toView $ CRSndFileComplete user ci ft + lift $ closeFileHandle fileId sndFiles + deleteAgentConnectionAsync user acId + +sendFileChunkNo :: SndFileTransfer -> Integer -> CM () +sendFileChunkNo ft@SndFileTransfer {agentConnId = AgentConnId acId} chunkNo = do + chunkBytes <- readFileChunk ft chunkNo + (msgId, _) <- withAgent $ \a -> sendMessage a acId PQEncOff SMP.noMsgFlags $ smpEncode FileChunk {chunkNo, chunkBytes} + withStore' $ \db -> updateSndFileChunkMsg db ft chunkNo msgId + +readFileChunk :: SndFileTransfer -> Integer -> CM ByteString +readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo = do + fsFilePath <- lift $ toFSFilePath filePath + read_ fsFilePath `catchThrow` (ChatError . CEFileRead filePath . show) + where + read_ fsFilePath = do + h <- getFileHandle fileId fsFilePath sndFiles ReadMode + pos <- hTell h + let pos' = (chunkNo - 1) * chunkSize + when (pos /= pos') $ hSeek h AbsoluteSeek pos' + liftIO . B.hGet h $ fromInteger chunkSize + +parseFileChunk :: ByteString -> CM FileChunk +parseFileChunk = liftEither . first (ChatError . CEFileRcvChunk) . smpDecode + +appendFileChunk :: RcvFileTransfer -> Integer -> ByteString -> Bool -> CM () +appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs, fileInvitation = FileInvitation {fileName}} chunkNo chunk final = + case fileStatus of + RFSConnected RcvFileInfo {filePath} -> append_ filePath + -- sometimes update of file transfer status to FSConnected + -- doesn't complete in time before MSG with first file chunk + RFSAccepted RcvFileInfo {filePath} -> append_ filePath + RFSCancelled _ -> pure () + _ -> throwChatError $ CEFileInternal "receiving file transfer not in progress" + where + append_ :: FilePath -> CM () + append_ filePath = do + fsFilePath <- lift $ toFSFilePath filePath + h <- getFileHandle fileId fsFilePath rcvFiles AppendMode + liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (fileErr . show) + withStore' $ \db -> updatedRcvFileChunkStored db ft chunkNo + when final $ do + lift $ closeFileHandle fileId rcvFiles + forM_ cryptoArgs $ \cfArgs -> do + tmpFile <- lift getChatTempDirectory >>= liftIO . (`uniqueCombine` fileName) + tryChatError (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case + Right () -> do + removeFile fsFilePath `catchChatError` \_ -> pure () + renameFile tmpFile fsFilePath + Left e -> do + toView $ CRChatError Nothing e + removeFile tmpFile `catchChatError` \_ -> pure () + withStore' (`removeFileCryptoArgs` fileId) + where + encryptErr e = fileErr $ e <> ", received file not encrypted" + fileErr = ChatError . CEFileWrite filePath + +getFileHandle :: Int64 -> FilePath -> (ChatController -> TVar (Map Int64 Handle)) -> IOMode -> CM Handle +getFileHandle fileId filePath files ioMode = do + fs <- asks files + h_ <- M.lookup fileId <$> readTVarIO fs + maybe (newHandle fs) pure h_ + where + newHandle fs = do + h <- openFile filePath ioMode `catchThrow` (ChatError . CEFileInternal . show) + atomically . modifyTVar fs $ M.insert fileId h + pure h + +isFileActive :: Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> CM Bool +isFileActive fileId files = do + fs <- asks files + isJust . M.lookup fileId <$> readTVarIO fs + +cancelRcvFileTransfer :: User -> RcvFileTransfer -> CM (Maybe ConnId) +cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, xftpRcvFile, rcvFileInline} = + cancel' `catchChatError` (\e -> toView (CRChatError (Just user) e) $> fileConnId) + where + cancel' = do + lift $ closeFileHandle fileId rcvFiles + withStore' $ \db -> do + updateFileCancelled db user fileId CIFSRcvCancelled + updateRcvFileStatus db fileId FSCancelled + deleteRcvFileChunks db ft + case xftpRcvFile of + Just XFTPRcvFile {agentRcvFileId = Just (AgentRcvFileId aFileId), agentRcvFileDeleted} -> + unless agentRcvFileDeleted $ agentXFTPDeleteRcvFile aFileId fileId + _ -> pure () + pure fileConnId + fileConnId = if isNothing xftpRcvFile && isNothing rcvFileInline then liveRcvFileTransferConnId ft else Nothing + +cancelSndFile :: User -> FileTransferMeta -> [SndFileTransfer] -> Bool -> CM [ConnId] +cancelSndFile user FileTransferMeta {fileId, xftpSndFile} fts sendCancel = do + withStore' (\db -> updateFileCancelled db user fileId CIFSSndCancelled) + `catchChatError` (toView . CRChatError (Just user)) + case xftpSndFile of + Nothing -> + catMaybes <$> forM fts (\ft -> cancelSndFileTransfer user ft sendCancel) + Just xsf -> do + forM_ fts (\ft -> cancelSndFileTransfer user ft False) + lift (agentXFTPDeleteSndFileRemote user xsf fileId) `catchChatError` (toView . CRChatError (Just user)) + pure [] + +-- TODO v6.0 remove +cancelSndFileTransfer :: User -> SndFileTransfer -> Bool -> CM (Maybe ConnId) +cancelSndFileTransfer user@User {userId} ft@SndFileTransfer {fileId, connId, agentConnId = AgentConnId acId, fileStatus, fileInline} sendCancel = + if fileStatus == FSCancelled || fileStatus == FSComplete + then pure Nothing + else cancel' `catchChatError` (\e -> toView (CRChatError (Just user) e) $> fileConnId) + where + cancel' = do + withStore' $ \db -> do + updateSndFileStatus db ft FSCancelled + deleteSndFileChunks db ft + when sendCancel $ case fileInline of + Just _ -> do + vr <- chatVersionRange + (sharedMsgId, conn) <- withStore $ \db -> (,) <$> getSharedMsgIdByFileId db userId fileId <*> getConnectionById db vr user connId + void $ sendDirectMessage_ conn (BFileChunk sharedMsgId FileChunkCancel) (ConnectionId connId) + _ -> withAgent $ \a -> void . sendMessage a acId PQEncOff SMP.noMsgFlags $ smpEncode FileChunkCancel + pure fileConnId + fileConnId = if isNothing fileInline then Just acId else Nothing + +closeFileHandle :: Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> CM' () +closeFileHandle fileId files = do + fs <- asks files + h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m) + liftIO $ mapM_ hClose h_ `catchAll_` pure () + +deleteMembersConnections :: User -> [GroupMember] -> CM () +deleteMembersConnections user members = deleteMembersConnections' user members False + +deleteMembersConnections' :: User -> [GroupMember] -> Bool -> CM () +deleteMembersConnections' user members waitDelivery = do + let memberConns = + filter (\Connection {connStatus} -> connStatus /= ConnDeleted) $ + mapMaybe (\GroupMember {activeConn} -> activeConn) members + deleteAgentConnectionsAsync' user (map aConnId memberConns) waitDelivery + lift . void . withStoreBatch' $ \db -> map (\conn -> updateConnectionStatus db conn ConnDeleted) memberConns + +deleteMemberConnection :: User -> GroupMember -> CM () +deleteMemberConnection user mem = deleteMemberConnection' user mem False + +deleteMemberConnection' :: User -> GroupMember -> Bool -> CM () +deleteMemberConnection' user GroupMember {activeConn} waitDelivery = do + forM_ activeConn $ \conn -> do + deleteAgentConnectionAsync' user (aConnId conn) waitDelivery + withStore' $ \db -> updateConnectionStatus db conn ConnDeleted + +deleteOrUpdateMemberRecord :: User -> GroupMember -> CM () +deleteOrUpdateMemberRecord user@User {userId} member = + withStore' $ \db -> + checkGroupMemberHasItems db user member >>= \case + Just _ -> updateGroupMemberStatus db userId member GSMemRemoved + Nothing -> deleteGroupMember db user member + +sendDirectContactMessages :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage] +sendDirectContactMessages user ct events = do + Connection {connChatVersion = v} <- liftEither $ contactSendConn_ ct + if v >= batchSend2Version + then sendDirectContactMessages' user ct events + else forM (L.toList events) $ \evt -> + (Right . fst <$> sendDirectContactMessage user ct evt) `catchChatError` \e -> pure (Left e) + +sendDirectContactMessages' :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage] +sendDirectContactMessages' user ct events = do + conn@Connection {connId} <- liftEither $ contactSendConn_ ct + let idsEvts = L.map (ConnectionId connId,) events + msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} + sndMsgs_ <- lift $ createSndMessages idsEvts + (sndMsgs', pqEnc_) <- batchSendConnMessagesB user conn msgFlags sndMsgs_ + forM_ pqEnc_ $ \pqEnc' -> void $ createContactPQSndItem user ct conn pqEnc' + pure sndMsgs' + +sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64) +sendDirectContactMessage user ct chatMsgEvent = do + conn@Connection {connId} <- liftEither $ contactSendConn_ ct + r <- sendDirectMessage_ conn chatMsgEvent (ConnectionId connId) + let (sndMessage, msgDeliveryId, pqEnc') = r + void $ createContactPQSndItem user ct conn pqEnc' + pure (sndMessage, msgDeliveryId) + +contactSendConn_ :: Contact -> Either ChatError Connection +contactSendConn_ ct@Contact {activeConn} = case activeConn of + Nothing -> err $ CEContactNotReady ct + Just conn + | not (connReady conn) -> err $ CEContactNotReady ct + | not (contactActive ct) -> err $ CEContactNotActive ct + | connDisabled conn -> err $ CEContactDisabled ct + | otherwise -> Right conn + where + err = Left . ChatError + +-- unlike sendGroupMemberMessage, this function will not store message as pending +-- TODO v5.8 we could remove pending messages once all clients support forwarding +sendDirectMemberMessage :: MsgEncodingI e => Connection -> ChatMsgEvent e -> GroupId -> CM (SndMessage, Int64, PQEncryption) +sendDirectMemberMessage conn chatMsgEvent groupId = sendDirectMessage_ conn chatMsgEvent (GroupId groupId) + +sendDirectMessage_ :: MsgEncodingI e => Connection -> ChatMsgEvent e -> ConnOrGroupId -> CM (SndMessage, Int64, PQEncryption) +sendDirectMessage_ conn chatMsgEvent connOrGroupId = do + when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn) + msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent connOrGroupId + -- TODO move compressed body to SndMessage and compress in createSndMessage + (msgDeliveryId, pqEnc') <- deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId + pure (msg, msgDeliveryId, pqEnc') + +createSndMessage :: MsgEncodingI e => ChatMsgEvent e -> ConnOrGroupId -> CM SndMessage +createSndMessage chatMsgEvent connOrGroupId = + liftEither . runIdentity =<< lift (createSndMessages $ Identity (connOrGroupId, chatMsgEvent)) + +createSndMessages :: forall e t. (MsgEncodingI e, Traversable t) => t (ConnOrGroupId, ChatMsgEvent e) -> CM' (t (Either ChatError SndMessage)) +createSndMessages idsEvents = do + g <- asks random + vr <- chatVersionRange' + withStoreBatch $ \db -> fmap (createMsg db g vr) idsEvents + where + createMsg :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> (ConnOrGroupId, ChatMsgEvent e) -> IO (Either ChatError SndMessage) + createMsg db g vr (connOrGroupId, evnt) = runExceptT $ do + withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId evnt encodeMessage + where + encodeMessage sharedMsgId = + encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt} + +sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> Connection -> NonEmpty (ChatMsgEvent e) -> GroupId -> CM () +sendGroupMemberMessages user conn events groupId = do + when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn) + let idsEvts = L.map (GroupId groupId,) events + (errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts + unless (null errs) $ toView $ CRChatErrors (Just user) errs + forM_ (L.nonEmpty msgs) $ \msgs' -> + batchSendConnMessages user conn MsgFlags {notification = True} msgs' + +batchSendConnMessages :: User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption) +batchSendConnMessages user conn msgFlags msgs = + batchSendConnMessagesB user conn msgFlags $ L.map Right msgs + +batchSendConnMessagesB :: User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption) +batchSendConnMessagesB _user conn msgFlags msgs_ = do + let batched_ = batchSndMessagesJSON msgs_ + case L.nonEmpty batched_ of + Just batched' -> do + let msgReqs = L.map (fmap (msgBatchReq conn msgFlags)) batched' + delivered <- deliverMessagesB msgReqs + let msgs' = concat $ L.zipWith flattenMsgs batched' delivered + pqEnc = findLastPQEnc delivered + when (length msgs' /= length msgs_) $ logError "batchSendConnMessagesB: msgs_ and msgs' length mismatch" + pure (msgs', pqEnc) + Nothing -> pure ([], Nothing) + where + flattenMsgs :: Either ChatError MsgBatch -> Either ChatError ([Int64], PQEncryption) -> [Either ChatError SndMessage] + flattenMsgs (Right (MsgBatch _ sndMsgs)) (Right _) = map Right sndMsgs + flattenMsgs (Right (MsgBatch _ sndMsgs)) (Left ce) = replicate (length sndMsgs) (Left ce) + flattenMsgs (Left ce) _ = [Left ce] -- restore original ChatError + findLastPQEnc :: NonEmpty (Either ChatError ([Int64], PQEncryption)) -> Maybe PQEncryption + findLastPQEnc = foldr' (\x acc -> case x of Right (_, pqEnc) -> Just pqEnc; Left _ -> acc) Nothing + +batchSndMessagesJSON :: NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch] +batchSndMessagesJSON = batchMessages maxEncodedMsgLength . L.toList + +msgBatchReq :: Connection -> MsgFlags -> MsgBatch -> ChatMsgReq +msgBatchReq conn msgFlags (MsgBatch batchBody sndMsgs) = (conn, msgFlags, batchBody, map (\SndMessage {msgId} -> msgId) sndMsgs) + +encodeConnInfo :: MsgEncodingI e => ChatMsgEvent e -> CM ByteString +encodeConnInfo chatMsgEvent = do + vr <- chatVersionRange + encodeConnInfoPQ PQSupportOff (maxVersion vr) chatMsgEvent + +encodeConnInfoPQ :: MsgEncodingI e => PQSupport -> VersionChat -> ChatMsgEvent e -> CM ByteString +encodeConnInfoPQ pqSup v chatMsgEvent = do + vr <- chatVersionRange + let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent} + case encodeChatMessage maxEncodedInfoLength info of + ECMEncoded connInfo -> case pqSup of + PQSupportOn | v >= pqEncryptionCompressionVersion && B.length connInfo > maxCompressedInfoLength -> do + let connInfo' = compressedBatchMsgBody_ connInfo + when (B.length connInfo' > maxCompressedInfoLength) $ throwChatError $ CEException "large compressed info" + pure connInfo' + _ -> pure connInfo + ECMLarge -> throwChatError $ CEException "large info" + +deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption) +deliverMessage conn cmEventTag msgBody msgId = do + let msgFlags = MsgFlags {notification = hasNotification cmEventTag} + deliverMessage' conn msgFlags msgBody msgId + +deliverMessage' :: Connection -> MsgFlags -> MsgBody -> MessageId -> CM (Int64, PQEncryption) +deliverMessage' conn msgFlags msgBody msgId = + deliverMessages ((conn, msgFlags, msgBody, [msgId]) :| []) >>= \case + r :| [] -> case r of + Right ([deliveryId], pqEnc) -> pure (deliveryId, pqEnc) + Right (deliveryIds, _) -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 delivery id, got " <> show (length deliveryIds) + Left e -> throwError e + rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs) + +-- [MessageId] - SndMessage ids inside MsgBatch, or single message id +type ChatMsgReq = (Connection, MsgFlags, MsgBody, [MessageId]) + +deliverMessages :: NonEmpty ChatMsgReq -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption))) +deliverMessages msgs = deliverMessagesB $ L.map Right msgs + +deliverMessagesB :: NonEmpty (Either ChatError ChatMsgReq) -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption))) +deliverMessagesB msgReqs = do + msgReqs' <- liftIO compressBodies + sent <- L.zipWith prepareBatch msgReqs' <$> withAgent (`sendMessagesB` snd (mapAccumL toAgent Nothing msgReqs')) + lift . void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent) + lift . withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent + where + compressBodies = + forME msgReqs $ \mr@(conn@Connection {pqSupport, connChatVersion = v}, msgFlags, msgBody, msgIds) -> + runExceptT $ case pqSupport of + -- we only compress messages when: + -- 1) PQ support is enabled + -- 2) version is compatible with compression + -- 3) message is longer than max compressed size (as this function is not used for batched messages anyway) + PQSupportOn | v >= pqEncryptionCompressionVersion && B.length msgBody > maxCompressedMsgLength -> do + let msgBody' = compressedBatchMsgBody_ msgBody + when (B.length msgBody' > maxCompressedMsgLength) $ throwError $ ChatError $ CEException "large compressed message" + pure (conn, msgFlags, msgBody', msgIds) + _ -> pure mr + toAgent prev = \case + Right (conn@Connection {connId, pqEncryption}, msgFlags, msgBody, _msgIds) -> + let cId = case prev of + Just prevId | prevId == connId -> "" + _ -> aConnId conn + in (Just connId, Right (cId, pqEncryption, msgFlags, msgBody)) + Left _ce -> (prev, Left (AP.INTERNAL "ChatError, skip")) -- as long as it is Left, the agent batchers should just step over it + prepareBatch (Right req) (Right ar) = Right (req, ar) + prepareBatch (Left ce) _ = Left ce -- restore original ChatError + prepareBatch _ (Left ae) = Left $ ChatErrorAgent ae Nothing + createDelivery :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO (Either ChatError ([Int64], PQEncryption)) + createDelivery db ((Connection {connId}, _, _, msgIds), (agentMsgId, pqEnc')) = do + Right . (,pqEnc') <$> mapM (createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId})) msgIds + updatePQSndEnabled :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO () + updatePQSndEnabled db ((Connection {connId, pqSndEnabled}, _, _, _), (_, pqSndEnabled')) = + case (pqSndEnabled, pqSndEnabled') of + (Just b, b') | b' /= b -> updatePQ + (Nothing, PQEncOn) -> updatePQ + _ -> pure () + where + updatePQ = updateConnPQSndEnabled db connId pqSndEnabled' + +sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage +sendGroupMessage user gInfo members chatMsgEvent = do + sendGroupMessages user gInfo members (chatMsgEvent :| []) >>= \case + ((Right msg) :| [], _) -> pure msg + _ -> throwChatError $ CEInternalError "sendGroupMessage: expected 1 message" + +sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage +sendGroupMessage' user gInfo members chatMsgEvent = + sendGroupMessages_ user gInfo members (chatMsgEvent :| []) >>= \case + ((Right msg) :| [], _) -> pure msg + _ -> throwChatError $ CEInternalError "sendGroupMessage': expected 1 message" + +sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) +sendGroupMessages user gInfo members events = do + when shouldSendProfileUpdate $ + sendProfileUpdate `catchChatError` (toView . CRChatError (Just user)) + sendGroupMessages_ user gInfo members events + where + User {profile = p, userMemberProfileUpdatedAt} = user + GroupInfo {userMemberProfileSentAt} = gInfo + shouldSendProfileUpdate + | incognitoMembership gInfo = False + | otherwise = + case (userMemberProfileSentAt, userMemberProfileUpdatedAt) of + (Just lastSentTs, Just lastUpdateTs) -> lastSentTs < lastUpdateTs + (Nothing, Just _) -> True + _ -> False + sendProfileUpdate = do + let members' = filter (`supportsVersion` memberProfileUpdateVersion) members + profileUpdateEvent = XInfo $ redactedMemberProfile $ fromLocalProfile p + void $ sendGroupMessage' user gInfo members' profileUpdateEvent + currentTs <- liftIO getCurrentTime + withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs + +data GroupSndResult = GroupSndResult + { sentTo :: [(GroupMemberId, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption))], + pending :: [(GroupMemberId, Either ChatError MessageId, Either ChatError ())], + forwarded :: [GroupMember] + } + +sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) +sendGroupMessages_ _user gInfo@GroupInfo {groupId} members events = do + let idsEvts = L.map (GroupId groupId,) events + sndMsgs_ <- lift $ createSndMessages idsEvts + recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) + let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} + (toSendSeparate, toSendBatched, toPending, forwarded, _, dups) = + foldr' addMember ([], [], [], [], S.empty, 0 :: Int) recipientMembers + when (dups /= 0) $ logError $ "sendGroupMessages_: " <> tshow dups <> " duplicate members" + -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here + -- Deliver to toSend members + let (sendToMemIds, msgReqs) = prepareMsgReqs msgFlags sndMsgs_ toSendSeparate toSendBatched + delivered <- maybe (pure []) (fmap L.toList . deliverMessagesB) $ L.nonEmpty msgReqs + when (length delivered /= length sendToMemIds) $ logError "sendGroupMessages_: sendToMemIds and delivered length mismatch" + -- Save as pending for toPending members + let (pendingMemIds, pendingReqs) = preparePending sndMsgs_ toPending + stored <- lift $ withStoreBatch (\db -> map (bindRight $ createPendingMsg db) pendingReqs) + when (length stored /= length pendingMemIds) $ logError "sendGroupMessages_: pendingMemIds and stored length mismatch" + -- Zip for easier access to results + let sentTo = zipWith3 (\mId mReq r -> (mId, fmap (\(_, _, _, msgIds) -> msgIds) mReq, r)) sendToMemIds msgReqs delivered + pending = zipWith3 (\mId pReq r -> (mId, fmap snd pReq, r)) pendingMemIds pendingReqs stored + pure (sndMsgs_, GroupSndResult {sentTo, pending, forwarded}) + where + shuffleMembers :: [GroupMember] -> IO [GroupMember] + shuffleMembers ms = do + let (adminMs, otherMs) = partition isAdmin ms + liftM2 (<>) (shuffle adminMs) (shuffle otherMs) + where + isAdmin GroupMember {memberRole} = memberRole >= GRAdmin + addMember m acc@(toSendSeparate, toSendBatched, pending, forwarded, !mIds, !dups) = + case memberSendAction gInfo events members m of + Just a + | mId `S.member` mIds -> (toSendSeparate, toSendBatched, pending, forwarded, mIds, dups + 1) + | otherwise -> case a of + MSASend conn -> ((m, conn) : toSendSeparate, toSendBatched, pending, forwarded, mIds', dups) + MSASendBatched conn -> (toSendSeparate, (m, conn) : toSendBatched, pending, forwarded, mIds', dups) + MSAPending -> (toSendSeparate, toSendBatched, m : pending, forwarded, mIds', dups) + MSAForwarded -> (toSendSeparate, toSendBatched, pending, m : forwarded, mIds', dups) + Nothing -> acc + where + mId = groupMemberId' m + mIds' = S.insert mId mIds + prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq]) + prepareMsgReqs msgFlags msgs_ toSendSeparate toSendBatched = do + let batched_ = batchSndMessagesJSON msgs_ + case L.nonEmpty batched_ of + Just batched' -> do + let (memsSep, mreqsSep) = foldr' foldMsgs ([], []) toSendSeparate + (memsBtch, mreqsBtch) = foldr' (foldBatches batched') ([], []) toSendBatched + (memsSep <> memsBtch, mreqsSep <> mreqsBtch) + Nothing -> ([], []) + where + foldMsgs :: (GroupMember, Connection) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) + foldMsgs (GroupMember {groupMemberId}, conn) memIdsReqs = + foldr' (\msg_ (memIds, reqs) -> (groupMemberId : memIds, fmap sndMessageReq msg_ : reqs)) memIdsReqs msgs_ + where + sndMessageReq :: SndMessage -> ChatMsgReq + sndMessageReq SndMessage {msgId, msgBody} = (conn, msgFlags, msgBody, [msgId]) + foldBatches :: NonEmpty (Either ChatError MsgBatch) -> (GroupMember, Connection) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) + foldBatches batched' (GroupMember {groupMemberId}, conn) memIdsReqs = + foldr' (\batch_ (memIds, reqs) -> (groupMemberId : memIds, fmap (msgBatchReq conn msgFlags) batch_ : reqs)) memIdsReqs batched' + preparePending :: NonEmpty (Either ChatError SndMessage) -> [GroupMember] -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) + preparePending msgs_ = + foldr' foldMsgs ([], []) + where + foldMsgs :: GroupMember -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) + foldMsgs GroupMember {groupMemberId} memIdsReqs = + foldr' (\msg_ (memIds, reqs) -> (groupMemberId : memIds, fmap pendingReq msg_ : reqs)) memIdsReqs msgs_ + where + pendingReq :: SndMessage -> (GroupMemberId, MessageId) + pendingReq SndMessage {msgId} = (groupMemberId, msgId) + createPendingMsg :: DB.Connection -> (GroupMemberId, MessageId) -> IO (Either ChatError ()) + createPendingMsg db (groupMemberId, msgId) = + createPendingGroupMessage db groupMemberId msgId Nothing $> Right () + +data MemberSendAction = MSASend Connection | MSASendBatched Connection | MSAPending | MSAForwarded + +memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction +memberSendAction gInfo events members m@GroupMember {memberRole} = case memberConn m of + Nothing -> pendingOrForwarded + Just conn@Connection {connStatus} + | connDisabled conn || connStatus == ConnDeleted -> Nothing + | connInactive conn -> Just MSAPending + | connStatus == ConnSndReady || connStatus == ConnReady -> sendBatchedOrSeparate conn + | otherwise -> pendingOrForwarded + where + sendBatchedOrSeparate conn + -- admin doesn't support batch forwarding - send messages separately so that admin can forward one by one + | memberRole >= GRAdmin && not (m `supportsVersion` batchSend2Version) = Just (MSASend conn) + -- either member is not admin, or admin supports batched forwarding + | otherwise = Just (MSASendBatched conn) + pendingOrForwarded = case memberCategory m of + GCUserMember -> Nothing -- shouldn't happen + GCInviteeMember -> Just MSAPending + GCHostMember -> Just MSAPending + GCPreMember -> forwardSupportedOrPending (invitedByGroupMemberId $ membership gInfo) + GCPostMember -> forwardSupportedOrPending (invitedByGroupMemberId m) + where + forwardSupportedOrPending invitingMemberId_ + | membersSupport && all isForwardedGroupMsg events = Just MSAForwarded + | any isXGrpMsgForward events = Nothing + | otherwise = Just MSAPending + where + membersSupport = + m `supportsVersion` groupForwardVersion && invitingMemberSupportsForward + invitingMemberSupportsForward = case invitingMemberId_ of + Just invMemberId -> + -- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember + case find (\m' -> groupMemberId' m' == invMemberId) members of + Just invitingMember -> invitingMember `supportsVersion` groupForwardVersion + Nothing -> False + Nothing -> False + isXGrpMsgForward event = case event of + XGrpMsgForward {} -> True + _ -> False + +sendGroupMemberMessage :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> ChatMsgEvent e -> Maybe Int64 -> CM () -> CM () +sendGroupMemberMessage user gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} chatMsgEvent introId_ postDeliver = do + msg <- createSndMessage chatMsgEvent (GroupId groupId) + messageMember msg `catchChatError` (toView . CRChatError (Just user)) + where + messageMember :: SndMessage -> CM () + messageMember SndMessage {msgId, msgBody} = forM_ (memberSendAction gInfo (chatMsgEvent :| []) [m] m) $ \case + MSASend conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver + MSASendBatched conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver + MSAPending -> withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_ + MSAForwarded -> pure () + +-- TODO ensure order - pending messages interleave with user input messages +sendPendingGroupMessages :: User -> GroupMember -> Connection -> CM () +sendPendingGroupMessages user GroupMember {groupMemberId} conn = do + pgms <- withStore' $ \db -> getPendingGroupMessages db groupMemberId + forM_ (L.nonEmpty pgms) $ \pgms' -> do + let msgs = L.map (\(sndMsg, _, _) -> sndMsg) pgms' + void $ batchSendConnMessages user conn MsgFlags {notification = True} msgs + lift . void . withStoreBatch' $ \db -> L.map (\SndMessage {msgId} -> deletePendingGroupMessage db groupMemberId msgId) msgs + lift . void . withStoreBatch' $ \db -> L.map (\(_, tag, introId_) -> updateIntro_ db tag introId_) pgms' + where + updateIntro_ :: DB.Connection -> ACMEventTag -> Maybe Int64 -> IO () + updateIntro_ db tag introId_ = case (tag, introId_) of + (ACMEventTag _ XGrpMemFwd_, Just introId) -> updateIntroStatus db introId GMIntroInvForwarded + _ -> pure () + +saveDirectRcvMSG :: MsgEncodingI e => Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (Connection, RcvMessage) +saveDirectRcvMSG conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do + conn' <- updatePeerChatVRange conn chatVRange + let agentMsgId = fst $ recipient agentMsgMeta + newMsg = NewRcvMessage {chatMsgEvent, msgBody} + rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} + msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing + pure (conn', msg) + +saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (GroupMember, Connection, RcvMessage) +saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do + (am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- updateMemberChatVRange authorMember conn chatVRange + let agentMsgId = fst $ recipient agentMsgMeta + newMsg = NewRcvMessage {chatMsgEvent, msgBody} + rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} + msg <- + withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId) + `catchChatError` \e -> case e of + ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do + vr <- chatVersionRange + fm <- withStore $ \db -> getGroupMember db vr user groupId forwardedByGroupMemberId + forM_ (memberConn fm) $ \fmConn -> + void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemId) groupId + throwError e + _ -> throwError e + pure (am', conn', msg) + +saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> CM RcvMessage +saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {memberId = refMemberId} msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = do + let newMsg = NewRcvMessage {chatMsgEvent, msgBody} + fwdMemberId = Just $ groupMemberId' forwardingMember + refAuthorId = Just $ groupMemberId' refAuthorMember + withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) + `catchChatError` \e -> case e of + ChatErrorStore (SEDuplicateGroupMessage _ _ (Just authorGroupMemberId) Nothing) -> do + vr <- chatVersionRange + am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db vr user groupId authorGroupMemberId + if sameMemberId refMemberId am + then forM_ (memberConn forwardingMember) $ \fmConn -> + void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemberId) groupId + else toView $ CRMessageError user "error" "saveGroupFwdRcvMsg: referenced author member id doesn't match message member id" + throwError e + _ -> throwError e + +saveSndChatItem :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> CM (ChatItem c 'MDSnd) +saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing Nothing False + +saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd) +saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = + saveSndChatItems user cd [Right NewSndChatItemData {msg, content, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case + [Right ci] -> pure ci + _ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item" + +data NewSndChatItemData c = NewSndChatItemData + { msg :: SndMessage, + content :: CIContent 'MDSnd, + ciFile :: Maybe (CIFile 'MDSnd), + quotedItem :: Maybe (CIQuote c), + itemForwarded :: Maybe CIForwardedFrom + } + +saveSndChatItems :: + forall c. + ChatTypeI c => + User -> + ChatDirection c 'MDSnd -> + [Either ChatError (NewSndChatItemData c)] -> + Maybe CITimed -> + Bool -> + CM [Either ChatError (ChatItem c 'MDSnd)] +saveSndChatItems user cd itemsData itemTimed live = do + createdAt <- liftIO getCurrentTime + when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $ + withStore' (\db -> updateChatTs db user cd createdAt) + lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData) + where + createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd)) + createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, ciFile, quotedItem, itemForwarded} = do + ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt + forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt + pure $ Right $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live createdAt Nothing createdAt + +saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv) +saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = + saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False + +saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDRcv) +saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerTs content ciFile itemTimed live = do + createdAt <- liftIO getCurrentTime + (ciId, quotedItem, itemForwarded) <- withStore' $ \db -> do + when (ciRequiresAttention content || contactChatDeleted cd) $ updateChatTs db user cd createdAt + r@(ciId, _, _) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt + forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt + pure r + pure $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live brokerTs forwardedByMember createdAt + +mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d +mkChatItem cd ciId content file quotedItem sharedMsgId itemForwarded itemTimed live itemTs forwardedByMember currentTs = + let itemText = ciContentToText content + itemStatus = ciCreateStatus content + meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs + in ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file} + +createAgentConnectionAsync :: ConnectionModeI c => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> CM (CommandId, ConnId) +createAgentConnectionAsync user cmdFunction enableNtfs cMode subMode = do + cmdId <- withStore' $ \db -> createCommand db user Nothing cmdFunction + connId <- withAgent $ \a -> createConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cMode IKPQOff subMode + pure (cmdId, connId) + +joinAgentConnectionAsync :: User -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> CM (CommandId, ConnId) +joinAgentConnectionAsync user enableNtfs cReqUri cInfo subMode = do + cmdId <- withStore' $ \db -> createCommand db user Nothing CFJoinConn + connId <- withAgent $ \a -> joinConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cReqUri cInfo PQSupportOff subMode + pure (cmdId, connId) + +allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> ChatMsgEvent e -> CM () +allowAgentConnectionAsync user conn@Connection {connId, pqSupport, connChatVersion} confId msg = do + cmdId <- withStore' $ \db -> createCommand db user (Just connId) CFAllowConn + dm <- encodeConnInfoPQ pqSupport connChatVersion msg + withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm + withStore' $ \db -> updateConnectionStatus db conn ConnAccepted + +agentAcceptContactAsync :: MsgEncodingI e => User -> Bool -> InvitationId -> ChatMsgEvent e -> SubscriptionMode -> PQSupport -> VersionChat -> CM (CommandId, ConnId) +agentAcceptContactAsync user enableNtfs invId msg subMode pqSup chatV = do + cmdId <- withStore' $ \db -> createCommand db user Nothing CFAcceptContact + dm <- encodeConnInfoPQ pqSup chatV msg + connId <- withAgent $ \a -> acceptContactAsync a (aCorrId cmdId) enableNtfs invId dm pqSup subMode + pure (cmdId, connId) + +deleteAgentConnectionAsync :: User -> ConnId -> CM () +deleteAgentConnectionAsync user acId = deleteAgentConnectionAsync' user acId False + +deleteAgentConnectionAsync' :: User -> ConnId -> Bool -> CM () +deleteAgentConnectionAsync' user acId waitDelivery = do + withAgent (\a -> deleteConnectionAsync a waitDelivery acId) `catchChatError` (toView . CRChatError (Just user)) + +deleteAgentConnectionsAsync :: User -> [ConnId] -> CM () +deleteAgentConnectionsAsync user acIds = deleteAgentConnectionsAsync' user acIds False + +deleteAgentConnectionsAsync' :: User -> [ConnId] -> Bool -> CM () +deleteAgentConnectionsAsync' _ [] _ = pure () +deleteAgentConnectionsAsync' user acIds waitDelivery = do + withAgent (\a -> deleteConnectionsAsync a waitDelivery acIds) `catchChatError` (toView . CRChatError (Just user)) + +agentXFTPDeleteRcvFile :: RcvFileId -> FileTransferId -> CM () +agentXFTPDeleteRcvFile aFileId fileId = do + lift $ withAgent' (`xftpDeleteRcvFile` aFileId) + withStore' $ \db -> setRcvFTAgentDeleted db fileId + +agentXFTPDeleteRcvFiles :: [(XFTPRcvFile, FileTransferId)] -> CM' () +agentXFTPDeleteRcvFiles rcvFiles = do + let rcvFiles' = filter (not . agentRcvFileDeleted . fst) rcvFiles + rfIds = mapMaybe fileIds rcvFiles' + withAgent' $ \a -> xftpDeleteRcvFiles a (map fst rfIds) + void . withStoreBatch' $ \db -> map (setRcvFTAgentDeleted db . snd) rfIds + where + fileIds :: (XFTPRcvFile, FileTransferId) -> Maybe (RcvFileId, FileTransferId) + fileIds (XFTPRcvFile {agentRcvFileId = Just (AgentRcvFileId aFileId)}, fileId) = Just (aFileId, fileId) + fileIds _ = Nothing + +agentXFTPDeleteSndFileRemote :: User -> XFTPSndFile -> FileTransferId -> CM' () +agentXFTPDeleteSndFileRemote user xsf fileId = + agentXFTPDeleteSndFilesRemote user [(xsf, fileId)] + +agentXFTPDeleteSndFilesRemote :: User -> [(XFTPSndFile, FileTransferId)] -> CM' () +agentXFTPDeleteSndFilesRemote user sndFiles = do + (_errs, redirects) <- partitionEithers <$> withStoreBatch' (\db -> map (lookupFileTransferRedirectMeta db user . snd) sndFiles) + let redirects' = mapMaybe mapRedirectMeta $ concat redirects + sndFilesAll = redirects' <> sndFiles + sndFilesAll' = filter (not . agentSndFileDeleted . fst) sndFilesAll + -- while file is being prepared and uploaded, it would not have description available; + -- this partitions files into those with and without descriptions - + -- files with description are deleted remotely, files without description are deleted internally + (sfsNoDescr, sfsWithDescr) <- partitionSndDescr sndFilesAll' [] [] + withAgent' $ \a -> xftpDeleteSndFilesInternal a sfsNoDescr + withAgent' $ \a -> xftpDeleteSndFilesRemote a (aUserId user) sfsWithDescr + void . withStoreBatch' $ \db -> map (setSndFTAgentDeleted db user . snd) sndFilesAll' + where + mapRedirectMeta :: FileTransferMeta -> Maybe (XFTPSndFile, FileTransferId) + mapRedirectMeta FileTransferMeta {fileId = fileId, xftpSndFile = Just sndFileRedirect} = Just (sndFileRedirect, fileId) + mapRedirectMeta _ = Nothing + partitionSndDescr :: + [(XFTPSndFile, FileTransferId)] -> + [SndFileId] -> + [(SndFileId, ValidFileDescription 'FSender)] -> + CM' ([SndFileId], [(SndFileId, ValidFileDescription 'FSender)]) + partitionSndDescr [] filesWithoutDescr filesWithDescr = pure (filesWithoutDescr, filesWithDescr) + partitionSndDescr ((XFTPSndFile {agentSndFileId = AgentSndFileId aFileId, privateSndFileDescr}, _) : xsfs) filesWithoutDescr filesWithDescr = + case privateSndFileDescr of + Nothing -> partitionSndDescr xsfs (aFileId : filesWithoutDescr) filesWithDescr + Just sfdText -> + tryChatError' (parseFileDescription sfdText) >>= \case + Left _ -> partitionSndDescr xsfs (aFileId : filesWithoutDescr) filesWithDescr + Right sfd -> partitionSndDescr xsfs filesWithoutDescr ((aFileId, sfd) : filesWithDescr) + +userProfileToSend :: User -> Maybe Profile -> Maybe Contact -> Bool -> Profile +userProfileToSend user@User {profile = p} incognitoProfile ct inGroup = do + let p' = fromMaybe (fromLocalProfile p) incognitoProfile + if inGroup + then redactedMemberProfile p' + else + let userPrefs = maybe (preferences' user) (const Nothing) incognitoProfile + in (p' :: Profile) {preferences = Just . toChatPrefs $ mergePreferences (userPreferences <$> ct) userPrefs} + +createRcvFeatureItems :: User -> Contact -> Contact -> CM' () +createRcvFeatureItems user ct ct' = + createFeatureItems user ct ct' CDDirectRcv CIRcvChatFeature CIRcvChatPreference contactPreference + +createSndFeatureItems :: User -> Contact -> Contact -> CM' () +createSndFeatureItems user ct ct' = + createFeatureItems user ct ct' CDDirectSnd CISndChatFeature CISndChatPreference getPref + where + getPref ContactUserPreference {userPreference} = case userPreference of + CUPContact {preference} -> preference + CUPUser {preference} -> preference + +type FeatureContent a d = ChatFeature -> a -> Maybe Int -> CIContent d + +createFeatureItems :: + MsgDirectionI d => + User -> + Contact -> + Contact -> + (Contact -> ChatDirection 'CTDirect d) -> + FeatureContent PrefEnabled d -> + FeatureContent FeatureAllowed d -> + (forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) -> + CM' () +createFeatureItems user ct ct' = createContactsFeatureItems user [(ct, ct')] + +createContactsFeatureItems :: + forall d. + MsgDirectionI d => + User -> + [(Contact, Contact)] -> + (Contact -> ChatDirection 'CTDirect d) -> + FeatureContent PrefEnabled d -> + FeatureContent FeatureAllowed d -> + (forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) -> + CM' () +createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do + let dirsCIContents = map contactChangedFeatures cts + (errs, acis) <- partitionEithers <$> createInternalItemsForChats user Nothing dirsCIContents + unless (null errs) $ toView' $ CRChatErrors (Just user) errs + toView' $ CRNewChatItems user acis + where + contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, [CIContent d]) + contactChangedFeatures (Contact {mergedPreferences = cups}, ct'@Contact {mergedPreferences = cups'}) = do + let contents = mapMaybe (\(ACF f) -> featureCIContent_ f) allChatFeatures + (chatDir ct', contents) + where + featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d) + featureCIContent_ f + | state /= state' = Just $ fContent ciFeature state' + | prefState /= prefState' = Just $ fContent ciOffer prefState' + | otherwise = Nothing + where + fContent :: FeatureContent a d -> (a, Maybe Int) -> CIContent d + fContent ci (s, param) = ci f' s param + f' = chatFeature f + state = featureState cup + state' = featureState cup' + prefState = preferenceState $ getPref cup + prefState' = preferenceState $ getPref cup' + cup = getContactUserPreference f cups + cup' = getContactUserPreference f cups' + +createGroupFeatureChangedItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> GroupInfo -> CM () +createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences = gps} GroupInfo {fullGroupPreferences = gps'} = + forM_ allGroupFeatures $ \(AGF f) -> do + let state = groupFeatureState $ getGroupPreference f gps + pref' = getGroupPreference f gps' + state'@(_, param', role') = groupFeatureState pref' + when (state /= state') $ + createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref') param' role') Nothing + +sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool +sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing} + +createGroupFeatureItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> CM () +createGroupFeatureItems user cd ciContent GroupInfo {fullGroupPreferences} = + forM_ allGroupFeatures $ \(AGF f) -> do + let p = getGroupPreference f fullGroupPreferences + (_, param, role) = groupFeatureState p + createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing + +createInternalChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM () +createInternalChatItem user cd content itemTs_ = + lift (createInternalItemsForChats user itemTs_ [(cd, [content])]) >>= \case + [Right aci] -> toView $ CRNewChatItems user [aci] + [Left e] -> throwError e + rs -> throwChatError $ CEInternalError $ "createInternalChatItem: expected 1 result, got " <> show (length rs) + +createInternalItemsForChats :: + forall c d. + (ChatTypeI c, MsgDirectionI d) => + User -> + Maybe UTCTime -> + [(ChatDirection c d, [CIContent d])] -> + CM' [Either ChatError AChatItem] +createInternalItemsForChats user itemTs_ dirsCIContents = do + createdAt <- liftIO getCurrentTime + let itemTs = fromMaybe createdAt itemTs_ + void . withStoreBatch' $ \db -> map (uncurry $ updateChat db createdAt) dirsCIContents + withStoreBatch' $ \db -> concatMap (uncurry $ createACIs db itemTs createdAt) dirsCIContents + where + updateChat :: DB.Connection -> UTCTime -> ChatDirection c d -> [CIContent d] -> IO () + updateChat db createdAt cd contents + | any ciRequiresAttention contents || contactChatDeleted cd = updateChatTs db user cd createdAt + | otherwise = pure () + createACIs :: DB.Connection -> UTCTime -> UTCTime -> ChatDirection c d -> [CIContent d] -> [IO AChatItem] + createACIs db itemTs createdAt cd = map $ \content -> do + ciId <- createNewChatItemNoMsg db user cd content itemTs createdAt + let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing Nothing False itemTs Nothing createdAt + pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci + +createLocalChatItems :: + User -> + ChatDirection 'CTLocal 'MDSnd -> + [(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom)] -> + UTCTime -> + CM [ChatItem 'CTLocal 'MDSnd] +createLocalChatItems user cd itemsData createdAt = do + withStore' $ \db -> updateChatTs db user cd createdAt + (errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) itemsData) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure items + where + createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom) -> IO (ChatItem 'CTLocal 'MDSnd) + createItem db (content, ciFile, itemForwarded) = do + ciId <- createNewChatItem_ db user cd Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False createdAt Nothing createdAt + forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt + pure $ mkChatItem cd ciId content ciFile Nothing Nothing itemForwarded Nothing False createdAt Nothing createdAt + +withUser' :: (User -> CM ChatResponse) -> CM ChatResponse +withUser' action = + asks currentUser + >>= readTVarIO + >>= maybe (throwChatError CENoActiveUser) run + where + run u = action u `catchChatError` (pure . CRChatCmdError (Just u)) + +withUser :: (User -> CM ChatResponse) -> CM ChatResponse +withUser action = withUser' $ \user -> + ifM (lift chatStarted) (action user) (throwChatError CEChatNotStarted) + +withUser_ :: CM ChatResponse -> CM ChatResponse +withUser_ = withUser . const + +withUserId' :: UserId -> (User -> CM ChatResponse) -> CM ChatResponse +withUserId' userId action = withUser' $ \user -> do + checkSameUser userId user + action user + +withUserId :: UserId -> (User -> CM ChatResponse) -> CM ChatResponse +withUserId userId action = withUser $ \user -> do + checkSameUser userId user + action user + +checkSameUser :: UserId -> User -> CM () +checkSameUser userId User {userId = activeUserId} = when (userId /= activeUserId) $ throwChatError (CEDifferentActiveUser userId activeUserId) + +chatStarted :: CM' Bool +chatStarted = fmap isJust . readTVarIO =<< asks agentAsync + +waitChatStartedAndActivated :: CM' () +waitChatStartedAndActivated = do + agentStarted <- asks agentAsync + chatActivated <- asks chatActivated + atomically $ do + started <- readTVar agentStarted + activated <- readTVar chatActivated + unless (isJust started && activated) retry + +chatVersionRange :: CM VersionRangeChat +chatVersionRange = lift chatVersionRange' +{-# INLINE chatVersionRange #-} + +chatVersionRange' :: CM' VersionRangeChat +chatVersionRange' = do + ChatConfig {chatVRange} <- asks config + pure chatVRange +{-# INLINE chatVersionRange' #-} + +adminContactReq :: ConnReqContact +adminContactReq = + either error id $ strDecode "simplex:/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23MCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%3D" + +simplexTeamContactProfile :: Profile +simplexTeamContactProfile = + Profile + { displayName = "SimpleX Chat team", + fullName = "", + image = Just (ImageData "data:image/jpg;base64,/9j/4AAQSkZJRgABAgAAAQABAAD/2wBDAAUDBAQEAwUEBAQFBQUGBwwIBwcHBw8KCwkMEQ8SEhEPERATFhwXExQaFRARGCEYGhwdHx8fExciJCIeJBweHx7/2wBDAQUFBQcGBw4ICA4eFBEUHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh7/wAARCAETARMDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREAAgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD7LooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiivP/iF4yFvv0rSpAZek0yn7v+yPeunC4WpiqihBf8A8rOc5w2UYZ4jEPTourfZDvH3jL7MW03SpR53SWUfw+w96veA/F0erRLY3zKl6owD2k/8Ar15EWLEljknqadDK8MqyxMUdTlWB5Br66WS0Hh/ZLfv1ufiNLj7Mo5m8ZJ3g9OTpy+Xn5/pofRdFcd4B8XR6tEthfMEvVHyk9JB/jXY18fiMPUw9R06i1P3PK80w2aYaOIw8rxf3p9n5hRRRWB6AUUVDe3UFlavc3MixxIMsxppNuyJnOMIuUnZIL26gsrV7m5kWOJBlmNeU+I/Gd9e6sk1hI8FvA2Y1z973NVPGnimfXLoxRFo7JD8if3vc1zefevr8syiNKPtKyvJ9Ox+F8Ycb1cdU+rYCTjTi/iWjk1+nbue3eEPEdtrtoMER3SD95Hn9R7Vu18+6bf3On3kd1aSmOVDkEd/Y17J4P8SW2vWY6R3aD97F/Ue1eVmmVPDP2lP4fyPtODeMoZrBYXFO1Zf+Tf8AB7r5o3qKKK8Q/QgooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAqavbTXmmz20Fw1vJIhVZB1FeDa3p15pWoSWl6hWQHr2YeoNfQlY3izw9Z6/YGGZQky8xSgcqf8K9jKcyWEnyzXuv8D4njLhZ51RVSi7VYLRdGu3k+z+88HzRuq1rWmXmkX8lnexFHU8Hsw9RVLNfcxlGcVKLumfgFahUozdOorSWjT6E0M0kMqyxOyOpyrKcEGvXPAPjCPVolsb9wl6owGPAkH+NeO5p8M0kMqyxOyOpyrA4INcWPy+njKfLLfoz2+HuIMTkmI9pT1i/ij0a/wA+zPpGiuM+H/jCPV4lsL91S+QfKTwJR/jXW3t1BZWslzcyLHFGMsxNfB4jC1aFX2U1r+fof0Rl2bYXMMKsVRl7vXy7p9rBfXVvZWr3NzKscSDLMTXjnjbxVPrtyYoiY7JD8if3vc0zxv4ruNeujFEWjsoz8if3vc1zOa+synKFh0qtVe9+X/BPxvjLjKWZSeEwjtSW7/m/4H5kmaM1HmlB54r3bH51YkzXo3wz8MXMc0es3ZeED/VR5wW9z7VB8O/BpnMerarEREDuhhb+L3Pt7V6cAAAAAAOgFfL5xmqs6FH5v9D9a4H4MlzQzHGq1tYR/KT/AEXzCiiivlj9hCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxfFvh208QWBhmASdRmKUdVP+FeH63pl5pGoSWV5EUdTwezD1HtX0VWL4t8O2fiHTzBONk6g+TKByp/wr28pzZ4WXs6msH+B8NxdwhTzeDxGHVqy/8m8n59n954FmjNW9b0y80fUHsr2MpIp4PZh6iqWfevuYyjOKlF3TPwetQnRm6dRWktGmSwzSQyrLE7I6nKsDgg1teIPFOqa3a29vdy4jiUAheN7f3jWBmjNROhTnJTkrtbGtLF4ijSnRpzajPddHbuP3e9Lmo80ua0scth+a9E+HXgw3Hl6tqsZEX3oYmH3vc+1J8OPBZnKavq0eIhzDCw+9/tH29q9SAAAAGAOgr5bOM35b0KD16v8ARH6twXwXz8uPx0dN4xfXzf6IFAUAAAAdBRRRXyZ+wBRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFB4GTXyj+1p+0ONJjufA3ga6DX7qU1DUY24gB4McZH8Xqe38tqFCdefLETaSufQ3h/4geEde8Uah4a0rWra51Ow/wBfCrD8ceuO+OldRX5I+GfEWseG/ENvr2j30ttqFvJ5iSqxyT3z6g96/RH9nD41aT8U9AWGcx2fiK1QC7tC33/+mieqn07V14zL3QXNHVEQnc9dooorzjQKKKKACiis7xHrel+HdGudY1m8is7K2QvLLI2AAP600m3ZAYfxUg8Pr4VutT1+7isYbSMuLp/4Pb3z6V8++HNd0zxDpq6hpVys8DHGRwVPoR2NeIftJ/G7VPifrbWVk8lp4btZD9mtwcGU/wDPR/c9h2rgfh34z1LwdrAurV2ktZCBcW5PyyD/AB9DX2WTyqYWny1Ho+nY+C4t4Wp5tF16CtVX/k3k/Ps/vPr/ADRmsjwx4g07xFpMWpaZOJInHI/iQ9wR61qbq+mVmro/D6tCdGbp1FZrdEma6/4XafpWoa7jUpV3oA0MLdJD/ntXG5p8E0kMqyxOyOhyrKcEGsMTRlWpShGVm+p1ZbiYYPFQr1IKai72fU+nFAUAKAAOABRXEfDnxpFrMK6fqDhL9BhSeko9frXb1+a4rDVMNUdOotT+k8szLD5lh44jDu8X968n5hRRRXOegFFFFABUGoXlvYWkl1dSrHFGMliaL+7t7C0kuruVYoYxlmNeI+OvFtx4huzHFuisYz+7jz97/aNenluW1MbU00it2fM8S8SUMkoXetR/DH9X5fmeteF/E+m+IFkFoxSWMnMb9cev0rbr5t0vULrTb6K8s5TFNGcgj+R9q9w8E+KbXxDYjlY7xB+9i/qPaurNsneE/eUtYfkeTwlxjHNV9XxVo1V90vTz8vmjoqKKK8I+8CiiigAooooAKKKKACiiigD5V/a8+P0mgvdeAvCUskepFdl9eDjyQR9xPfHeviiR3lkaSR2d2OWZjkk+tfoj+058CtP+Jektq2jxRWnie2T91KMKLlR/yzf+h7V+fOuaVqGiarcaXqtpLaXls5jlikXDKRX0mWSpOlaG/U56l76lKtPwtr+reGNetdb0S8ls761cPHJG2D9D6g9MVmUV6TSasyD9Jf2cfjXpPxR0MW9w0dp4gtkAubYnHmf7aeo/lXr1fkh4W1/V/DGuW2taHey2d9bOHjkjP6H1HtX6Jfs5fGvR/inoQgmeOz8RWqD7XaE439vMT1U+navnMfgHRfPD4fyN4Tvoz12iis7xJremeHdEutZ1i7jtLK1jLyyucAAf1rzUm3ZGgeJNb0vw7otzrOs3kVpZWyF5ZZDgAD+Z9q/PL9pP436r8UNZaxs2ks/Dlq5+z24ODMf77+p9B2o/aU+N2p/FDXDZ2LS2fhy1ci3t84Mx/wCej+/oO1eNV9DgMAqS55/F+RhOd9EFFFABJwBkmvUMzqPh34y1Lwjq63FszSWshAntyeHHt719Z2EstzpVlqD2txbR3kCzxLPGUbawyODXK/slfs8nUpbXx144tGFkhElhp8q4849pHB/h9B3r608X+GLDxBpX2WRFiljX9xIowUPYfT2rGnnkMPWVJ6x6vt/XU+P4o4SjmtN4igrVV/5N5Pz7P7z56zRmrmvaVe6LqMljexMkiHg9mHqKoZr6uEozipRd0z8Rq0J0ZunUVmtGmTwTSQTJNC7JIhyrKcEGvZvhz41j1mJdP1GRUv0GFY8CX/69eJZqSCaWCVZYXZHU5VlOCDXDmGXU8bT5ZaPo+x7WQZ9iMlxHtKesX8UejX+fZn1FRXDfDbxtHrUKadqDqmoIuAx4EoHf613NfnWKwtTC1HTqKzR/QGW5lh8yw8cRh3eL+9Ps/MKr6heW1hZyXd3KsUUYyzGjUby20+zku7yZYoY13MzGvDPHvi+48RXpjiZorCM/u4/73+0feuvLMsqY6pZaRW7/AK6nlcScR0MloXetR/DH9X5D/Hni648Q3nlxlo7GM/u48/e9zXL7qZmjNfodDDwoU1TpqyR+AY7G18dXlXryvJ/19w/dVvSdRutMvo7yzlaOVDkY7+xqkDmvTPhn4HMxj1jV4v3Y+aCFh97/AGjWGPxNHDUXKrt27+R15JlWLzHFxp4XSS1v/L53PQ/C+oXGqaJb3t1bNbyyLkoe/v8AQ1p0AAAAAADoBRX5nUkpSbirLsf0lh6c6dKMJy5mkrvv5hRRRUGwUUUUAFFFFABRRRQAV4d+038CdO+JWkyavo8cdp4mtkzHIBhbkD+B/f0Ne40VpSqypSUovUTV9GfkTruk6joer3Ok6taS2d7ayGOaGVdrKRVKv0T/AGnfgXp/xK0h9Y0iOO18TWqZikAwLkD+B/6Gvz51zStQ0TVbjS9UtZbW8tnKSxSLgqRX1GExccRG636o55RcSlWp4V1/VvDGvWut6JeSWl9bOGjkQ4/A+oPpWXRXU0mrMk/RP4LftDeFvF3ge41HxDfW+lappkG+/idsBwP40HfJ7V8o/tJ/G/VPifrbWVk8tn4btn/0e2zgykfxv6n0HavGwSM4JGeuO9JXFRwFKlUc18vIpzbVgoooAJIAGSa7SQr6x/ZM/Z4k1J7Xxz44tClkMSWFhIuDL3Ejg/w+g70fsmfs8NqMtt448c2eLJCJLCwlX/WnqHcH+H0HevtFFVECIoVVGAAMACvFx+PtenTfqzWEOrEjRI41jjUIigBVAwAPSnUUV4ZsYXjLwzZeJNOaCcBLhQfJmA5U/wCFeBa/pV7ompSWF9GUkToccMOxHtX01WF4z8M2XiXTTBOAk6AmGYDlD/hXvZPnEsHL2dTWD/A+K4r4UhmsHXoK1Zf+TeT8+z+8+c80Zq5r2k3ui6jJY30ZSRTwezD1FUM1+gQlGcVKLumfiFWjOjN06is1umTwTSQTJNE7JIh3KynBBr2PwL8QrO701odbnSC5t0yZCcCUD+teK5pd1cWPy2ljoctTdbPqetkme4rJ6rqUHdPdPZ/8Mdb4/wDGFz4ivDFGxisIz+7j/ve5rls1HuozXTQw1PD01TpqyR5+OxlfHV5V68ryf9fcSZozTAa9P+GHgQzmPWdZhIjHzQQMPvf7R9qxxuMpYOk6lR/8E6MpyfEZriFQoL1fRLux/wAMvApmMesazFiP70EDfxf7R9vavWFAUAAAAcACgAAAAAAdBRX5xjsdVxtXnn8l2P3/ACXJcNlGHVGivV9W/wCugUUUVxHrhRRRQAUUUUAFFFFABRRRQAUUUUAFeH/tOfArT/iXpUmsaSsVp4mto/3UuMLcgDhH/oe1e4Vn+I9a0zw7otzrGsXkVpZWyF5ZZGwAB/WtaNSdOalDcTSa1PyZ1zStQ0TVrnStVtZLS8tnMcsUgwVIqlXp/wC0l8S7T4nePn1aw0q3srO3XyYJBGBNOoPDSHv7DtXmFfXU5SlBOSszlYUUUVYAAScDk19Zfsmfs7vqLW3jjx1ZFLMESafYSjmXuJHHZfQd6+VtLvJtO1K2v7cRtLbyrKgkQOpKnIyp4I46Gv0b/Zv+NOjfFDw+lrIIrDX7RAtzZ8AMMffj9V9u1efmVSrCn7m3Vl00m9T16NEjjWONVRFGFUDAA9KWiivmToCiiigAooooAwfGnhiy8S6cYJwEuEH7mYDlT/hXz7r+k32h6lJYahFskQ8Hsw9QfSvpjUr2106ykvLyZYYYxlmY18+/EXxa/ijU1aOMRWkGRCCBuPuT/Svr+GK2KcnTSvT/ACfl/kfmPiBhMvUI1m7Vn0XVefp0fy9Oa3UbqZmjNfa2PynlJM+9AOajzTo5GjkV0YqynIPoaVg5T1P4XeA/P8vWdaiIj+9BAw+9/tH29q9dAAAAAAHQVwPwx8dQ63Ammai6R6hGuFJ4Ew9vf2rvq/Ms5qYmeJaxGjWy6W8j+gOFcPl9LAReBd0931b8+3oFFFFeSfSBRRRQAUUUUAFFFFABRRRQAUUUUAFFFZ3iTW9L8OaJdazrN5HaWNqheWWQ4AH+NNJt2QB4l1vTPDmiXWs6xdx2llaxl5ZHOAAO3ufavzx/aT+N2qfFDWzZWbSWfhy2ci3tg2DKf77+p9B2pf2lfjdqfxQ1trGxeW08N2z/AOj2+cGYj/lo/v6DtXjVfQ4DAKkuefxfkYTnfRBRRQAScAZNeoZhRXv3w2/Zh8V+Lfh7deJprgadcvHv02zlT5rgdcsf4Qe1eHa5pWoaJq1zpWq2ktpeW0hjlikXDKwrOFanUk4xd2htNFKtTwrr+reGNdtta0S8ltL22cPHIhx07H1HtWXRWjSasxH6S/s4/GrSfijoYtp3jtfENqg+1WpON4/vp6j27V69X5IeFfEGr+F9etdc0O9ks7+1cPHKh/QjuD3Ffoj+zl8bNI+KWhLbztFZ+IraMfa7TON+Osieqn07V85j8A6L54fD+RvCd9GevUUUV5hoFVtTvrXTbGW9vJligiXczNRqd9aabYy3t7MsMEQyzMa+ffiN42uvE96YoS0OmxH91F3b/ab3r1spympmFSy0it3+i8z57iDiCjlFG71qPZfq/Id8RPGl14lvTFEzRafGf3cf97/aNclmmZozX6Xh8NTw1NU6askfheNxdbG1pV68ryY/NGTTM16R4J+GVxrGkSX+pSSWfmJ/oq45J7MR6Vni8ZRwkOes7I1y7K8TmNX2WHjd7/0zzvJozV3xDpF7oepyWF/EUkQ8HHDD1FZ+feuiEozipRd0zjq0Z0puE1ZrdE0E8sEyTQu0ciHKspwQa9z+GHjuLXIU0zUpFTUEXCseBKB/WvBs1JBPLBMk0LmORCGVlOCDXn5lllLH0uWWjWz7HsZFnlfJ6/tKesXuu6/z7M+tKK4D4X+PItdhTTNSdY9SQYVicCYDuPf2rv6/M8XhKuEqulVVmj92y7MaGYUFXoO6f4Ps/MKKKK5juCiiigAooooAKKKKACiig9KAM7xLrmleG9EudZ1q8jtLG2QvLK5wAPQep9q/PH9pP43ap8T9beyspJbTw3bSH7NbZx5pH8b+p9u1bH7YPxL8XeJPG114V1G0udH0jT5SIrNuDOR0kbs2e3pXgdfRZfgVTSqT3/IwnO+iCiigAkgAZJr1DMK+s/2TP2d31Brbxz46tNtmMSafp8i8y9/MkB6L0wO9J+yb+zwdSe28b+ObLFmpEljYSr/rT1DuP7voO9faCKqIERQqqMAAYAFeLj8fa9Om/VmsIdWEaJGixooVFGFUDAA9K8Q/ac+BWnfErSZNY0mOO08T2yZilAwtyAPuP/Q9q9worx6VWVKSlF6mrSasfkTrmlahomrXOlaray2l7bSGOaKRcMrCqVfon+098C7D4l6U+s6Skdr4mtY/3UmMC5UdI29/Q1+fOt6XqGi6rcaVqlrJa3ls5SWKQYKkV9RhMXHERut+qOeUeUpVqeFfEGreGNdttb0W7ktb22cNG6HH4H1FZdFdTSasyT9Jf2cPjVpXxR0Fbe4eK18Q2qD7Va7sbx/z0T1H8q9V1O+tdNsZb29mWGCJdzMxr8ovAOoeIdK8W2GoeF5podVhlDQtEefcH2PevsbxP4417xTp1jDq3lQGKFPOigJ2NLj5m59849K4KHD0sTX9x2h18vJHj55xDSyqhd61Hsv1fkaXxG8bXXie9MURaLTo2/dR5+9/tH3rkM1HmjNffYfC08NTVOmrJH4ljMXWxtaVau7yZJmgHmmAmvWfhN8PTceVrmuQkRDDW9uw+9/tN7Vjj8dSwNJ1ar9F3OjK8pr5nXVGivV9Eu7H/Cf4emcx63rkJEfDW9u4+9/tMPT2r2RQFAVQABwAKAAAAAAB0Aor8uzDMKuOq+0qfJdj9zyjKMPlVBUaK9X1bOf8b+FbHxRppt7gCO4UfuZwOUP9R7V86+IdHv8AQtTk0/UIikqHg9mHqD6V9VVz3jnwrY+KNMNvcKEuEBME2OUP+FenkmdywUvZVdab/A8PijheGZw9vQVqq/8AJvJ+fZnzLuo3Ve8Q6Pf6FqclhqERjkQ8Hsw9Qazs1+jwlGpFSi7pn4xVozpTcJqzW6J7eeSCZJoZGjkQhlZTgg17t8LvHsWuQppmpOseooMKxPEw/wAa8DzV3Q7fULvVIIdLWQ3ZcGMx8EH1z2rzs1y2jjaLVTRrZ9v+AezkGcYnK8SpUVzKWjj3/wCD2PrCiqOgx38Oj20eqTJNeLGBK6jAJq9X5VOPLJq9z98pyc4KTVr9H0CiiipLCiiigAooooAKKKKAPK/2hfg3o/xT8PFdsVprlupNnebec/3W9VNfnR4y8Naz4R8RXWg69ZvaXts5V1YcEdmB7g9jX6115V+0P8GtF+Knh05SO0161UmzvQuD/uP6qf0r08DjnRfJP4fyM5wvqj80RycCvrP9kz9ndtRNr458dWTLaAiTT9PlXBl9JJB/d7gd+tXv2bv2Y7yz19vEHxFs1VbKYi1sCQwlZTw7f7PcDvX2CiLGioihVUYAAwAK6cfmGns6T9WTCHVhGiRoqRqFRRgKBgAUtFFeGbBRRRQAV4h+038CtP8AiZpTatpCQ2fia2jPlS4wtyo52P8A0Pavb6K0pVZUpKUXqJq+jPyJ1zStQ0TVrnStVtJbS9tnMcsUgwVIqPS7C61O+isrKFpZ5W2qor9AP2r/AIM6J448OzeJLV7fTtesoyRO3yrcqP4H9/Q14F8OvBlp4XsvMkCTajKP3suM7f8AZX0H86+1yiDzFcy0S3Pms+zqllNLXWb2X6vyH/DnwZaeF7EPIEm1CUDzZcfd/wBke1dfmo80ua+0pUY0oqMVofjWLxNXF1XWrO8mSZozUea9N+B/hTTdau5NUv5opvsrjbak8k9mYelc+OxcMHQlWqbI1y3LqmYYmOHpbvuafwj+HhnMWva5DiMENb27D73ozD09q9oAAAAAAHQCkUBVCqAAOABS1+U5jmNXH1XUqfJdj9yyjKKGV0FRor1fVsKKKK4D1AooooA57xz4UsPFOmG3uFEdwgJgnA5Q/wBR7V84eI9Gv9A1SXT9RhMcqHg/wuOxB7ivrCud8d+E7DxTpZt51CXKDMEwHKn/AAr6LI88lgpeyq603+Hmv1Pj+J+GIZnB16KtVX/k3k/Psz5p0uxu9Tv4rGxheaeVtqIoyTX0T8OPBNp4XsRJKFm1GQfvZf7v+yvtR8OfBFn4UtDIxW41CUfvJsdB/dX0FdfWue568W3RoP3Pz/4BhwvwtHL0sTiVeq9l/L/wQooor5g+3CiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKrarf2ml2E19fTpBbwrud2OAKTVdQtNLsJb6+mWGCJcszGvm34nePLzxXfmGEtDpkTfuos/f/wBpvevZyfJ6uZVbLSC3f6LzPBz3PaOVUbvWb2X6vyH/ABM8d3fiq/MULPDpsR/dRdN3+03vXF5pm6jdX6phsLTw1JUqSskfjGLxVbGVnWrO8mSZ96M0wGnSq8UhjkRkdeCrDBFb2OXlFzWn4b1y/wBA1SPUNPmMciHkdmHoR6Vk7hS596ipTjUi4zV0y6c50pqcHZrZn1X4C8W2HizShc27BLmMATwZ5Q/4V0dfIfhvXL/w/qseo6dMY5U6js47gj0r6Y8BeLtP8WaUtzbER3KAefATyh/qPevzPPshlgJe1pa03+Hk/wBGfr/DfEkcygqNbSqv/JvNefdHSUUUV80fWhRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFVtVv7TS7CW+vp1ht4l3O7HpSatqNnpWny319OsMES7mZjXzP8UfH154tv8AyYWeDS4WPlQ5xvP95vU/yr2smyarmVWy0gt3+i8zws8zylldK71m9l+r8h/xP8eXfiy/MUJaHTIm/cxZ5b/ab3ris0zNGa/V8NhaWFpKlSVkj8bxeKrYuq61Z3kx+aX2pmTXsnwc+GrXBh8Qa/CViB3W9sw5b0Zh6e1YZhj6OAourVfourfY3y3LK+Y11Ror1fRLux3wc+GxuPK1/X4SIgQ1tbuPvf7TD09BXT/Fv4dQ6/bPqukxpFqca5KgYE4Hb6+9ekKAqhVAAHAApa/L62fYupi1ilKzWy6W7f5n63R4bwVPBPBuN0931v3/AMj4wuIZred4J42jlQlWVhgg0zNfRHxc+HUXiCB9W0mNI9TRcso4EwH9a+eLiKW2neCeNo5UO1kYYIPpX6TlOa0cypc8NJLddv8AgH5XnOS1srrck9YvZ9/+CJmtPw1rl/4f1WLUdPmMcqHkZ4Yeh9qys0Zr0qlONSLhNXTPKpznSmpwdmtmfWHgDxfp/i3SVubZhHcoAJ4CfmQ/1HvXSV8feGdd1Dw9q0WpabMY5UPIz8rr3UjuK+nPAHjDT/FulLcW7CO6QYngJ5Q/1FfmGfZBLAS9rS1pv8PJ/oz9c4c4jjmMFRraVV/5N5rz7o6WiiivmT6wKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAOY+JXhRfFvh5rAXDwTod8LA/KW9GHcV8s65pV/oupzadqNu0FxC2GVu/uPUV9m1x/xM8DWHi/TD8qw6jEP3E4HP+6fUV9Tw7n7wEvY1v4b/AAf+Xc+S4k4eWYR9vR/iL8V29ex8q5o+gq9ruk32i6nLp2oQNFPG2CCOvuPUV6v8Gvhk1w0PiDxDBiH71tbOPvejMPT2r9Cx2Z4fB4f283o9rdfQ/OMBlWIxuI+rwjZre/T1F+DPw0NwYfEPiCDEQ+a2tnH3vRmHp6Cvc1AVQqgADgAUKoVQqgAAYAHalr8lzPMq2Y1nVqv0XRI/YsryuhltBUqS9X1bCiiivOPSCvNfi98OYvEVu+raTEseqRrllHAnHoff3r0qiuvBY2tgqyq0nZr8fJnHjsDRx1F0ayun+Hmj4ruIZbad4J42ilQlWRhgg1Hmvoz4vfDiLxDA+raRGseqRjLIOBOP8a8AsdI1K91hdIgtJDetJ5ZiK4Knvn0xX6zleb0Mwoe1Ts1uu3/A8z8dzbJK+XYj2TV0/hff/g+Q3SbC81XUIbCwgee4mYKiKOpr6a+F3ga28IaaWkYTajOo8+Tsv+yvtTPhd4DtPCWnCWULNqcq/vZcfd/2V9q7avh+IeIHjG6FB/u1u+//AAD73hrhuOBSxGIV6j2X8v8AwQooor5M+xCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxdd8LaHrd/a32pWKTT2rbo2Pf2PqK2VAVQqgAAYAHalorSVWc4qMm2lt5GcKNOEnKMUm9/MKKKKzNAooooAKKKKACs+HRdLh1iXV4rKFb6VQrzBfmIrQoqozlG/K7XJlCMrOSvYKKKKkoKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooA//2Q=="), + contactLink = Just adminContactReq, + preferences = Nothing + } + +simplexStatusContactProfile :: Profile +simplexStatusContactProfile = + Profile + { displayName = "SimpleX-Status", + fullName = "", + image = Just (ImageData "data:image/jpg;base64,/9j/4AAQSkZJRgABAQAASABIAAD/4QBYRXhpZgAATU0AKgAAAAgAAgESAAMAAAABAAEAAIdpAAQAAAABAAAAJgAAAAAAA6ABAAMAAAABAAEAAKACAAQAAAABAAAAr6ADAAQAAAABAAAArwAAAAD/7QA4UGhvdG9zaG9wIDMuMAA4QklNBAQAAAAAAAA4QklNBCUAAAAAABDUHYzZjwCyBOmACZjs+EJ+/8AAEQgArwCvAwEiAAIRAQMRAf/EAB8AAAEFAQEBAQEBAAAAAAAAAAABAgMEBQYHCAkKC//EALUQAAIBAwMCBAMFBQQEAAABfQECAwAEEQUSITFBBhNRYQcicRQygZGhCCNCscEVUtHwJDNicoIJChYXGBkaJSYnKCkqNDU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6g4SFhoeIiYqSk5SVlpeYmZqio6Slpqeoqaqys7S1tre4ubrCw8TFxsfIycrS09TV1tfY2drh4uPk5ebn6Onq8fLz9PX29/j5+v/EAB8BAAMBAQEBAQEBAQEAAAAAAAABAgMEBQYHCAkKC//EALURAAIBAgQEAwQHBQQEAAECdwABAgMRBAUhMQYSQVEHYXETIjKBCBRCkaGxwQkjM1LwFWJy0QoWJDThJfEXGBkaJicoKSo1Njc4OTpDREVGR0hJSlNUVVZXWFlaY2RlZmdoaWpzdHV2d3h5eoKDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uLj5OXm5+jp6vLz9PX29/j5+v/bAEMAAQEBAQEBAgEBAgMCAgIDBAMDAwMEBgQEBAQEBgcGBgYGBgYHBwcHBwcHBwgICAgICAkJCQkJCwsLCwsLCwsLC//bAEMBAgICAwMDBQMDBQsIBggLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLC//dAAQAC//aAAwDAQACEQMRAD8A/v4ooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAP/Q/v4ooooAKKKKACiiigAoorE8R+ItF8J6Jc+IvEVwlrZ2iGSWWQ4CgVUISlJRirtmdatTo05VaslGMU223ZJLVtvokbdFfl3of/BRbS734rtpup2Ig8LSsIYrjnzkOcea3bafTqBX6cafqFjq1jFqemSrPbzqHjkQ5VlPIINetm2Q43LXD65T5eZXX+XquqPiuC/Efh/itYh5HiVUdGTjJWaflJJ6uEvsy2fqXKKKK8c+5Ciq17e2mnWkl/fyLDDCpd3c4VVHJJJr8c/2kf8Ago34q8M3mpTfByG3fT7CGSJZrlC3nStwJF5GFU8gd69LA5VicXTrVaMfdpxcpPokk397toj4LjvxKyLhGjRqZxValVkowhFc05O9m0tPdjfV7dN2kfq346+J3w9+GWlPrXxA1m00i1QZL3Uqxj8Mnn8K/Mj4tf8ABYD4DeEJ5dM+Gmn3niq4TIE0YEFtn/ffBI+imv51vHfxA8b/ABR1+bxT8RNUuNXvp3LtJcOWCk84VeigdgBXI18LXzupLSkrL72fzrxH9IXNsTKVPKKMaMOkpe/P8fdXpaXqfqvrf/BYH9p6+1w3+iafo1jZA8WrRPKSPeTcpz9BX1l8J/8Ags34PvxDp/xn8M3OmSnAe709hcQfUoSHA/A1/PtSE4/GuKGZ4mLvz39T4TL/ABe4swlZ1ljpTvvGaUo/dbT/ALdsf2rfCX9pT4HfHGzF18M/EdnqTYBaFXCzJn+9G2GH5V7nX8IOm6hqGkX8eraLcy2d3EcpPbuY5FPsykGv6gf+CWf7QPxB+OPwX1Ky+JF22pX3h69+yJdyf62WJlDrvPdlzjPevdwGae3l7OcbP8D+i/DTxm/1ixkcqx2H5K7TalF3jLlV2rPWLtqtWvM/T2iiivYP3c//0f7+KKKKACiiigAooooAK/Fv/goX8Qvi2fFcXgfWrRtP8NDEls0bZS7YfxORxlT0Xt1r9pK8u+L/AMI/Cfxp8F3HgvxbFujlGYpgB5kMg6Op9R+tfR8K5vQy3MYYnE01KK0843+0vNf8NZn5f4wcFZhxTwziMpy3FOjVeqSdo1Lf8u5u11GXk97Xuro/mBFyDX3t+yL+2Be/CW+h8B+OHafw7cyALIxJa0Ldx6p6jt1FfMvx/wDgR4w/Z+8YN4d8RoZrSbLWd4owk6D+TDuK8KF0K/pLFYHA51geWVp0pq6a/Brs1/wH2P8ALvJsz4h4D4h9tR5qGLoS5ZRls11jJbSjJferSi9mf1uafqFlqtlFqWmyrPBOoeORDlWU8gg069vrPTbSS/v5FhghUu7ucKqjqSa/CH9j79sm++EuoQ/D/wAeSNceHbmRVjlZstZk9x6p6jt2q3+15+2fffFS8n8AfD2V7bw9CxWWZThrwj+Se3evxB+G2Zf2n9TX8Lf2nTl/+S/u/PbU/v2P0nuGv9Vf7cf+9/D9Xv73tLd/+ffXn7afF7pqftbfth3nxUu5vAXgGR7fw/A5WWUHDXZX19E9B361+Z/xKm3eCL9R3UfzFbQul6Cn+I/A3ivxR8LPEXivSbVn07RoVkurg8Iu5gAue7HPSv1HOsrwmVcN4uhRSjBUp6vq3Fq7fVt/5I/gTNeI884x4kjmeYOVWtKSdop2hCPvWjFbQjFNv5ybbuz4Toqa0ge9uoLOIhWnkSNSxwAXIUEnsBnmv0+/aK/4Jg+O/gj8Hoviz4b1n/hJFt40l1G2ig2NDG4yZEIJ3KvfgHHNfxVTw9SpGUoK6W5+xZVw1mWZYfEYrA0XOFBKU2raJ31te72b0T0R+XRIAyegr+gr/glx+yZoHhjwBc/tKfFywiafUY2OmpeIGS3sVGWmIbgF+TkjhR71+YP7DX7Lt9+1H8ZLfR75WTw5pBS61ScDKsoIKwg+snf0Ffqd/wAFSv2o4Phf4Ltv2WvhmVtrjUbRBfvA2Ps1kOFhAHQyAc9ML9a9HL6UacHi6q0W3mz9Q8M8owuV4KvxpnEL0aN40Yv/AJeVXpp5LZPo7v7J+M/7U/jX4e/EL4/+JfFXwrsI9P0Ke5K26RKESTZw0oUcAOeQBX7J/wDBFU5+HPjYf9RWH/0SK/nqACgKOgr+hT/giouPh143b11SH/0SKWVzc8YpPrf8jHwexk8XxzSxVRJSn7WTSVknKMnoui7H7a0UUV9cf3Mf/9L+/iiiigAoorzX4wfGD4afAP4bav8AF74v6xbaD4d0K3e6vb26cJHHGgyevUnoAOSeBTjFyajFXYHpVFf55Xxt/wCDu34nj9vzS/G3wX0Qz/ArQ2ksLnSp1CXurQyMA15uPMTqBmJD2+914/uU/Y//AGxfgH+3P8ENL+P37OutxazoWpoNwHyzW02PmhmjPKSKeCD9RxXqY/JcXg4QqV4WUvw8n2ZnCrGTaTPqGiiivKNDy/4u/CLwd8afBtx4N8ZW4kilBMUoH7yGTs6HsR+tfzjftA/AXxl+z54yfw34jQzWkuXs7xF/dzR/0YdxX9OPiDxBofhPQ7vxN4mu4rDT7CF57m4ncJHFFGMszMcAAAZJNf53n/Bav/g5W1H4ufGjTvg5+xB5F14E8JX4l1HVriIE6xNE2GjhLDKQdRuGC55HHX9L8Os+x2ExP1eKcsO/iX8vmvPy6/ifg3jZ4NYDjDBPFUEqeYU17k/50vsT8n0lvF+V0fq0LhTUgnA4r4y/ZG/bJ+FX7YXw9HjDwBP5N/ahV1LTZeJrSUjoR3U/wsOK+sRdL/n/APXX9G0nCrBTpu6Z/mVmuSYvLcXUwOPpOnWg7SjJWaf9ap7NarQ+pf2dP2evGH7Q3i4aLogNvp1uQ15esMpEnoPVj2Ffrd+1V8GvDnw5/YU8X+APh/Z7IrewEjYGXlZGUs7nqSQM18C/sO/ti6b8F7o/Dnx6qpoN9LvS6RRvglbjL45ZT69vpX7wX1poHjjwxNYzbL3TdUt2jbaQySRSrg4PoQa/nnxXxGaTxLwmIjy4e3uW2lpu33Xbp87v+7Po58I8L4nhfFVMuqKeY1oTp1nJe9S5k0oxWtoPfmXxve1uVfwqKA0YHYiv6Ev+CZ37bVv490eP9mb4zXAn1GKJo9Murg5F3bgYMLk9XUcD+8tflR+1/wDsn+Nv2XfiNdadqFs8vh28md9Mv1GY3iJyEY9nXoQa+UrC/v8ASr+DVdJnktbq2dZYZomKvG6nIZSOhFfztQrVMJW1Xqu5+Z8PZ5mvBWeSc4NSg+WrTeinHqv1jL56ptP+s7xHZ/A//gnR8EfE/jTwra+RHqF5JdxWpbLTXcwwkSnrsGPwXNfyrfEDx54l+J/jXU/iB4wna51LVZ3nmdj3Y8KPQKOAPQV2vxX/AGhvjT8corC3+K2vz6vFpq7beNgERT3YqvBY92NeNVeOxirNRpq0Fsju8RePKWfTo4TLqPscFRXuU9F7z+KTSuvJK7srvqwr+ir/AIIuaVd2/wAH/FesSIRDd6uFjb+8Y41Dfka/BX4YfCzx78ZfGVr4C+G+nyajqV22Aqj5I17u7dFUdya/r+/ZV+Aenfs2fBLSPhbZyC4ntVaW7nAx5tzKd0jfTJwPYV1ZLQk63tbaI+w8AOHcXiM8ebcjVClGS5ujlJWUV3sm27baX3R9FUUUV9Uf2gf/0/7+KKKKACv4If8Ag8QT9vN9W8IsVk/4Z+WJedOL7f7Xyd32/HGNu3yc/LnPev73q84+Lnwj+G/x3+HGr/CT4uaRba74d123e1vbK6QPHJG4weD0I6gjkHkV6WUY9YLFQxDgpJdP8vMipDmi0f4W1frt/wAEhP8Agrt8af8AglD8b38V+Fo21zwPr7xp4i0B3KpcRoeJoTyEnjBO04+boeK+m/8AguZ/wQz+I3/BMD4kyfEn4Ww3fiD4Oa5KzWWolC76XKx4tbphwOuI3PDAc81/PdX7LCeFzHC3VpU5f18mjympU5eZ/t9fsk/tb/Av9tv4G6N+0F+z3rUWs6BrEQYFCPNt5cfPDMnVJEPDKf5V794h8Q6F4T0O78TeJ7uGw06wiae4uZ3EcUUaDLMzHAAA6k1/j9f8EiP+Cunxv/4JTfHAeKPCZfWfAuuyRx+IvD8jkRTxg486Lsk8YJ2n+Loa/V7/AILy/wDBxZd/t2eHl/Zc/Y6mu9I+Gl1DDNrWoSBoLvUpGAY2+OqQoeH/AL5GOlfneI4OxCxio0taT+12Xn59u53xxMeW73ND/g4M/wCDgzVP2yNV1H9jz9j3UZrD4ZWE7waxrEDlH110ONiEYItgQe/7z6V/I6AAMDgCgAKNo6Cv0j/4Jkf8Ex/j/wD8FOvj/Y/Cj4UWE9voFvNGdf18xk2um2pPzEt0MhGdiZyTX6FhsNhctwvLH3YR1bfXzfn/AEjhlKVSR77/AMEMf2Rf2v8A9qr9tPRrb9mNpdL0fSp438UaxKjNYW+nk/PHKOA7uoIjTrnniv7Lfj98CvG37PPjiXwj4uiLxNl7S7UYjuIuzD39R1Ffvt+wn+wd+z5/wTy+A+n/AAF/Z70pbKyt1V728cA3V/c4w0079WYnoOijgV7V8cPgb4G+Pngqfwb41twwYEwXCgebBJ2ZT/MdDXi5N4mTwmYWqRvhXpb7S/vL9V28z8c8YfBXC8XYL61hbQx9Ne7LpNfyT8v5ZfZfkfyXi5r9Lf2Jv24bn4S3UHwz+JkzT+HZ5AsNy5LNZlu3vHn8q+KPj38CPHf7PPjabwn4yt2ELMxtLsD91cRg8Mp6Z9R2rxAXAPANfuePyzL89y/2c7TpTV1JdOzT6Nf8Bn8C5FnGfcEZ79Yw96OJpPlnCS0a6xkusX/k4u9mf2IeK/B/w++Mngt9C8U2ltrWi6lEGCuA6OrDhlPY+hHNfztftw/8E4tN+AGlTfE34ba3HJo0koVdMvGC3CFv4Ym/5aAenBArvf2PP2+9R+CGmv4B+JSy6joEUbtaOp3TQOBkRj1Rjx7V8uftEftH+Nf2i/G7+KPEzmG0hyllZqT5cEef1Y9zX4LT8GMTisynhsY7UI6qot5J7Jefe+i87o/prxI8YuEM/wCF6WM+rc2ZSXKo6qVJrdykvih/Ktebsmnb4DkilicxyqVYdQRzXUaN4R1HVMSzjyIf7zDk/QV6dIlpJIJ5Y1Z16MRk1+qf7DX7Ed58ULmH4p/Fe2kt/D8Dq9paSDabwjncf+mf/oX0rKXg3lOR+0zDPMW6lCL92EVyufZN3vfyjbvdI/AeFsJnHFOPp5TktD97L4pP4YLrJu2iXnq3ok20es/8Erv2f/G/gf8AtD4ozj7Bo2pwiFIpY/3t2VOQ4J5VFzx659q/aKq9paWthax2VlGsUMShERBtVVHAAA6AVYr4LNcdTxWIdSjRjSpqyjGKslFber7t6tn+k3APB1LhjJaOUUqsqjjdylJ/FKTvJpfZV9orbzd2yiiivNPsj//U/v4ooooAKKKKAPO/iz8Jvh18c/h1q/wm+LGk2+ueHtdt3tb2yukDxyxuMEEHoR1B6g81/lm/8Fy/+CFfxG/4Jh/ENvid8J4bzxF8Htdmke1vliaRtHctxbXTAEBecRyHAbGDzX+q54j8R6B4Q0C88U+KbyHT9N0+F7i5ubhxHFFFGMszMcAADqa/zM/+Dhb/AIL06p+3f4rvP2Tf2Xr6S0+Eui3DR397GcHXriM8N7W6EfIP4jz6V9fwfPGLFctD+H9q+3/D9jmxKjy+9ufyq0UAY4or9ZPMP0v/AOCX3/BLf9oT/gqP8d4Phf8ACa0lsvDtjLG3iDxDJGTa6bbse56NKwB8uPOSfav9ZX9hD9hT4Df8E8v2fdK/Z7+AenLbWNkoe8vHUfab+6I+eeZhyWY9B0UcCv8AKC/4JUf8FV/j1/wSu+PCfEf4aSHUvC+rPHH4i0CViIL63U43D+7MgJKN+B4r/Wd/Yy/bM+BH7eHwH0j9oL9n7Vo9S0fU4182LI8+0nx88MydVdTxz16ivzbjZ43nipfwOlu/n59uh6GE5Labn1ZRRRXwB2Hi3x3+BPgj9oHwJceCPGcIIYFre4UfvYJezKf5jvX8vH7QvwB8d/s4eOZfB/jKEtDIS9neKP3VxFngqfX1Hav6gvj58e/An7PHgK48ceN7gLtBW2twf3txL2RR/M9hX8rX7Qn7Rnjz9o3x5L418ZyhUXKWlqh/dW8WeFUevqe5r988G4Zu3Ut/ueu/839z/wBu6fM/jj6UdPhlwo8y/wCFTS3Lb+H/ANPf/bPtf9unlQuAec077SPWueFznrTxc1+/eyP4udE/XX9g79h24+K8tv8AF74qQvD4fgkDWdo64N4V53H/AKZg/wDfX0r+ge0tLWwtY7KyjWKGJQiIgwqqOAAOwFfzc/sIft2XnwO1KH4ZfEeVp/Ct5L8k7Es9k7YHH/TMnkjt1r+kDTNT07WtOg1fSJ0ubW5QSRSxncjowyCCOoNfyr4q0s3jmreYfwtfZW+Hl/8Akv5r6/Kx/or9HSXDX+rqhkqtidPb81vac/d/3P5Lab/auXqKKK/Lz+gwooooA//V/v4ooooAKxfEniTQPB2gXnirxVew6dpunQvcXV1cOI4oYoxlndjgAADJJrar/PV/4Ozf+CiX7Xlr8Yrf9hCx0u98GfDaS0iv5L1GZT4iZs5HmKceTERgx9d3LcYr08py2eOxMaEXbu/L9SKk1CN2fIX/AAcD/wDBfrXv27vFF1+yx+ylqFzpnwl0id476+icxSa/MhwGOMEWykHYv8fU9hX8qoAAwOAKUAAYFfqj/wAEnf8AglH8cv8Agqp8ek+Hvw/R9M8I6NJFJ4k19lzHZW7k/ImeGmcAhF/E8V+xUKGFyzC2Xuwju/1fds8tuVSXmM/4JQ/8Epfjr/wVU+Pcfw5+HiPpXhPSXjl8ReIZEJhsoGP3E7PO4B2J+J4r7o/4Li/8EC/H3/BL/UYPjH8Hp7vxV8JNQMcL3sy7rnTLkgDbcFRjZI3KPwATg9q/0rP2MP2MPgL+wZ8BdI/Z5/Z60hNM0bS4x5kpANxeTn7887gAvI55JPToOK9y+J/ww8AfGfwBqvwu+KOlW+t6Brdu9re2V0gkilicYIIP6HqDXwVbjSu8YqlNfulpy9139e3Y7VhY8tnuf4VdfqD/AMErP+Cpvx1/4Jb/ALQNn8S/h7cS6j4VvpUj8QeH2kIt723zgsB0WVRyjetffn/BeH/ghJ4x/wCCZvjlvjP8EYbvXPg5rk7GKcqZJdGmc5FvOwH+rOcRyH0wea/nCr9ApVcNmOGuvehL+vk0cLUqcvM/24v2Mf20PgH+3l8CdK/aA/Z61iPVNI1FF86LI+0Wc+PnhnTqjqeOevUcV3nx/wD2gfh/+zp4CuPHHjq5CBQVtrZT+9uJeyIP5noBX+Ud/wAEL/25f2t/2NP2u7A/s7xPrPhzW5Yk8T6LOzCyls1PzTE9I5UXJRupPHIr+p39o79pXx/+0v8AEGbxv42l2RrlLO0QnyreLPCqPX1PUmvM4b8KauYZg5VJWwkdW/tP+6vPu+i8z8r8VvF3D8L4P6vhbTx017sekF/PL/21fafkjV/aF/aN8e/tHePZ/GvjOc+XuK2lopPlW8WeFUevqe9eFfasDmsL7UB1r9kv+Cen/BPuX4mPa/Gv41Wrw6HE4k0/T5FwbsjkO4PPl56D+L6V/QWbZjlnDmW+1q2hSgrRit2+kYrq/wDh2fw9kXDmdcZ526NK9SvUfNOctorrKT6JdF6JIh/Yq/4JyXXxq8MSfEn4wtPpukXkLLp1vH8s0hYcTHPRR1Ud6+KP2nP2bvHX7MXj+Twl4pUz2U+Xsb5QRHcRZ/Rh/Etf2D2trbWNtHZ2caxRRKEREGFVRwAAOgFeSfHL4G+Af2gvAVz4A8f2wmt5huimUDzYJB0dD2I/Wv5/yrxgx0c3niMcr4abtyL7C6OPdrr/ADeWlv604g+jdlFTh6ngsrfLjaauqj/5eS6xn2i/s2+Hz1v/ABi+d3r9O/2DP28r/wCBGpRfDT4lSvdeFL2UBJmYs9izcZX1j7kduor48/ah/Zr8bfsu/EWTwZ4pHn2c4MtheqMJcQ5IB9mHRhXzd9oAFf0Djsuy3iHLeSdqlGorpr8Gn0a/4DW6P5DyrMc74Mzz2tG9LE0XaUXs11jJdYv/ACaezP7pdK1bTNd02DWdGnS6tLlBJFLEwZHRuQQR1FaFfix/wSG1n47X3hPVLHXUL+BoT/oEtxneLjPzLD6pjr2B6d6/aev424nyP+yMyrZf7RT5Huvv17NdV0Z/pTwPxP8A6w5Lh82dGVJ1FrGXdaNp9YveL6oKKKK8A+sP/9b+/iiiigAr4E/4KI/8E4f2b/8AgpZ8DLr4M/H7SklljV5NJ1aJQLzTblhxLC/Uc43L0YcGvvuitKNadKaqU3aS2Ymk1Zn+Vt8Nf+DZH9vDxJ/wUEn/AGQfGti+m+DdMkF5eeNlTNjLpRb5Xgz964cfL5XVWyTx1/0lv2L/ANif9nv9gn4H6b8Bv2dNDh0jSrFF8+YKDcXs4GGmuJOskjHPJ6dBxX1lgZz3pa9bNc+xWPjGFV2iui6vu/60M6dKMNgooorxTU4T4m/DHwB8ZfAeqfDH4paRba7oGtQPbXtjeRiWGaJxghlII/wr/M//AOCw/wDwbq/En9kb9o7Ttc/ZhQ6h8KvGl4VgknkUyaJIxy0UmTueMDmNgCexr/SN/aA/aA+Hf7N3w6u/iL8RbtYYIFIggBHm3Ev8Mca9yfyA5NfyB/tTftZfEX9qv4gSeL/GEv2exgLJYWEZPlW8WeOO7H+Ju9fsXhRwnmOZYl4hNwwi+Jv7T/lj5930Xnofj3iv4nYThrCPD0bTxs17kekV/PPy7L7T8rn58fs1fs1/Df8AZg8Dp4U8CwB7qYK19fuAZrmQDkseyjsvQV9GfaWrAWcjvUnnt6mv62w+Cp0KapUo2itkfwFmOLxWPxNTGYyo51Zu8pN6t/1stktEftx/wTa/YHsfi6sHx2+L8aT6BFJnT7DcGFy6dWlAzhQf4T171/SBaWltY20dlZRrFDEoREQYVVHAAA6AV/Hv+xJ+3N4y/ZO8Wi0ui+oeE9QkX7dYk5KdjLFzw49Ohr+tj4c/Efwb8WPB1l498A30eoaZqEYkiljOevVWHZh0IPIr+TPGXLs6p5p9Zxz5sO9KbXwxX8rXSXd/a3Wmi/t76P8AmHD08l+qZZDkxUdaydueT/mT0vDsl8Oz1d33FFFFfjR/QB4x8dPgN8O/2hvA1x4F+Idms8MgJhmAxLbydnjbqCP1r8RPg3/wSV8Z/wDC9r7T/izMreDNIlEkM8TYfUVPKpgcoAPv+/Ar+iKivrsh43zbKMLWweCq2hUXXXlf80eza0/HdJnwPFHhpkHEGOw+YZlQ5qlJ7rTnXSM/5op6/hs2jD8NeGdA8HaHbeGvC9nFYWFmgjhghUIiKOwArcoor5Oc5Tk5Sd292fd06cacVCCtFaJLZLsgoooqSz//1/7+KKKKACiiigAooooAK8J/aK/aG+H37M/wzvPiX8QrgRwwDbb26kebczH7saDuSep7DmvdW3bTt69s1/Hj/wAFS9c/acu/2hbiw+Psf2fTYWf+w47bd9ha2zw0ZPWQj7+eQfav0Dw44PpcRZssLXqqFOK5pK9pSS6RXfu+i1PzvxN4zrcN5PLF4ei51JPli7XjFv7U327Lq9Dwr9qv9rn4lftZ+Pv+Ev8AG8i29na7ksNPiJ8m2iJ7Ak5Y/wATHrXy/wDacDJNYfn45PFftR/wTX/4Ju6j8aryz+OXxttpLXwtbSrJY2Mi7W1Bl53MD0hB/wC+vpX9jZpmGU8LZT7WolTo01aMVu30jFdW/wDNvqz+HcryTOeLs4dODdSvUd5Tlsl1lJ9Eui9Elsix/wAE8/8Agmpc/Hq3HxZ+OcFxY+F8f6Daj93Jen++eMiMdum76V88ft4fsM+LP2RvGH9p6MJtS8G6gxNnfMMmFj/yxmIAAYfwnuPev7DbGxs9Ms4tP0+JYIIFCRxoNqqq8AADoBXL+P8AwB4R+KHhG+8C+OrGPUNM1CMxTQyjIIPcehHUEdDX8x4PxqzWOdvH11fDS0dJbKPRp/zrdvrtta39V47wCyWeQRy7D6YqOqrPeUuqkv5Hsl9ndXd7/wACwuGHevvT9iL9u7x1+yP4n+wMDqXhPUJVN/YMTlOxlh/uuB+BqH9vD9hXxl+yD4v/ALS03zNT8HajIfsV8VyYSf8AljNjgMOx/iHvX59C6bHav6fjDKeJsqurVcPVX9ecZRfzTP5LdLOeE850vRxNJ/15SjJfJo/v3+GnxJ8HfF3wRp/xC8BXiX2l6lEJYZEPr1Vh2YdCDyDXd1/PD/wRa8KftJW8moeKfPNp8N7kMBBdKT9ouR/Hbgn5QP4m6Gv6Hq/iHjXh6lkmb1svoVlUjF6Nbq/2ZdOZdbfhsf6AcC8SVs9yahmWIoOlOS1T2dvtR68r3V/x3ZRRRXyh9eFFFFABRRRQB//Q/v4ooooAKKKKACiiigAr5u/aj/Zg+HX7VvwyuPh14+i2N/rLO8jA861mHR0Pp2YdCOK+kaK6sDjq+DxEMVhZuFSDumt00cmOwOHxuHnhcVBTpzVpJ7NM/nF/ZW/4I2eINL+MV9rH7Rk0Vz4d0G5H2GCA8anjlXfuiDjcvJJ46V/RfY2FlpdlFpumxJBbwII444wFVEUYAAHAAFW6K9/injHM+Ia8a+Y1L8qsorSK7tLu3q3+iSPn+E+C8q4dw86GW07czvJvWT7Jvstkv1bYUUUV8sfVnEfEb4c+Dvix4Mv/AAB49sY9Q0vUYjFNDIMjB7j0YdQRyDX4HeH/APgiNJB+0LKNe1vzvhzARcxBeLyUEn/R27ADu46jtmv6KKK+r4d42zjI6Vajl1ZxjUVmt7P+aN9pW0uv0R8lxJwNk2e1aFfMqCnKk7p7XX8srbxvrZ/qzn/CnhXw/wCCPDll4R8K2sdlp2nQrBbwRDCoiDAAFdBRRXy05ynJzm7t6tvqfVwhGEVCCsloktkgoooqSgooooAKKKKAP//R/v4ooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAP/Z"), + contactLink = Just (either error id $ strDecode "simplex:/contact/#/?v=1-2&smp=smp%3A%2F%2Fu2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU%3D%40smp4.simplex.im%2FShQuD-rPokbDvkyotKx5NwM8P3oUXHxA%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEA6fSx1k9zrOmF0BJpCaTarZvnZpMTAVQhd3RkDQ35KT0%253D%26srv%3Do5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"), + preferences = Nothing + } + +timeItToView :: String -> CM' a -> CM' a +timeItToView s action = do + t1 <- liftIO getCurrentTime + a <- action + t2 <- liftIO getCurrentTime + let diff = diffToMilliseconds $ diffUTCTime t2 t1 + toView' $ CRTimedAction s diff + pure a diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs new file mode 100644 index 0000000000..2df77a074e --- /dev/null +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -0,0 +1,2887 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +module Simplex.Chat.Library.Subscriber where + +import Control.Logger.Simple +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Unlift +import Control.Monad.Reader +import qualified Data.Aeson as J +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Either (lefts, partitionEithers, rights) +import Data.Functor (($>)) +import Data.Int (Int64) +import Data.List (foldl', partition) +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import qualified Data.List.NonEmpty as L +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1) +import Data.Time (addUTCTime) +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as V4 +import Data.Word (Word32) +import Simplex.Chat.Call +import Simplex.Chat.Controller +import Simplex.Chat.Messages +import Simplex.Chat.Messages.CIContent +import Simplex.Chat.Messages.CIContent.Events +import Simplex.Chat.ProfileGenerator (generateRandomProfile) +import Simplex.Chat.Protocol +import Simplex.Chat.Library.Internal +import Simplex.Chat.Store +import Simplex.Chat.Store.Connections +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Files +import Simplex.Chat.Store.Groups +import Simplex.Chat.Store.Messages +import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences +import Simplex.Chat.Types.Shared +import Simplex.Chat.Util (shuffle) +import Simplex.FileTransfer.Description (ValidFileDescription) +import qualified Simplex.FileTransfer.Description as FD +import Simplex.FileTransfer.Protocol (FilePartyI) +import qualified Simplex.FileTransfer.Transport as XFTP +import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId) +import Simplex.Messaging.Agent as Agent +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) +import Simplex.Messaging.Agent.Protocol +import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) +import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB +import Simplex.Messaging.Client (ProxyClientError (..)) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.File (CryptoFile (..)) +import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) +import qualified Simplex.Messaging.Crypto.Ratchet as CR +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..)) +import qualified Simplex.Messaging.Protocol as SMP +import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Transport (TransportError (..)) +import Simplex.Messaging.Util +import Simplex.Messaging.Version +import qualified System.FilePath as FP +import Text.Read (readMaybe) +import UnliftIO.Directory +import UnliftIO.STM + +smallGroupsRcptsMemLimit :: Int +smallGroupsRcptsMemLimit = 20 + +processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM () +processAgentMessage _ connId (DEL_RCVQ srv qId err_) = + toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_ +processAgentMessage _ connId DEL_CONN = + toView $ CRAgentConnDeleted (AgentConnId connId) +processAgentMessage _ "" (ERR e) = + toView $ CRChatError Nothing $ ChatErrorAgent e Nothing +processAgentMessage corrId connId msg = do + lockEntity <- critical (withStore (`getChatLockEntity` AgentConnId connId)) + withEntityLock "processAgentMessage" lockEntity $ do + vr <- chatVersionRange + -- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here + critical (withStore' (`getUserByAConnId` AgentConnId connId)) >>= \case + Just user -> processAgentMessageConn vr user corrId connId msg `catchChatError` (toView . CRChatError (Just user)) + _ -> throwChatError $ CENoConnectionUser (AgentConnId connId) + +-- CRITICAL error will be shown to the user as alert with restart button in Android/desktop apps. +-- SEDBBusyError will only be thrown on IO exceptions or SQLError during DB queries, +-- e.g. when database is locked or busy for longer than 3s. +-- In this case there is no better mitigation than showing alert: +-- - without ACK the message delivery will be stuck, +-- - with ACK message will be lost, as it failed to be saved. +-- Full app restart is likely to resolve database condition and the message will be received and processed again. +critical :: CM a -> CM a +critical a = + a `catchChatError` \case + ChatErrorStore SEDBBusyError {message} -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing + e -> throwError e + +processAgentMessageNoConn :: AEvent 'AENone -> CM () +processAgentMessageNoConn = \case + CONNECT p h -> hostEvent $ CRHostConnected p h + DISCONNECT p h -> hostEvent $ CRHostDisconnected p h + DOWN srv conns -> serverEvent srv conns NSDisconnected CRContactsDisconnected + UP srv conns -> serverEvent srv conns NSConnected CRContactsSubscribed + SUSPENDED -> toView CRChatSuspended + DEL_USER agentUserId -> toView $ CRAgentUserDeleted agentUserId + ERRS cErrs -> errsEvent cErrs + where + hostEvent :: ChatResponse -> CM () + hostEvent = whenM (asks $ hostEvents . config) . toView + serverEvent srv conns nsStatus event = do + chatModifyVar connNetworkStatuses $ \m -> foldl' (\m' cId -> M.insert cId nsStatus m') m connIds + ifM (asks $ coreApi . config) (notifyAPI connIds) notifyCLI + where + connIds = map AgentConnId conns + notifyAPI = toView . CRNetworkStatus nsStatus + notifyCLI = do + cs <- withStore' (`getConnectionsContacts` conns) + toView $ event srv cs + errsEvent :: [(ConnId, AgentErrorType)] -> CM () + errsEvent cErrs = do + vr <- chatVersionRange + errs <- lift $ rights <$> withStoreBatch' (\db -> map (getChatErr vr db) cErrs) + toView $ CRChatErrors Nothing errs + where + getChatErr :: VersionRangeChat -> DB.Connection -> (ConnId, AgentErrorType) -> IO ChatError + getChatErr vr db (connId, err) = + let acId = AgentConnId connId + in ChatErrorAgent err <$> (getUserByAConnId db acId $>>= \user -> eitherToMaybe <$> runExceptT (getConnectionEntity db vr user acId)) + +processAgentMsgSndFile :: ACorrId -> SndFileId -> AEvent 'AESndFile -> CM () +processAgentMsgSndFile _corrId aFileId msg = do + (cRef_, fileId) <- withStore (`getXFTPSndFileDBIds` AgentSndFileId aFileId) + withEntityLock_ cRef_ . withFileLock "processAgentMsgSndFile" fileId $ + withStore' (`getUserByASndFileId` AgentSndFileId aFileId) >>= \case + Just user -> process user fileId `catchChatError` (toView . CRChatError (Just user)) + _ -> do + lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) + throwChatError $ CENoSndFileUser $ AgentSndFileId aFileId + where + withEntityLock_ :: Maybe ChatRef -> CM a -> CM a + withEntityLock_ cRef_ = case cRef_ of + Just (ChatRef CTDirect contactId) -> withContactLock "processAgentMsgSndFile" contactId + Just (ChatRef CTGroup groupId) -> withGroupLock "processAgentMsgSndFile" groupId + _ -> id + process :: User -> FileTransferId -> CM () + process user fileId = do + (ft@FileTransferMeta {xftpRedirectFor, cancelled}, sfts) <- withStore $ \db -> getSndFileTransfer db user fileId + vr <- chatVersionRange + unless cancelled $ case msg of + SFPROG sndProgress sndTotal -> do + let status = CIFSSndTransfer {sndProgress, sndTotal} + ci <- withStore $ \db -> do + liftIO $ updateCIFileStatus db user fileId status + lookupChatItemByFileId db vr user fileId + toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal + SFDONE sndDescr rfds -> do + withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr) + ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId + case ci of + Nothing -> do + lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) + withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText rfds) + case rfds of + [] -> sendFileError (FileErrOther "no receiver descriptions") "no receiver descriptions" vr ft + rfd : _ -> case [fd | fd@(FD.ValidFileDescription FD.FileDescription {chunks = [_]}) <- rfds] of + [] -> case xftpRedirectFor of + Nothing -> xftpSndFileRedirect user fileId rfd >>= toView . CRSndFileRedirectStartXFTP user ft + Just _ -> sendFileError (FileErrOther "chaining redirects") "Prohibit chaining redirects" vr ft + rfds' -> do + -- we have 1 chunk - use it as URI whether it is redirect or not + ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor + toView $ CRSndStandaloneFileComplete user ft' $ map (decodeLatin1 . strEncode . FD.fileDescriptionURI) rfds' + Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) -> + case (msgId_, itemDeleted) of + (Just sharedMsgId, Nothing) -> do + when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send" + -- TODO either update database status or move to SFPROG + toView $ CRSndFileProgressXFTP user ci ft 1 1 + case (rfds, sfts, d, cInfo) of + (rfd : extraRFDs, sft : _, SMDSnd, DirectChat ct) -> do + withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) + conn@Connection {connId} <- liftEither $ contactSendConn_ ct + sendFileDescriptions (ConnectionId connId) ((conn, sft, fileDescrText rfd) :| []) sharedMsgId >>= \case + Just rs -> case L.last rs of + Right ([msgDeliveryId], _) -> + withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId + Right (deliveryIds, _) -> toView $ CRChatError (Just user) $ ChatError $ CEInternalError $ "SFDONE, sendFileDescriptions: expected 1 delivery id, got " <> show (length deliveryIds) + Left e -> toView $ CRChatError (Just user) e + Nothing -> toView $ CRChatError (Just user) $ ChatError $ CEInternalError "SFDONE, sendFileDescriptions: expected at least 1 result" + lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) + (_, _, SMDSnd, GroupChat g@GroupInfo {groupId}) -> do + ms <- withStore' $ \db -> getGroupMembers db vr user g + let rfdsMemberFTs = zipWith (\rfd (conn, sft) -> (conn, sft, fileDescrText rfd)) rfds (memberFTs ms) + extraRFDs = drop (length rfdsMemberFTs) rfds + withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) + forM_ (L.nonEmpty rfdsMemberFTs) $ \rfdsMemberFTs' -> + sendFileDescriptions (GroupId groupId) rfdsMemberFTs' sharedMsgId + ci' <- withStore $ \db -> do + liftIO $ updateCIFileStatus db user fileId CIFSSndComplete + getChatItemByFileId db vr user fileId + lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) + toView $ CRSndFileCompleteXFTP user ci' ft + where + memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)] + memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts') + where + mConns' = mapMaybe useMember ms + sfts' = mapMaybe (\sft@SndFileTransfer {groupMemberId} -> (,sft) <$> groupMemberId) sfts + -- Should match memberSendAction logic + useMember GroupMember {groupMemberId, activeConn = Just conn@Connection {connStatus}} + | (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) && not (connInactive conn) = + Just (groupMemberId, conn) + | otherwise = Nothing + useMember _ = Nothing + _ -> pure () + _ -> pure () -- TODO error? + SFWARN e -> do + let err = tshow e + logWarn $ "Sent file warning: " <> err + ci <- withStore $ \db -> do + liftIO $ updateCIFileStatus db user fileId (CIFSSndWarning $ agentFileError e) + lookupChatItemByFileId db vr user fileId + toView $ CRSndFileWarning user ci ft err + SFERR e -> + sendFileError (agentFileError e) (tshow e) vr ft + where + fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text + fileDescrText = safeDecodeUtf8 . strEncode + sendFileDescriptions :: ConnOrGroupId -> NonEmpty (Connection, SndFileTransfer, RcvFileDescrText) -> SharedMsgId -> CM (Maybe (NonEmpty (Either ChatError ([Int64], PQEncryption)))) + sendFileDescriptions connOrGroupId connsTransfersDescrs sharedMsgId = do + lift . void . withStoreBatch' $ \db -> L.map (\(_, sft, rfdText) -> updateSndFTDescrXFTP db user sft rfdText) connsTransfersDescrs + partSize <- asks $ xftpDescrPartSize . config + let connsIdsEvts = connDescrEvents partSize + sndMsgs_ <- lift $ createSndMessages $ L.map snd connsIdsEvts + let (errs, msgReqs) = partitionEithers . L.toList $ L.zipWith (fmap . toMsgReq) connsIdsEvts sndMsgs_ + delivered <- mapM deliverMessages (L.nonEmpty msgReqs) + let errs' = errs <> maybe [] (lefts . L.toList) delivered + unless (null errs') $ toView $ CRChatErrors (Just user) errs' + pure delivered + where + connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)) + connDescrEvents partSize = L.fromList $ concatMap splitText (L.toList connsTransfersDescrs) + where + splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))] + splitText (conn, _, rfdText) = + map (\fileDescr -> (conn, (connOrGroupId, XMsgFileDescr {msgId = sharedMsgId, fileDescr}))) (L.toList $ splitFileDescr partSize rfdText) + toMsgReq :: (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq + toMsgReq (conn, _) SndMessage {msgId, msgBody} = + (conn, MsgFlags {notification = hasNotification XMsgFileDescr_}, msgBody, [msgId]) + sendFileError :: FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM () + sendFileError ferr err vr ft = do + logError $ "Sent file error: " <> err + ci <- withStore $ \db -> do + liftIO $ updateFileCancelled db user fileId (CIFSSndError ferr) + lookupChatItemByFileId db vr user fileId + lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) + toView $ CRSndFileError user ci ft err + +agentFileError :: AgentErrorType -> FileError +agentFileError = \case + XFTP _ XFTP.AUTH -> FileErrAuth + FILE NO_FILE -> FileErrNoFile + BROKER _ e -> brokerError FileErrRelay e + e -> FileErrOther $ tshow e + where + brokerError srvErr = \case + HOST -> srvErr SrvErrHost + SMP.TRANSPORT TEVersion -> srvErr SrvErrVersion + e -> srvErr . SrvErrOther $ tshow e + +splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr +splitFileDescr partSize rfdText = splitParts 1 rfdText + where + splitParts partNo remText = + let (part, rest) = T.splitAt partSize remText + complete = T.null rest + fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete} + in if complete + then fileDescr :| [] + else fileDescr <| splitParts (partNo + 1) rest + +processAgentMsgRcvFile :: ACorrId -> RcvFileId -> AEvent 'AERcvFile -> CM () +processAgentMsgRcvFile _corrId aFileId msg = do + (cRef_, fileId) <- withStore (`getXFTPRcvFileDBIds` AgentRcvFileId aFileId) + withEntityLock_ cRef_ . withFileLock "processAgentMsgRcvFile" fileId $ + withStore' (`getUserByARcvFileId` AgentRcvFileId aFileId) >>= \case + Just user -> process user fileId `catchChatError` (toView . CRChatError (Just user)) + _ -> do + lift $ withAgent' (`xftpDeleteRcvFile` aFileId) + throwChatError $ CENoRcvFileUser $ AgentRcvFileId aFileId + where + withEntityLock_ :: Maybe ChatRef -> CM a -> CM a + withEntityLock_ cRef_ = case cRef_ of + Just (ChatRef CTDirect contactId) -> withContactLock "processAgentMsgRcvFile" contactId + Just (ChatRef CTGroup groupId) -> withGroupLock "processAgentMsgRcvFile" groupId + _ -> id + process :: User -> FileTransferId -> CM () + process user fileId = do + ft <- withStore $ \db -> getRcvFileTransfer db user fileId + vr <- chatVersionRange + unless (rcvFileCompleteOrCancelled ft) $ case msg of + RFPROG rcvProgress rcvTotal -> do + let status = CIFSRcvTransfer {rcvProgress, rcvTotal} + ci <- withStore $ \db -> do + liftIO $ updateCIFileStatus db user fileId status + lookupChatItemByFileId db vr user fileId + toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal ft + RFDONE xftpPath -> + case liveRcvFileTransferPath ft of + Nothing -> throwChatError $ CEInternalError "no target path for received XFTP file" + Just targetPath -> do + fsTargetPath <- lift $ toFSFilePath targetPath + renameFile xftpPath fsTargetPath + ci_ <- withStore $ \db -> do + liftIO $ do + updateRcvFileStatus db fileId FSComplete + updateCIFileStatus db user fileId CIFSRcvComplete + lookupChatItemByFileId db vr user fileId + agentXFTPDeleteRcvFile aFileId fileId + toView $ maybe (CRRcvStandaloneFileComplete user fsTargetPath ft) (CRRcvFileComplete user) ci_ + RFWARN e -> do + ci <- withStore $ \db -> do + liftIO $ updateCIFileStatus db user fileId (CIFSRcvWarning $ agentFileError e) + lookupChatItemByFileId db vr user fileId + toView $ CRRcvFileWarning user ci e ft + RFERR e + | e == FILE NOT_APPROVED -> do + aci_ <- resetRcvCIFileStatus user fileId CIFSRcvAborted + forM_ aci_ cleanupACIFile + agentXFTPDeleteRcvFile aFileId fileId + forM_ aci_ $ \aci -> toView $ CRChatItemUpdated user aci + | otherwise -> do + aci_ <- withStore $ \db -> do + liftIO $ updateFileCancelled db user fileId (CIFSRcvError $ agentFileError e) + lookupChatItemByFileId db vr user fileId + forM_ aci_ cleanupACIFile + agentXFTPDeleteRcvFile aFileId fileId + toView $ CRRcvFileError user aci_ e ft + +processAgentMessageConn :: VersionRangeChat -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM () +processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do + -- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert, + -- as in this case no need to ACK message - we can't process messages for this connection anyway. + -- SEDBException will be re-trown as CRITICAL as it is likely to indicate a temporary database condition + -- that will be resolved with app restart. + entity <- critical $ withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus + case agentMessage of + END -> case entity of + RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct + _ -> toView $ CRSubscriptionEnd user entity + MSGNTF msgId msgTs_ -> toView $ CRNtfMessage user entity $ ntfMsgAckInfo msgId msgTs_ + _ -> case entity of + RcvDirectMsgConnection conn contact_ -> + processDirectMessage agentMessage entity conn contact_ + RcvGroupMsgConnection conn gInfo m -> + processGroupMessage agentMessage entity conn gInfo m + RcvFileConnection conn ft -> + processRcvFileConn agentMessage entity conn ft + SndFileConnection conn ft -> + processSndFileConn agentMessage entity conn ft + UserContactConnection conn uc -> + processUserContactRequest agentMessage entity conn uc + where + updateConnStatus :: ConnectionEntity -> CM ConnectionEntity + updateConnStatus acEntity = case agentMsgConnStatus agentMessage of + Just connStatus -> do + let conn = (entityConnection acEntity) {connStatus} + withStore' $ \db -> updateConnectionStatus db conn connStatus + pure $ updateEntityConnStatus acEntity connStatus + Nothing -> pure acEntity + + agentMsgConnStatus :: AEvent e -> Maybe ConnStatus + agentMsgConnStatus = \case + JOINED True -> Just ConnSndReady + CONF {} -> Just ConnRequested + INFO {} -> Just ConnSndReady + CON _ -> Just ConnReady + _ -> Nothing + + processCONFpqSupport :: Connection -> PQSupport -> CM Connection + processCONFpqSupport conn@Connection {connId, pqSupport = pq} pq' + | pq == PQSupportOn && pq' == PQSupportOff = do + let pqEnc' = CR.pqSupportToEnc pq' + withStore' $ \db -> updateConnSupportPQ db connId pq' pqEnc' + pure (conn {pqSupport = pq', pqEncryption = pqEnc'} :: Connection) + | pq /= pq' = do + messageWarning "processCONFpqSupport: unexpected pqSupport change" + pure conn + | otherwise = pure conn + + processINFOpqSupport :: Connection -> PQSupport -> CM () + processINFOpqSupport Connection {pqSupport = pq} pq' = + when (pq /= pq') $ messageWarning "processINFOpqSupport: unexpected pqSupport change" + + processDirectMessage :: AEvent e -> ConnectionEntity -> Connection -> Maybe Contact -> CM () + processDirectMessage agentMsg connEntity conn@Connection {connId, connChatVersion, peerChatVRange, viaUserContactLink, customUserProfileId, connectionCode} = \case + Nothing -> case agentMsg of + CONF confId pqSupport _ connInfo -> do + conn' <- processCONFpqSupport conn pqSupport + -- [incognito] send saved profile + (conn'', inGroup) <- saveConnInfo conn' connInfo + incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) + let profileToSend = userProfileToSend user (fromLocalProfile <$> incognitoProfile) Nothing inGroup + -- [async agent commands] no continuation needed, but command should be asynchronous for stability + allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend + INFO pqSupport connInfo -> do + processINFOpqSupport conn pqSupport + void $ saveConnInfo conn connInfo + MSG meta _msgFlags _msgBody -> + -- We are not saving message (saveDirectRcvMSG) as contact hasn't been created yet, + -- chat item is also not created here + withAckMessage' "new contact msg" agentConnId meta $ pure () + SENT msgId _proxy -> do + void $ continueSending connEntity conn + sentMsgDeliveryEvent conn msgId + OK -> + -- [async agent commands] continuation on receiving OK + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + JOINED _ -> + -- [async agent commands] continuation on receiving JOINED + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + QCONT -> + void $ continueSending connEntity conn + MWARN _ err -> + processConnMWARN connEntity conn err + MERR _ err -> do + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + processConnMERR connEntity conn err + MERRS _ err -> do + -- error cannot be AUTH error here + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + ERR err -> do + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + -- TODO add debugging output + _ -> pure () + Just ct@Contact {contactId} -> case agentMsg of + INV (ACR _ cReq) -> + -- [async agent commands] XGrpMemIntro continuation on receiving INV + withCompletedCommand conn agentMsg $ \_ -> + case cReq of + directConnReq@(CRInvitationUri _ _) -> do + contData <- withStore' $ \db -> do + setConnConnReqInv db user connId cReq + getXGrpMemIntroContDirect db user ct + forM_ contData $ \(hostConnId, xGrpMemIntroCont) -> + sendXGrpMemInv hostConnId (Just directConnReq) xGrpMemIntroCont + CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" + MSG msgMeta _msgFlags msgBody -> do + tags <- newTVarIO [] + withAckMessage "contact msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do + let MsgMeta {pqEncryption} = msgMeta + (ct', conn') <- updateContactPQRcv user ct conn pqEncryption + checkIntegrityCreateItem (CDDirectRcv ct') msgMeta `catchChatError` \_ -> pure () + forM_ aChatMsgs $ \case + Right (ACMsg _ chatMsg) -> + processEvent ct' conn' tags eInfo chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e + Left e -> do + atomically $ modifyTVar' tags ("error" :) + logInfo $ "contact msg=error " <> eInfo <> " " <> tshow e + toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e) + checkSendRcpt ct' $ rights aChatMsgs -- not crucial to use ct'' from processEvent + where + aChatMsgs = parseChatMessages msgBody + processEvent :: Contact -> Connection -> TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM () + processEvent ct' conn' tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do + let tag = toCMEventTag chatMsgEvent + atomically $ modifyTVar' tags (tshow tag :) + logInfo $ "contact msg=" <> tshow tag <> " " <> eInfo + (conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta msgBody chatMsg + let ct'' = ct' {activeConn = Just conn''} :: Contact + case event of + XMsgNew mc -> newContentMessage ct'' mc msg msgMeta + XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr + XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live + XMsgDel sharedMsgId _ -> messageDelete ct'' sharedMsgId msg msgMeta + XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta + -- TODO discontinue XFile + XFile fInv -> processFileInvitation' ct'' fInv msg msgMeta + XFileCancel sharedMsgId -> xFileCancel ct'' sharedMsgId + XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct'' sharedMsgId fileConnReq_ fName + XInfo p -> xInfo ct'' p + XDirectDel -> xDirectDel ct'' msg msgMeta + XGrpInv gInv -> processGroupInvitation ct'' gInv msg msgMeta + XInfoProbe probe -> xInfoProbe (COMContact ct'') probe + XInfoProbeCheck probeHash -> xInfoProbeCheck (COMContact ct'') probeHash + XInfoProbeOk probe -> xInfoProbeOk (COMContact ct'') probe + XCallInv callId invitation -> xCallInv ct'' callId invitation msg msgMeta + XCallOffer callId offer -> xCallOffer ct'' callId offer msg + XCallAnswer callId answer -> xCallAnswer ct'' callId answer msg + XCallExtra callId extraInfo -> xCallExtra ct'' callId extraInfo msg + XCallEnd callId -> xCallEnd ct'' callId msg + BFileChunk sharedMsgId chunk -> bFileChunk ct'' sharedMsgId chunk msgMeta + _ -> messageError $ "unsupported message: " <> T.pack (show event) + checkSendRcpt :: Contact -> [AChatMessage] -> CM Bool + checkSendRcpt ct' aMsgs = do + let Contact {chatSettings = ChatSettings {sendRcpts}} = ct' + pure $ fromMaybe (sendRcptsContacts user) sendRcpts && any aChatMsgHasReceipt aMsgs + where + aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) = + hasDeliveryReceipt (toCMEventTag chatMsgEvent) + RCVD msgMeta msgRcpt -> + withAckMessage' "contact rcvd" agentConnId msgMeta $ + directMsgReceived ct conn msgMeta msgRcpt + CONF confId pqSupport _ connInfo -> do + conn' <- processCONFpqSupport conn pqSupport + ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn' connInfo + conn'' <- updatePeerChatVRange conn' chatVRange + case chatMsgEvent of + -- confirming direct connection with a member + XGrpMemInfo _memId _memProfile -> do + -- TODO check member ID + -- TODO update member profile + -- [async agent commands] no continuation needed, but command should be asynchronous for stability + allowAgentConnectionAsync user conn'' confId XOk + XInfo profile -> do + ct' <- processContactProfileUpdate ct profile False `catchChatError` const (pure ct) + -- [incognito] send incognito profile + incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId + let p = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct') False + allowAgentConnectionAsync user conn'' confId $ XInfo p + void $ withStore' $ \db -> resetMemberContactFields db ct' + XGrpLinkInv glInv -> do + -- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group + (gInfo, host) <- withStore $ \db -> do + liftIO $ deleteContactCardKeepConn db connId ct + createGroupInvitedViaLink db vr user conn'' glInv + -- [incognito] send saved profile + incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId) + let profileToSend = userProfileToSend user (fromLocalProfile <$> incognitoProfile) Nothing True + allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend + toView $ CRBusinessLinkConnecting user gInfo host ct + _ -> messageError "CONF for existing contact must have x.grp.mem.info or x.info" + INFO pqSupport connInfo -> do + processINFOpqSupport conn pqSupport + ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo + _conn' <- updatePeerChatVRange conn chatVRange + case chatMsgEvent of + XGrpMemInfo _memId _memProfile -> do + -- TODO check member ID + -- TODO update member profile + pure () + XInfo profile -> + void $ processContactProfileUpdate ct profile False + XOk -> pure () + _ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok" + CON pqEnc -> + withStore' (\db -> getViaGroupMember db vr user ct) >>= \case + Nothing -> do + when (pqEnc == PQEncOn) $ withStore' $ \db -> updateConnPQEnabledCON db connId pqEnc + let conn' = conn {pqSndEnabled = Just pqEnc, pqRcvEnabled = Just pqEnc} :: Connection + ct' = ct {activeConn = Just conn'} :: Contact + -- [incognito] print incognito profile used for this contact + incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) + lift $ setContactNetworkStatus ct' NSConnected + toView $ CRContactConnected user ct' (fmap fromLocalProfile incognitoProfile) + when (directOrUsed ct') $ do + unless (contactUsed ct') $ withFastStore' $ \db -> updateContactUsed db user ct' + createInternalChatItem user (CDDirectRcv ct') (CIRcvDirectE2EEInfo $ E2EInfo pqEnc) Nothing + createFeatureEnabledItems ct' + when (contactConnInitiated conn') $ do + let Connection {groupLinkId} = conn' + doProbeContacts = isJust groupLinkId + probeMatchingContactsAndMembers ct' (contactConnIncognito ct') doProbeContacts + withStore' $ \db -> resetContactConnInitiated db user conn' + forM_ viaUserContactLink $ \userContactLinkId -> do + ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId + let (UserContactLink {autoAccept}, groupId_, gLinkMemRole) = ucl + when (connChatVersion < batchSend2Version) $ sendAutoReply ct' autoAccept + forM_ groupId_ $ \groupId -> do + groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId + subMode <- chatReadVar subscriptionMode + groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode + gVar <- asks random + withStore $ \db -> createNewContactMemberAsync db gVar user groupInfo ct' gLinkMemRole groupConnIds connChatVersion peerChatVRange subMode + Just (gInfo, m@GroupMember {activeConn}) -> + when (maybe False ((== ConnReady) . connStatus) activeConn) $ do + notifyMemberConnected gInfo m $ Just ct + let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo + when (memberCategory m == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True + SENT msgId proxy -> do + void $ continueSending connEntity conn + sentMsgDeliveryEvent conn msgId + checkSndInlineFTComplete conn msgId + cis <- withStore $ \db -> do + cis <- updateDirectItemsStatus' db ct conn msgId (CISSndSent SSPComplete) + liftIO $ forM cis $ \ci -> setDirectSndChatItemViaProxy db user ct ci (isJust proxy) + let acis = map ctItem cis + unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis + where + ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct) + SWITCH qd phase cStats -> do + toView $ CRContactSwitch user ct (SwitchProgress qd phase cStats) + when (phase == SPStarted || phase == SPCompleted) $ case qd of + QDRcv -> createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCESwitchQueue phase Nothing) Nothing + QDSnd -> createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing + RSYNC rss cryptoErr_ cStats -> + case (rss, connectionCode, cryptoErr_) of + (RSRequired, _, Just cryptoErr) -> processErr cryptoErr + (RSAllowed, _, Just cryptoErr) -> processErr cryptoErr + (RSAgreed, Just _, _) -> do + withStore' $ \db -> setConnectionVerified db user connId Nothing + let ct' = ct {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} :: Contact + ratchetSyncEventItem ct' + securityCodeChanged ct' + _ -> ratchetSyncEventItem ct + where + processErr cryptoErr = do + let e@(mde, n) = agentMsgDecryptError cryptoErr + ci_ <- withStore $ \db -> + getDirectChatItemLast db user contactId + >>= liftIO + . mapM (\(ci, content') -> updateDirectChatItem' db user contactId ci content' False False Nothing Nothing) + . mdeUpdatedCI e + case ci_ of + Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) + _ -> do + toView $ CRContactRatchetSync user ct (RatchetSyncProgress rss cStats) + createInternalChatItem user (CDDirectRcv ct) (CIRcvDecryptionError mde n) Nothing + ratchetSyncEventItem ct' = do + toView $ CRContactRatchetSync user ct' (RatchetSyncProgress rss cStats) + createInternalChatItem user (CDDirectRcv ct') (CIRcvConnEvent $ RCERatchetSync rss) Nothing + OK -> + -- [async agent commands] continuation on receiving OK + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + JOINED sqSecured -> + -- [async agent commands] continuation on receiving JOINED + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> + when (directOrUsed ct && sqSecured) $ do + lift $ setContactNetworkStatus ct NSConnected + toView $ CRContactSndReady user ct + forM_ viaUserContactLink $ \userContactLinkId -> do + ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId + let (UserContactLink {autoAccept}, _, _) = ucl + when (connChatVersion >= batchSend2Version) $ sendAutoReply ct autoAccept + QCONT -> + void $ continueSending connEntity conn + MWARN msgId err -> do + updateDirectItemStatus ct conn msgId (CISSndWarning $ agentSndError err) + processConnMWARN connEntity conn err + MERR msgId err -> do + updateDirectItemStatus ct conn msgId (CISSndError $ agentSndError err) + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + processConnMERR connEntity conn err + MERRS msgIds err -> do + -- error cannot be AUTH error here + updateDirectItemsStatusMsgs ct conn (L.toList msgIds) (CISSndError $ agentSndError err) + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + ERR err -> do + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + -- TODO add debugging output + _ -> pure () + where + sendAutoReply ct = \case + Just AutoAccept {autoReply = Just mc} -> do + (msg, _) <- sendDirectContactMessage user ct (XMsgNew $ MCSimple (extMsgContent mc Nothing)) + ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] + _ -> pure () + + processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> CM () + processGroupMessage agentMsg connEntity conn@Connection {connId, connChatVersion, connectionCode} gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} m = case agentMsg of + INV (ACR _ cReq) -> + withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} -> + case cReq of + groupConnReq@(CRInvitationUri _ _) -> case cmdFunction of + -- [async agent commands] XGrpMemIntro continuation on receiving INV + CFCreateConnGrpMemInv + | maxVersion (peerChatVRange conn) >= groupDirectInvVersion -> sendWithoutDirectCReq + | otherwise -> sendWithDirectCReq + where + sendWithoutDirectCReq = do + let GroupMember {groupMemberId, memberId} = m + hostConnId <- withStore $ \db -> do + liftIO $ setConnConnReqInv db user connId cReq + getHostConnId db user groupId + sendXGrpMemInv hostConnId Nothing XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} + sendWithDirectCReq = do + let GroupMember {groupMemberId, memberId} = m + contData <- withStore' $ \db -> do + setConnConnReqInv db user connId cReq + getXGrpMemIntroContGroup db user m + forM_ contData $ \(hostConnId, directConnReq) -> + sendXGrpMemInv hostConnId (Just directConnReq) XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} + -- [async agent commands] group link auto-accept continuation on receiving INV + CFCreateConnGrpInv -> do + ct <- withStore $ \db -> getContactViaMember db vr user m + withStore' $ \db -> setNewContactMemberConnRequest db user m cReq + groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo + sendGrpInvitation ct m groupLinkId + toView $ CRSentGroupInvitation user gInfo ct m + where + sendGrpInvitation :: Contact -> GroupMember -> Maybe GroupLinkId -> CM () + sendGrpInvitation ct GroupMember {memberId, memberRole = memRole} groupLinkId = do + currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo + let GroupMember {memberRole = userRole, memberId = userMemberId} = membership + groupInv = + GroupInvitation + { fromMember = MemberIdRole userMemberId userRole, + invitedMember = MemberIdRole memberId memRole, + connRequest = cReq, + groupProfile, + business = Nothing, + groupLinkId = groupLinkId, + groupSize = Just currentMemCount + } + (_msg, _) <- sendDirectContactMessage user ct $ XGrpInv groupInv + -- we could link chat item with sent group invitation message (_msg) + createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing + _ -> throwChatError $ CECommandError "unexpected cmdFunction" + CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" + CONF confId _pqSupport _ connInfo -> do + ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo + conn' <- updatePeerChatVRange conn chatVRange + case memberCategory m of + GCInviteeMember -> + case chatMsgEvent of + XGrpAcpt memId + | sameMemberId memId m -> do + withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted + -- [async agent commands] no continuation needed, but command should be asynchronous for stability + allowAgentConnectionAsync user conn' confId XOk + | otherwise -> messageError "x.grp.acpt: memberId is different from expected" + _ -> messageError "CONF from invited member must have x.grp.acpt" + _ -> + case chatMsgEvent of + XGrpMemInfo memId _memProfile + | sameMemberId memId m -> do + let GroupMember {memberId = membershipMemId} = membership + membershipProfile = redactedMemberProfile $ fromLocalProfile $ memberProfile membership + -- TODO update member profile + -- [async agent commands] no continuation needed, but command should be asynchronous for stability + allowAgentConnectionAsync user conn' confId $ XGrpMemInfo membershipMemId membershipProfile + | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" + _ -> messageError "CONF from member must have x.grp.mem.info" + INFO _pqSupport connInfo -> do + ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo + _conn' <- updatePeerChatVRange conn chatVRange + case chatMsgEvent of + XGrpMemInfo memId _memProfile + | sameMemberId memId m -> do + -- TODO update member profile + pure () + | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" + XInfo _ -> pure () -- sent when connecting via group link + XOk -> pure () + _ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok" + pure () + CON _pqEnc -> do + withStore' $ \db -> do + updateGroupMemberStatus db userId m GSMemConnected + unless (memberActive membership) $ + 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) $ chatHasNtfs chatSettings + case memberCategory m of + GCHostMember -> do + toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected} + let cd = CDGroupRcv gInfo m + createInternalChatItem user cd (CIRcvGroupE2EEInfo E2EInfo {pqEnabled = PQEncOff}) Nothing + createGroupFeatureItems user cd CIRcvGroupFeature gInfo + let GroupInfo {groupProfile = GroupProfile {description}} = gInfo + memberConnectedChatItem gInfo m + unless expectHistory $ forM_ description $ groupDescriptionChatItem gInfo m + where + expectHistory = groupFeatureAllowed SGFHistory gInfo && m `supportsVersion` groupHistoryIncludeWelcomeVersion + GCInviteeMember -> do + memberConnectedChatItem gInfo m + toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected} + let Connection {viaUserContactLink} = conn + when (isJust viaUserContactLink && isNothing (memberContactId m)) sendXGrpLinkMem + members <- withStore' $ \db -> getGroupMembers db vr user gInfo + void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m + sendIntroductions members + when (groupFeatureAllowed SGFHistory gInfo) sendHistory + when (connChatVersion < batchSend2Version) sendGroupAutoReply + where + sendXGrpLinkMem = do + let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo + profileToSend = profileToSendOnAccept user profileMode True + void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId + sendIntroductions members = do + intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m + shuffledIntros <- liftIO $ shuffleIntros intros + if m `supportsVersion` batchSendVersion + then do + let events = map (memberIntro . reMember) shuffledIntros + forM_ (L.nonEmpty events) $ \events' -> + sendGroupMemberMessages user conn events' groupId + else forM_ shuffledIntros $ \intro -> + processIntro intro `catchChatError` (toView . CRChatError (Just user)) + memberIntro :: GroupMember -> ChatMsgEvent 'Json + memberIntro reMember = + let mInfo = memberInfo reMember + mRestrictions = memberRestrictions reMember + in XGrpMemIntro mInfo mRestrictions + shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro] + shuffleIntros intros = do + let (admins, others) = partition isAdmin intros + (admPics, admNoPics) = partition hasPicture admins + (othPics, othNoPics) = partition hasPicture others + mconcat <$> mapM shuffle [admPics, admNoPics, othPics, othNoPics] + where + isAdmin GroupMemberIntro {reMember = GroupMember {memberRole}} = memberRole >= GRAdmin + hasPicture GroupMemberIntro {reMember = GroupMember {memberProfile = LocalProfile {image}}} = isJust image + processIntro intro@GroupMemberIntro {introId} = do + void $ sendDirectMemberMessage conn (memberIntro $ reMember intro) groupId + withStore' $ \db -> updateIntroStatus db introId GMIntroSent + sendHistory = + when (m `supportsVersion` batchSendVersion) $ do + (errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100) + (errs', events) <- partitionEithers <$> mapM (tryChatError . itemForwardEvents) items + let errors = map ChatErrorStore errs <> errs' + unless (null errors) $ toView $ CRChatErrors (Just user) errors + let events' = maybe (concat events) (\x -> concat events <> [x]) descrEvent_ + forM_ (L.nonEmpty events') $ \events'' -> + sendGroupMemberMessages user conn events'' groupId + descrEvent_ :: Maybe (ChatMsgEvent 'Json) + descrEvent_ + | m `supportsVersion` groupHistoryIncludeWelcomeVersion = do + let GroupInfo {groupProfile = GroupProfile {description}} = gInfo + fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description + | otherwise = Nothing + itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json] + itemForwardEvents cci = case cci of + (CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) + | not (blockedByAdmin sender) -> do + fInvDescr_ <- join <$> forM file getRcvFileInvDescr + processContentItem sender ci mc fInvDescr_ + (CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do + fInvDescr_ <- join <$> forM file getSndFileInvDescr + processContentItem membership ci mc fInvDescr_ + _ -> pure [] + where + getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText)) + getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do + expired <- fileExpired + if fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled || expired + then pure Nothing + else do + rfd <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId + pure $ invCompleteDescr ciFile rfd + getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe (FileInvitation, RcvFileDescrText)) + getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do + expired <- fileExpired + if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired + then pure Nothing + else do + -- can also lookup in extra_xftp_file_descriptions, though it can be empty; + -- would be best if snd file had a single rcv description for all members saved in files table + rfd <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId + pure $ invCompleteDescr ciFile rfd + fileExpired :: CM Bool + fileExpired = do + ttl <- asks $ rcvFilesTTL . agentConfig . config + cutoffTs <- addUTCTime (-ttl) <$> liftIO getCurrentTime + pure $ chatItemTs cci < cutoffTs + invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText) + invCompleteDescr CIFile {fileName, fileSize} RcvFileDescr {fileDescrText, fileDescrComplete} + | fileDescrComplete = + let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} + fInv = xftpFileInvitation fileName fileSize fInvDescr + in Just (fInv, fileDescrText) + | otherwise = Nothing + processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json] + processContentItem sender ChatItem {meta, quotedItem} mc fInvDescr_ = + if isNothing fInvDescr_ && not (msgContentHasText mc) + then pure [] + else do + let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta + quotedItemId_ = quoteItemId =<< quotedItem + fInv_ = fst <$> fInvDescr_ + (msgContainer, _) <- prepareGroupMsg user gInfo mc quotedItemId_ Nothing fInv_ itemTimed False + let senderVRange = memberChatVRange' sender + xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer} + fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of + (Just fileDescrText, Just msgId) -> do + partSize <- asks $ xftpDescrPartSize . config + let parts = splitFileDescr partSize fileDescrText + pure . L.toList $ L.map (XMsgFileDescr msgId) parts + _ -> pure [] + let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents + GroupMember {memberId} = sender + msgForwardEvents = map (\cm -> XGrpMsgForward memberId cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) + pure msgForwardEvents + _ -> do + let memCategory = memberCategory m + withStore' (\db -> getViaGroupContact db vr user m) >>= \case + Nothing -> do + notifyMemberConnected gInfo m Nothing + let connectedIncognito = memberIncognito membership + when (memCategory == GCPreMember) $ probeMatchingMemberContact m connectedIncognito + Just ct@Contact {activeConn} -> + forM_ activeConn $ \Connection {connStatus} -> + when (connStatus == ConnReady) $ do + notifyMemberConnected gInfo m $ Just ct + let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo + when (memCategory == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True + sendXGrpMemCon memCategory + where + GroupMember {memberId} = m + sendXGrpMemCon = \case + GCPreMember -> + forM_ (invitedByGroupMemberId membership) $ \hostId -> do + host <- withStore $ \db -> getGroupMember db vr user groupId hostId + forM_ (memberConn host) $ \hostConn -> + void $ sendDirectMemberMessage hostConn (XGrpMemCon memberId) groupId + GCPostMember -> + forM_ (invitedByGroupMemberId m) $ \invitingMemberId -> do + im <- withStore $ \db -> getGroupMember db vr user groupId invitingMemberId + forM_ (memberConn im) $ \imConn -> + void $ sendDirectMemberMessage imConn (XGrpMemCon memberId) groupId + _ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected" + MSG msgMeta _msgFlags msgBody -> do + tags <- newTVarIO [] + withAckMessage "group msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do + checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure () + forM_ aChatMsgs $ \case + Right (ACMsg _ chatMsg) -> + processEvent tags eInfo chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e + Left e -> do + atomically $ modifyTVar' tags ("error" :) + logInfo $ "group msg=error " <> eInfo <> " " <> tshow e + toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e) + forwardMsgs (rights aChatMsgs) `catchChatError` (toView . CRChatError (Just user)) + checkSendRcpt $ rights aChatMsgs + where + aChatMsgs = parseChatMessages msgBody + brokerTs = metaBrokerTs msgMeta + processEvent :: TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM () + processEvent tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do + let tag = toCMEventTag chatMsgEvent + atomically $ modifyTVar' tags (tshow tag :) + logInfo $ "group msg=" <> tshow tag <> " " <> eInfo + (m', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m conn msgMeta msgBody chatMsg + case event of + XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs False + XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr + XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg brokerTs ttl live + XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs + XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs + -- TODO discontinue XFile + XFile fInv -> processGroupFileInvitation' gInfo m' fInv msg brokerTs + XFileCancel sharedMsgId -> xFileCancelGroup gInfo m' sharedMsgId + XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m' sharedMsgId fileConnReq_ fName + XInfo p -> xInfoMember gInfo m' p brokerTs + XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p + XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg brokerTs + XGrpMemIntro memInfo memRestrictions_ -> xGrpMemIntro gInfo m' memInfo memRestrictions_ + XGrpMemInv memId introInv -> xGrpMemInv gInfo m' memId introInv + XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo m' memInfo introInv + XGrpMemRole memId memRole -> xGrpMemRole gInfo m' memId memRole msg brokerTs + XGrpMemRestrict memId memRestrictions -> xGrpMemRestrict gInfo m' memId memRestrictions msg brokerTs + XGrpMemCon memId -> xGrpMemCon gInfo m' memId + XGrpMemDel memId -> xGrpMemDel gInfo m' memId msg brokerTs + XGrpLeave -> xGrpLeave gInfo m' msg brokerTs + XGrpDel -> xGrpDel gInfo m' msg brokerTs + XGrpInfo p' -> xGrpInfo gInfo m' p' msg brokerTs + XGrpPrefs ps' -> xGrpPrefs gInfo m' ps' + XGrpDirectInv connReq mContent_ -> memberCanSend m' $ xGrpDirectInv gInfo m' conn' connReq mContent_ msg brokerTs + XGrpMsgForward memberId msg' msgTs -> xGrpMsgForward gInfo m' memberId msg' msgTs + XInfoProbe probe -> xInfoProbe (COMGroupMember m') probe + XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m') probeHash + XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m') probe + BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta + _ -> messageError $ "unsupported message: " <> tshow event + checkSendRcpt :: [AChatMessage] -> CM Bool + checkSendRcpt aMsgs = do + currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo + let GroupInfo {chatSettings = ChatSettings {sendRcpts}} = gInfo + pure $ + fromMaybe (sendRcptsSmallGroups user) sendRcpts + && any aChatMsgHasReceipt aMsgs + && currentMemCount <= smallGroupsRcptsMemLimit + where + aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) = + hasDeliveryReceipt (toCMEventTag chatMsgEvent) + forwardMsgs :: [AChatMessage] -> CM () + forwardMsgs aMsgs = do + let GroupMember {memberRole = membershipMemRole} = membership + when (membershipMemRole >= GRAdmin && not (blockedByAdmin m)) $ do + let forwardedMsgs = mapMaybe (\(ACMsg _ chatMsg) -> forwardedGroupMsg chatMsg) aMsgs + forM_ (L.nonEmpty forwardedMsgs) $ \forwardedMsgs' -> do + ChatConfig {highlyAvailable} <- asks config + -- members introduced to this invited member + introducedMembers <- + if memberCategory m == GCInviteeMember + then withStore' $ \db -> getForwardIntroducedMembers db vr user m highlyAvailable + else pure [] + -- invited members to which this member was introduced + invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db vr user m highlyAvailable + let GroupMember {memberId} = m + ms = forwardedToGroupMembers (introducedMembers <> invitedMembers) forwardedMsgs' + events = L.map (\cm -> XGrpMsgForward memberId cm brokerTs) forwardedMsgs' + unless (null ms) $ void $ sendGroupMessages user gInfo ms events + RCVD msgMeta msgRcpt -> + withAckMessage' "group rcvd" agentConnId msgMeta $ + groupMsgReceived gInfo m conn msgMeta msgRcpt + SENT msgId proxy -> do + continued <- continueSending connEntity conn + sentMsgDeliveryEvent conn msgId + checkSndInlineFTComplete conn msgId + updateGroupItemsStatus gInfo m conn msgId GSSSent (Just $ isJust proxy) + when continued $ sendPendingGroupMessages user m conn + SWITCH qd phase cStats -> do + toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats) + when (phase == SPStarted || phase == SPCompleted) $ case qd of + QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing + QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing + RSYNC rss cryptoErr_ cStats -> + case (rss, connectionCode, cryptoErr_) of + (RSRequired, _, Just cryptoErr) -> processErr cryptoErr + (RSAllowed, _, Just cryptoErr) -> processErr cryptoErr + (RSAgreed, Just _, _) -> do + withStore' $ \db -> setConnectionVerified db user connId Nothing + let m' = m {activeConn = Just (conn {connectionCode = Nothing} :: Connection)} :: GroupMember + ratchetSyncEventItem m' + toView $ CRGroupMemberVerificationReset user gInfo m' + createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent RCEVerificationCodeReset) Nothing + _ -> ratchetSyncEventItem m + where + processErr cryptoErr = do + let e@(mde, n) = agentMsgDecryptError cryptoErr + ci_ <- withStore $ \db -> + getGroupMemberChatItemLast db user groupId (groupMemberId' m) + >>= liftIO + . mapM (\(ci, content') -> updateGroupChatItem db user groupId ci content' False False Nothing) + . mdeUpdatedCI e + case ci_ of + Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci) + _ -> do + toView $ CRGroupMemberRatchetSync user gInfo m (RatchetSyncProgress rss cStats) + createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvDecryptionError mde n) Nothing + ratchetSyncEventItem m' = do + toView $ CRGroupMemberRatchetSync user gInfo m' (RatchetSyncProgress rss cStats) + createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent $ RCERatchetSync rss) Nothing + OK -> + -- [async agent commands] continuation on receiving OK + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + JOINED sqSecured -> + -- [async agent commands] continuation on receiving JOINED + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> + when (sqSecured && connChatVersion >= batchSend2Version) sendGroupAutoReply + QCONT -> do + continued <- continueSending connEntity conn + when continued $ sendPendingGroupMessages user m conn + MWARN msgId err -> do + withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSWarning $ agentSndError err) + processConnMWARN connEntity conn err + MERR msgId err -> do + withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSError $ agentSndError err) + -- group errors are silenced to reduce load on UI event log + -- toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + processConnMERR connEntity conn err + MERRS msgIds err -> do + let newStatus = GSSError $ agentSndError err + -- error cannot be AUTH error here + withStore' $ \db -> forM_ msgIds $ \msgId -> + updateGroupItemsErrorStatus db msgId (groupMemberId' m) newStatus `catchAll_` pure () + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + ERR err -> do + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + -- TODO add debugging output + _ -> pure () + where + updateGroupItemsErrorStatus :: DB.Connection -> AgentMsgId -> GroupMemberId -> GroupSndStatus -> IO () + updateGroupItemsErrorStatus db msgId groupMemberId newStatus = do + itemIds <- getChatItemIdsByAgentMsgId db connId msgId + forM_ itemIds $ \itemId -> updateGroupMemSndStatus' db itemId groupMemberId newStatus + sendGroupAutoReply = autoReplyMC >>= mapM_ send + where + autoReplyMC = do + let GroupInfo {businessChat} = gInfo + GroupMember {memberId = joiningMemberId} = m + case businessChat of + Just BusinessChatInfo {customerId, chatType = BCCustomer} + | joiningMemberId == customerId -> useReply <$> withStore (`getUserAddress` user) + where + useReply UserContactLink {autoAccept} = case autoAccept of + Just AutoAccept {businessAddress, autoReply} | businessAddress -> autoReply + _ -> Nothing + _ -> pure Nothing + send mc = do + msg <- sendGroupMessage' user gInfo [m] (XMsgNew $ MCSimple (extMsgContent mc Nothing)) + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndMsgContent mc) + withStore' $ \db -> createGroupSndStatus db (chatItemId' ci) (groupMemberId' m) GSSNew + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] + + agentMsgDecryptError :: AgentCryptoError -> (MsgDecryptError, Word32) + agentMsgDecryptError = \case + DECRYPT_AES -> (MDEOther, 1) + DECRYPT_CB -> (MDEOther, 1) + RATCHET_HEADER -> (MDERatchetHeader, 1) + RATCHET_EARLIER _ -> (MDERatchetEarlier, 1) + RATCHET_SKIPPED n -> (MDETooManySkipped, n) + RATCHET_SYNC -> (MDERatchetSync, 0) + + mdeUpdatedCI :: (MsgDecryptError, Word32) -> CChatItem c -> Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv) + mdeUpdatedCI (mde', n') (CChatItem _ ci@ChatItem {content = CIRcvDecryptionError mde n}) + | mde == mde' = case mde of + MDERatchetHeader -> r (n + n') + MDETooManySkipped -> r n' -- the numbers are not added as sequential MDETooManySkipped will have it incremented by 1 + MDERatchetEarlier -> r (n + n') + MDEOther -> r (n + n') + MDERatchetSync -> r 0 + | otherwise = Nothing + where + r n'' = Just (ci, CIRcvDecryptionError mde n'') + mdeUpdatedCI _ _ = Nothing + + processSndFileConn :: AEvent e -> ConnectionEntity -> Connection -> SndFileTransfer -> CM () + processSndFileConn agentMsg connEntity conn ft@SndFileTransfer {fileId, fileName, fileStatus} = + case agentMsg of + -- SMP CONF for SndFileConnection happens for direct file protocol + -- when recipient of the file "joins" connection created by the sender + CONF confId _pqSupport _ connInfo -> do + ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo + conn' <- updatePeerChatVRange conn chatVRange + case chatMsgEvent of + -- TODO save XFileAcpt message + XFileAcpt name + | name == fileName -> do + withStore' $ \db -> updateSndFileStatus db ft FSAccepted + -- [async agent commands] no continuation needed, but command should be asynchronous for stability + allowAgentConnectionAsync user conn' confId XOk + | otherwise -> messageError "x.file.acpt: fileName is different from expected" + _ -> messageError "CONF from file connection must have x.file.acpt" + CON _ -> do + ci <- withStore $ \db -> do + liftIO $ updateSndFileStatus db ft FSConnected + updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1 + toView $ CRSndFileStart user ci ft + sendFileChunk user ft + SENT msgId _proxy -> do + withStore' $ \db -> updateSndFileChunkSent db ft msgId + unless (fileStatus == FSCancelled) $ sendFileChunk user ft + MERR _ err -> do + cancelSndFileTransfer user ft True >>= mapM_ (deleteAgentConnectionAsync user) + case err of + SMP _ SMP.AUTH -> unless (fileStatus == FSCancelled) $ do + ci <- withStore $ \db -> do + liftIO (lookupChatRefByFileId db user fileId) >>= \case + Just (ChatRef CTDirect _) -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled + _ -> pure () + lookupChatItemByFileId db vr user fileId + toView $ CRSndFileRcvCancelled user ci ft + _ -> throwChatError $ CEFileSend fileId err + MSG meta _ _ -> + withAckMessage' "file msg" agentConnId meta $ pure () + OK -> + -- [async agent commands] continuation on receiving OK + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + JOINED _ -> + -- [async agent commands] continuation on receiving JOINED + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + ERR err -> do + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + -- TODO add debugging output + _ -> pure () + + processRcvFileConn :: AEvent e -> ConnectionEntity -> Connection -> RcvFileTransfer -> CM () + processRcvFileConn agentMsg connEntity conn ft@RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}, grpMemberId} = + case agentMsg of + INV (ACR _ cReq) -> + withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} -> + case cReq of + fileInvConnReq@(CRInvitationUri _ _) -> case cmdFunction of + -- [async agent commands] direct XFileAcptInv continuation on receiving INV + CFCreateConnFileInvDirect -> do + ct <- withStore $ \db -> getContactByFileId db vr user fileId + sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId + void $ sendDirectContactMessage user ct (XFileAcptInv sharedMsgId (Just fileInvConnReq) fileName) + -- [async agent commands] group XFileAcptInv continuation on receiving INV + CFCreateConnFileInvGroup -> case grpMemberId of + Just gMemberId -> do + GroupMember {groupId, activeConn} <- withStore $ \db -> getGroupMemberById db vr user gMemberId + case activeConn of + Just gMemberConn -> do + sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId + void $ sendDirectMemberMessage gMemberConn (XFileAcptInv sharedMsgId (Just fileInvConnReq) fileName) groupId + _ -> throwChatError $ CECommandError "no GroupMember activeConn" + _ -> throwChatError $ CECommandError "no grpMemberId" + _ -> throwChatError $ CECommandError "unexpected cmdFunction" + CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" + -- SMP CONF for RcvFileConnection happens for group file protocol + -- when sender of the file "joins" connection created by the recipient + -- (sender doesn't create connections for all group members) + CONF confId _pqSupport _ connInfo -> do + ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo + conn' <- updatePeerChatVRange conn chatVRange + case chatMsgEvent of + XOk -> allowAgentConnectionAsync user conn' confId XOk -- [async agent commands] no continuation needed, but command should be asynchronous for stability + _ -> pure () + CON _ -> startReceivingFile user fileId + MSG meta _ msgBody -> do + -- XXX: not all branches do ACK + parseFileChunk msgBody >>= receiveFileChunk ft (Just conn) meta + OK -> + -- [async agent commands] continuation on receiving OK + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + JOINED _ -> + -- [async agent commands] continuation on receiving JOINED + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + MERR _ err -> do + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + processConnMERR connEntity conn err + ERR err -> do + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + -- TODO add debugging output + _ -> pure () + + receiveFileChunk :: RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> CM () + receiveFileChunk ft@RcvFileTransfer {fileId, chunkSize} conn_ meta@MsgMeta {recipient = (msgId, _), integrity} = \case + FileChunkCancel -> + unless (rcvFileCompleteOrCancelled ft) $ do + cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) + ci <- withStore $ \db -> getChatItemByFileId db vr user fileId + toView $ CRRcvFileSndCancelled user ci ft + FileChunk {chunkNo, chunkBytes = chunk} -> do + case integrity of + MsgOk -> pure () + MsgError MsgDuplicate -> pure () -- TODO remove once agent removes duplicates + MsgError e -> + badRcvFileChunk ft $ "invalid file chunk number " <> show chunkNo <> ": " <> show e + withStore' (\db -> createRcvFileChunk db ft chunkNo msgId) >>= \case + RcvChunkOk -> + if B.length chunk /= fromInteger chunkSize + then badRcvFileChunk ft "incorrect chunk size" + else withAckMessage' "file msg" agentConnId meta $ appendFileChunk ft chunkNo chunk False + RcvChunkFinal -> + if B.length chunk > fromInteger chunkSize + then badRcvFileChunk ft "incorrect chunk size" + else do + appendFileChunk ft chunkNo chunk True + ci <- withStore $ \db -> do + liftIO $ do + updateRcvFileStatus db fileId FSComplete + updateCIFileStatus db user fileId CIFSRcvComplete + deleteRcvFileChunks db ft + getChatItemByFileId db vr user fileId + toView $ CRRcvFileComplete user ci + forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn) + RcvChunkDuplicate -> withAckMessage' "file msg" agentConnId meta $ pure () + RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo + + processUserContactRequest :: AEvent e -> ConnectionEntity -> Connection -> UserContact -> CM () + processUserContactRequest agentMsg connEntity conn UserContact {userContactLinkId} = case agentMsg of + REQ invId pqSupport _ connInfo -> do + ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo + case chatMsgEvent of + XContact p xContactId_ -> profileContactRequest invId chatVRange p xContactId_ pqSupport + XInfo p -> profileContactRequest invId chatVRange p Nothing pqSupport + -- TODO show/log error, other events in contact request + _ -> pure () + MERR _ err -> do + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + processConnMERR connEntity conn err + ERR err -> do + toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity) + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + -- TODO add debugging output + _ -> pure () + where + profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> PQSupport -> CM () + profileContactRequest invId chatVRange p xContactId_ reqPQSup = do + withStore (\db -> createOrUpdateContactRequest db vr user userContactLinkId invId chatVRange p xContactId_ reqPQSup) >>= \case + CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact + CORGroup gInfo -> toView $ CRBusinessRequestAlreadyAccepted user gInfo + CORRequest cReq -> do + ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId + let (UserContactLink {connReqContact, autoAccept}, groupId_, gLinkMemRole) = ucl + isSimplexTeam = sameConnReqContact connReqContact adminContactReq + v = maxVersion chatVRange + case autoAccept of + Just AutoAccept {acceptIncognito, businessAddress} + | businessAddress -> + if v < groupFastLinkJoinVersion || (isSimplexTeam && v < businessChatsVersion) + then do + ct <- acceptContactRequestAsync user cReq Nothing True reqPQSup + toView $ CRAcceptingContactRequest user ct + else do + gInfo <- acceptBusinessJoinRequestAsync user cReq + toView $ CRAcceptingBusinessRequest user gInfo + | otherwise -> case groupId_ of + Nothing -> do + -- [incognito] generate profile to send, create connection with incognito profile + incognitoProfile <- if acceptIncognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing + ct <- acceptContactRequestAsync user cReq incognitoProfile True reqPQSup + toView $ CRAcceptingContactRequest user ct + Just groupId -> do + gInfo <- withStore $ \db -> getGroupInfo db vr user groupId + let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo + if v >= groupFastLinkJoinVersion + then do + mem <- acceptGroupJoinRequestAsync user gInfo cReq gLinkMemRole profileMode + createInternalChatItem user (CDGroupRcv gInfo mem) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing + toView $ CRAcceptingGroupJoinRequestMember user gInfo mem + else do + -- TODO v5.7 remove old API (or v6.0?) + ct <- acceptContactRequestAsync user cReq profileMode False PQSupportOff + toView $ CRAcceptingGroupJoinRequest user gInfo ct + _ -> toView $ CRReceivedContactRequest user cReq + + memberCanSend :: GroupMember -> CM () -> CM () + memberCanSend GroupMember {memberRole} a + | memberRole <= GRObserver = messageError "member is not allowed to send messages" + | otherwise = a + + processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM () + processConnMERR connEntity conn err = do + case err of + SMP _ SMP.AUTH -> do + authErrCounter' <- withStore' $ \db -> incAuthErrCounter db user conn + when (authErrCounter' >= authErrDisableCount) $ case connEntity of + RcvDirectMsgConnection ctConn (Just ct) -> do + toView $ CRContactDisabled user ct {activeConn = Just ctConn {authErrCounter = authErrCounter'}} + _ -> toView $ CRConnectionDisabled connEntity + SMP _ SMP.QUOTA -> + unless (connInactive conn) $ do + withStore' $ \db -> setQuotaErrCounter db user conn quotaErrSetOnMERR + toView $ CRConnectionInactive connEntity True + _ -> pure () + + processConnMWARN :: ConnectionEntity -> Connection -> AgentErrorType -> CM () + processConnMWARN connEntity conn err = do + case err of + SMP _ SMP.QUOTA -> + unless (connInactive conn) $ do + quotaErrCounter' <- withStore' $ \db -> incQuotaErrCounter db user conn + when (quotaErrCounter' >= quotaErrInactiveCount) $ + toView $ + CRConnectionInactive connEntity True + _ -> pure () + + continueSending :: ConnectionEntity -> Connection -> CM Bool + continueSending connEntity conn = + if connInactive conn + then do + withStore' $ \db -> setQuotaErrCounter db user conn 0 + toView $ CRConnectionInactive connEntity False + pure True + else pure False + + -- TODO v5.7 / v6.0 - together with deprecating old group protocol establishing direct connections? + -- we could save command records only for agent APIs we process continuations for (INV) + withCompletedCommand :: forall e. AEntityI e => Connection -> AEvent e -> (CommandData -> CM ()) -> CM () + withCompletedCommand Connection {connId} agentMsg action = do + let agentMsgTag = AEvtTag (sAEntity @e) $ aEventTag agentMsg + cmdData_ <- withStore' $ \db -> getCommandDataByCorrId db user corrId + case cmdData_ of + Just cmdData@CommandData {cmdId, cmdConnId = Just cmdConnId', cmdFunction} + | connId == cmdConnId' && (agentMsgTag == commandExpectedResponse cmdFunction || agentMsgTag == AEvtTag SAEConn ERR_) -> do + withStore' $ \db -> deleteCommand db user cmdId + action cmdData + | otherwise -> err cmdId $ "not matching connection id or unexpected response, corrId = " <> show corrId + Just CommandData {cmdId, cmdConnId = Nothing} -> err cmdId $ "no command connection id, corrId = " <> show corrId + Nothing -> throwChatError . CEAgentCommandError $ "command not found, corrId = " <> show corrId + where + err cmdId msg = do + withStore' $ \db -> updateCommandStatus db user cmdId CSError + throwChatError . CEAgentCommandError $ msg + + withAckMessage' :: Text -> ConnId -> MsgMeta -> CM () -> CM () + withAckMessage' label cId msgMeta action = do + withAckMessage label cId msgMeta False Nothing $ \_ -> action $> False + + withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe (TVar [Text]) -> (Text -> CM Bool) -> CM () + withAckMessage label cId msgMeta showCritical tags action = do + -- [async agent commands] command should be asynchronous + -- TODO catching error and sending ACK after an error, particularly if it is a database error, will result in the message not processed (and no notification to the user). + -- Possible solutions are: + -- 1) retry processing several times + -- 2) stabilize database + -- 3) show screen of death to the user asking to restart + eInfo <- eventInfo + logInfo $ label <> ": " <> eInfo + tryChatError (action eInfo) >>= \case + Right withRcpt -> + withLog (eInfo <> " ok") $ ackMsg msgMeta $ if withRcpt then Just "" else Nothing + -- If showCritical is True, then these errors don't result in ACK and show user visible alert + -- This prevents losing the message that failed to be processed. + Left (ChatErrorStore SEDBBusyError {message}) | showCritical -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing + Left e -> do + withLog (eInfo <> " error: " <> tshow e) $ ackMsg msgMeta Nothing + throwError e + where + eventInfo = do + v <- asks eventSeq + eId <- atomically $ stateTVar v $ \i -> (i + 1, i + 1) + pure $ "conn_id=" <> tshow cId <> " event_id=" <> tshow eId + withLog eInfo' ack = do + ts <- showTags + logInfo $ T.unwords [label, "ack:", ts, eInfo'] + ack + logInfo $ T.unwords [label, "ack=success:", ts, eInfo'] + showTags = do + ts <- maybe (pure []) readTVarIO tags + pure $ case ts of + [] -> "no_chat_messages" + [t] -> "chat_message=" <> t + _ -> "chat_message_batch=" <> T.intercalate "," (reverse ts) + ackMsg :: MsgMeta -> Maybe MsgReceiptInfo -> CM () + ackMsg MsgMeta {recipient = (msgId, _)} rcpt = withAgent $ \a -> ackMessageAsync a "" cId msgId rcpt + + sentMsgDeliveryEvent :: Connection -> AgentMsgId -> CM () + sentMsgDeliveryEvent Connection {connId} msgId = + withStore' $ \db -> updateSndMsgDeliveryStatus db connId msgId MDSSndSent + + agentSndError :: AgentErrorType -> SndError + agentSndError = \case + SMP _ AUTH -> SndErrAuth + SMP _ QUOTA -> SndErrQuota + BROKER _ e -> brokerError SndErrRelay e + SMP proxySrv (SMP.PROXY (SMP.BROKER e)) -> brokerError (SndErrProxy proxySrv) e + AP.PROXY proxySrv _ (ProxyProtocolError (SMP.PROXY (SMP.BROKER e))) -> brokerError (SndErrProxyRelay proxySrv) e + e -> SndErrOther $ tshow e + where + brokerError srvErr = \case + NETWORK -> SndErrExpired + TIMEOUT -> SndErrExpired + HOST -> srvErr SrvErrHost + SMP.TRANSPORT TEVersion -> srvErr SrvErrVersion + e -> srvErr . SrvErrOther $ tshow e + + badRcvFileChunk :: RcvFileTransfer -> String -> CM () + badRcvFileChunk ft err = + unless (rcvFileCompleteOrCancelled ft) $ do + cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) + throwChatError $ CEFileRcvChunk err + + memberConnectedChatItem :: GroupInfo -> GroupMember -> CM () + memberConnectedChatItem gInfo m = + -- ts should be broker ts but we don't have it for CON + createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEMemberConnected) Nothing + + groupDescriptionChatItem :: GroupInfo -> GroupMember -> Text -> CM () + groupDescriptionChatItem gInfo m descr = + createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvMsgContent $ MCText descr) Nothing + + notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> CM () + notifyMemberConnected gInfo m ct_ = do + memberConnectedChatItem gInfo m + lift $ mapM_ (`setContactNetworkStatus` NSConnected) ct_ + toView $ CRConnectedToGroupMember user gInfo m ct_ + + probeMatchingContactsAndMembers :: Contact -> IncognitoEnabled -> Bool -> CM () + probeMatchingContactsAndMembers ct connectedIncognito doProbeContacts = do + gVar <- asks random + contactMerge <- readTVarIO =<< asks contactMergeEnabled + if contactMerge && not connectedIncognito + then do + (probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId (COMContact ct) + -- ! when making changes to probe-and-merge mechanism, + -- ! test scenario in which recipient receives probe after probe hashes (not covered in tests): + -- sendProbe -> sendProbeHashes (currently) + -- sendProbeHashes -> sendProbe (reversed - change order in code, may add delay) + sendProbe probe + cs <- + if doProbeContacts + then map COMContact <$> withStore' (\db -> getMatchingContacts db vr user ct) + else pure [] + ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db vr user ct) + sendProbeHashes (cs <> ms) probe probeId + else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32) + where + sendProbe :: Probe -> CM () + sendProbe probe = void . sendDirectContactMessage user ct $ XInfoProbe probe + + probeMatchingMemberContact :: GroupMember -> IncognitoEnabled -> CM () + probeMatchingMemberContact GroupMember {activeConn = Nothing} _ = pure () + probeMatchingMemberContact m@GroupMember {groupId, activeConn = Just conn} connectedIncognito = do + gVar <- asks random + contactMerge <- readTVarIO =<< asks contactMergeEnabled + if contactMerge && not connectedIncognito + then do + (probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId $ COMGroupMember m + sendProbe probe + cs <- map COMContact <$> withStore' (\db -> getMatchingMemberContacts db vr user m) + sendProbeHashes cs probe probeId + else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32) + where + sendProbe :: Probe -> CM () + sendProbe probe = void $ sendDirectMemberMessage conn (XInfoProbe probe) groupId + + sendProbeHashes :: [ContactOrMember] -> Probe -> Int64 -> CM () + sendProbeHashes cgms probe probeId = + forM_ cgms $ \cgm -> sendProbeHash cgm `catchChatError` \_ -> pure () + where + probeHash = ProbeHash $ C.sha256Hash (unProbe probe) + sendProbeHash :: ContactOrMember -> CM () + sendProbeHash cgm@(COMContact c) = do + void . sendDirectContactMessage user c $ XInfoProbeCheck probeHash + withStore' $ \db -> createSentProbeHash db userId probeId cgm + sendProbeHash (COMGroupMember GroupMember {activeConn = Nothing}) = pure () + sendProbeHash cgm@(COMGroupMember m@GroupMember {groupId, activeConn = Just conn}) = + when (memberCurrent m) $ do + void $ sendDirectMemberMessage conn (XInfoProbeCheck probeHash) groupId + withStore' $ \db -> createSentProbeHash db userId probeId cgm + + messageWarning :: Text -> CM () + messageWarning = toView . CRMessageError user "warning" + + messageError :: Text -> CM () + messageError = toView . CRMessageError user "error" + + newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM () + newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do + unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct + let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc + -- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete + -- case content of + -- MCText "hello 111" -> + -- UE.throwIO $ userError "#####################" + -- -- throwChatError $ CECommandError "#####################" + -- _ -> pure () + if isVoice content && not (featureAllowed SCFVoice forContact ct) + then do + void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False + 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 + newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live + autoAcceptFile file_ + where + brokerTs = metaBrokerTs msgMeta + newChatItem ciContent ciFile_ timed_ live = do + ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live + reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_ + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions}] + + autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM () + autoAcceptFile = mapM_ $ \(ft, CIFile {fileSize}) -> do + -- ! autoAcceptFileSize is only used in tests + ChatConfig {autoAcceptFileSize = sz} <- asks config + when (sz > fileSize) $ receiveFile' user ft False Nothing Nothing >>= toView + + messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> CM () + messageFileDescription ct@Contact {contactId} sharedMsgId fileDescr = do + fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId + processFDMessage (CDDirectRcv ct) sharedMsgId fileId fileDescr + + groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM () + groupMessageFileDescription g@GroupInfo {groupId} m sharedMsgId fileDescr = do + fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId + processFDMessage (CDGroupRcv g m) sharedMsgId fileId fileDescr + + processFDMessage :: ChatTypeQuotable c => ChatDirection c 'MDRcv -> SharedMsgId -> FileTransferId -> FileDescr -> CM () + processFDMessage cd sharedMsgId fileId fileDescr = do + ft <- withStore $ \db -> getRcvFileTransfer db user fileId + unless (rcvFileCompleteOrCancelled ft) $ do + (rfd@RcvFileDescr {fileDescrComplete}, ft'@RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs}) <- withStore $ \db -> do + rfd <- appendRcvFD db userId fileId fileDescr + -- reading second time in the same transaction as appending description + -- to prevent race condition with accept + ft' <- getRcvFileTransfer db user fileId + pure (rfd, ft') + when fileDescrComplete $ do + ci <- withStore $ \db -> getAChatItemBySharedMsgId db user cd sharedMsgId + toView $ CRRcvFileDescrReady user ci ft' rfd + case (fileStatus, xftpRcvFile) of + (RFSAccepted _, Just XFTPRcvFile {userApprovedRelays}) -> receiveViaCompleteFD user fileId rfd userApprovedRelays cryptoArgs + _ -> pure () + + processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv)) + processFileInvitation fInv_ mc createRcvFT = forM fInv_ $ \fInv' -> do + ChatConfig {fileChunkSize} <- asks config + let fInv@FileInvitation {fileName, fileSize} = mkValidFileInvitation fInv' + inline <- receiveInlineMode fInv (Just mc) fileChunkSize + ft@RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFT db fInv inline fileChunkSize + let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP + (filePath, fileStatus, ft') <- case inline of + Just IFMSent -> do + encrypt <- chatReadVar encryptLocalFiles + ft' <- (if encrypt then setFileToEncrypt else pure) ft + fPath <- getRcvFilePath fileId Nothing fileName True + withStore' $ \db -> startRcvInlineFT db user ft' fPath inline + pure (Just fPath, CIFSRcvAccepted, ft') + _ -> pure (Nothing, CIFSRcvInvitation, ft) + let RcvFileTransfer {cryptoArgs} = ft' + fileSource = (`CryptoFile` cryptoArgs) <$> filePath + pure (ft', CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol}) + + mkValidFileInvitation :: FileInvitation -> FileInvitation + mkValidFileInvitation fInv@FileInvitation {fileName} = fInv {fileName = FP.makeValid $ FP.takeFileName fileName} + + messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> CM () + messageUpdate ct@Contact {contactId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do + 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). + -- Chat item and update message which created it will have different sharedMsgId in this case... + let timed_ = rcvContactCITimed ct ttl + ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs content Nothing timed_ live + ci' <- withStore' $ \db -> do + createChatItemVersion db (chatItemId' ci) brokerTs mc + updateDirectChatItem' db user contactId ci content True live Nothing Nothing + toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci') + where + brokerTs = metaBrokerTs msgMeta + content = CIRcvMsgContent mc + live = fromMaybe False live_ + updateRcvChatItem = do + cci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId + case cci of + CChatItem SMDRcv ci@ChatItem {meta = CIMeta {itemForwarded, itemLive}, content = CIRcvMsgContent oldMC} + | isNothing itemForwarded -> do + let changed = mc /= oldMC + if changed || fromMaybe False itemLive + then do + ci' <- withStore' $ \db -> do + when changed $ + addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc) + reactions <- getDirectCIReactions db ct sharedMsgId + let edited = itemLive /= Just True + updateDirectChatItem' db user contactId ci {reactions} content edited live Nothing $ Just msgId + toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci') + startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci' + else toView $ CRChatItemNotChanged user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) + _ -> messageError "x.msg.update: contact attempted invalid message update" + + messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> CM () + messageDelete ct@Contact {contactId} sharedMsgId _rcvMessage msgMeta = do + deleteRcvChatItem `catchCINotFound` (toView . CRChatItemDeletedNotFound user ct) + where + brokerTs = metaBrokerTs msgMeta + deleteRcvChatItem = do + cci@(CChatItem msgDir ci) <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId + case msgDir of + SMDRcv + | rcvItemDeletable ci brokerTs -> + if featureAllowed SCFFullDelete forContact ct + then deleteDirectCIs user ct [cci] False False >>= toView + else markDirectCIsDeleted user ct [cci] False brokerTs >>= toView + | otherwise -> messageError "x.msg.del: contact attempted invalid message delete" + SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete" + + rcvItemDeletable :: ChatItem c d -> UTCTime -> Bool + rcvItemDeletable ChatItem {meta = CIMeta {itemTs, itemDeleted}} brokerTs = + -- 78 hours margin to account for possible sending delay + diffUTCTime brokerTs itemTs < (78 * 3600) && isNothing itemDeleted + + directMsgReaction :: Contact -> SharedMsgId -> MsgReaction -> Bool -> RcvMessage -> MsgMeta -> CM () + directMsgReaction ct sharedMsgId reaction add RcvMessage {msgId} MsgMeta {broker = (_, brokerTs)} = do + when (featureAllowed SCFReactions forContact ct) $ do + rs <- withStore' $ \db -> getDirectReactions db ct sharedMsgId False + when (reactionAllowed add reaction rs) $ do + updateChatItemReaction `catchCINotFound` \_ -> + withStore' $ \db -> setDirectReaction db ct sharedMsgId False reaction add msgId brokerTs + where + updateChatItemReaction = do + cr_ <- withStore $ \db -> do + CChatItem md ci <- getDirectChatItemBySharedMsgId db user (contactId' ct) sharedMsgId + if ciReactionAllowed ci + then liftIO $ do + setDirectReaction db ct sharedMsgId False reaction add msgId brokerTs + reactions <- getDirectCIReactions db ct sharedMsgId + let ci' = CChatItem md ci {reactions} + r = ACIReaction SCTDirect SMDRcv (DirectChat ct) $ CIReaction CIDirectRcv ci' brokerTs reaction + pure $ Just $ CRChatItemReaction user add r + else pure Nothing + mapM_ toView cr_ + + groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM () + groupMsgReaction g@GroupInfo {groupId} m sharedMsgId itemMemberId reaction add RcvMessage {msgId} brokerTs = do + when (groupFeatureAllowed SGFReactions g) $ do + rs <- withStore' $ \db -> getGroupReactions db g m itemMemberId sharedMsgId False + when (reactionAllowed add reaction rs) $ do + updateChatItemReaction `catchCINotFound` \_ -> + withStore' $ \db -> setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs + where + updateChatItemReaction = do + cr_ <- withStore $ \db -> do + CChatItem md ci <- getGroupMemberCIBySharedMsgId db user groupId itemMemberId sharedMsgId + if ciReactionAllowed ci + then liftIO $ do + setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs + reactions <- getGroupCIReactions db g itemMemberId sharedMsgId + let ci' = CChatItem md ci {reactions} + r = ACIReaction SCTGroup SMDRcv (GroupChat g) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction + pure $ Just $ CRChatItemReaction user add r + else pure Nothing + mapM_ toView cr_ + + reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool + reactionAllowed add reaction rs = (reaction `elem` rs) /= add && not (add && length rs >= maxMsgReactions) + + catchCINotFound :: CM a -> (SharedMsgId -> CM a) -> CM a + catchCINotFound f handle = + f `catchChatError` \case + ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId + e -> throwError e + + newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM () + newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded + | blockedByAdmin m = createBlockedByAdmin + | otherwise = case prohibitedGroupContent gInfo m content fInv_ of + Just f -> rejected f + Nothing -> + withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case + Just ciModeration -> do + applyModeration ciModeration + withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_ + Nothing -> createContentItem + where + rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False + timed' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo itemTTL + live' = fromMaybe False live_ + ExtMsgContent content fInv_ itemTTL live_ = mcExtMsgContent mc + createBlockedByAdmin + | groupFeatureAllowed SGFFullDelete gInfo = do + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvBlocked Nothing timed' False + ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo ci brokerTs + groupMsgToView gInfo ci' + | otherwise = do + file_ <- processFileInv + ci <- createNonLive file_ + ci' <- withStore' $ \db -> markGroupCIBlockedByAdmin db user gInfo ci + groupMsgToView gInfo ci' + applyModeration CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt} + | moderatorRole < GRAdmin || moderatorRole < memberRole = + createContentItem + | groupFeatureAllowed SGFFullDelete gInfo = do + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvModerated Nothing timed' False + ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt + groupMsgToView gInfo ci' + | otherwise = do + file_ <- processFileInv + ci <- createNonLive file_ + toView =<< markGroupCIsDeleted user gInfo [CChatItem SMDRcv ci] False (Just moderator) moderatedAt + createNonLive file_ = + saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed' False + createContentItem = do + file_ <- processFileInv + newChatItem (CIRcvMsgContent content) (snd <$> file_) timed' live' + when (showMessages $ memberSettings m) $ autoAcceptFile file_ + processFileInv = + processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m + newChatItem ciContent ciFile_ timed_ live = do + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs 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 ci' {reactions} + + groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM () + groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} brokerTs ttl_ live_ + | prohibitedSimplexLinks gInfo m mc = + messageWarning $ "x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks + | otherwise = do + 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). + -- Chat item and update message which created it will have different sharedMsgId in this case... + let timed_ = rcvGroupCITimed gInfo ttl_ + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs content Nothing timed_ live + ci' <- withStore' $ \db -> do + createChatItemVersion db (chatItemId' ci) brokerTs mc + ci' <- updateGroupChatItem db user groupId ci content True live Nothing + blockedMember m ci' $ markGroupChatItemBlocked db user gInfo ci' + toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci') + where + content = CIRcvMsgContent mc + live = fromMaybe False live_ + updateRcvChatItem = do + cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId + case cci of + CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} -> + if sameMemberId memberId m' + then do + let changed = mc /= oldMC + if changed || fromMaybe False itemLive + then do + ci' <- withStore' $ \db -> do + when changed $ + addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc) + reactions <- getGroupCIReactions db gInfo memberId sharedMsgId + let edited = itemLive /= Just True + updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId + toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci') + 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" + _ -> messageError "x.msg.update: group member attempted invalid message update" + + groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> UTCTime -> CM () + groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} brokerTs = do + let msgMemberId = fromMaybe memberId sndMemberId_ + withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case + Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of + CIGroupRcv mem -> case sndMemberId_ of + -- regular deletion + Nothing + | sameMemberId memberId mem && msgMemberId == memberId && rcvItemDeletable ci brokerTs -> + delete cci Nothing >>= toView + | otherwise -> + messageError "x.msg.del: member attempted invalid message delete" + -- moderation (not limited by time) + Just _ + | sameMemberId memberId mem && msgMemberId == memberId -> + delete cci (Just m) >>= toView + | otherwise -> + moderate mem cci + CIGroupSnd -> moderate membership cci + Left e + | msgMemberId == memberId -> messageError $ "x.msg.del: message not found, " <> tshow e + | 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 + moderate :: GroupMember -> CChatItem 'CTGroup -> CM () + moderate mem cci = case sndMemberId_ of + Just sndMemberId + | sameMemberId sndMemberId mem -> checkRole mem $ delete cci (Just m) >>= toView + | otherwise -> messageError "x.msg.del: message of another member with incorrect memberId" + _ -> messageError "x.msg.del: message of another member without memberId" + checkRole GroupMember {memberRole} a + | senderRole < GRAdmin || senderRole < memberRole = + messageError "x.msg.del: message of another member with insufficient member permissions" + | otherwise = a + delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM ChatResponse + delete cci byGroupMember + | groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCIs user gInfo [cci] False False byGroupMember brokerTs + | otherwise = markGroupCIsDeleted user gInfo [cci] False byGroupMember brokerTs + + -- TODO remove once XFile is discontinued + processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> CM () + processFileInvitation' ct fInv' msg@RcvMessage {sharedMsgId_} msgMeta = do + ChatConfig {fileChunkSize} <- asks config + let fInv@FileInvitation {fileName, fileSize} = mkValidFileInvitation fInv' + inline <- receiveInlineMode fInv Nothing fileChunkSize + RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct 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 (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] + where + brokerTs = metaBrokerTs msgMeta + + -- TODO remove once XFile is discontinued + processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> UTCTime -> CM () + processGroupFileInvitation' gInfo m fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} brokerTs = 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_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False + ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci + groupMsgToView gInfo ci' + + 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 -> CM (Maybe InlineFileMode) + receiveInlineMode FileInvitation {fileSize, fileInline, fileDescr} mc_ chSize = case (fileInline, fileDescr) of + (Just mode, Nothing) -> do + InlineFilesConfig {receiveChunks, receiveInstant} <- asks $ inlineFiles . config + pure $ if fileSize <= receiveChunks * chSize then inline' receiveInstant else Nothing + where + inline' receiveInstant = if mode == IFMOffer || (receiveInstant && maybe False isVoice mc_) then fileInline else Nothing + _ -> pure Nothing + + xFileCancel :: Contact -> SharedMsgId -> CM () + xFileCancel Contact {contactId} sharedMsgId = do + fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId + ft <- withStore (\db -> getRcvFileTransfer db user fileId) + unless (rcvFileCompleteOrCancelled ft) $ do + cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) + ci <- withStore $ \db -> getChatItemByFileId db vr user fileId + toView $ CRRcvFileSndCancelled user ci ft + + xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM () + xFileAcptInv ct sharedMsgId fileConnReq_ fName = do + fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId + (AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId + assertSMPAcceptNotProhibited ci + ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId) + -- [async agent commands] no continuation needed, but command should be asynchronous for stability + if fName == fileName + then unless cancelled $ case fileConnReq_ of + -- receiving via a separate connection + Just fileConnReq -> do + subMode <- chatReadVar subscriptionMode + dm <- encodeConnInfo XOk + connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode + withStore' $ \db -> createSndDirectFTConnection db vr user fileId connIds subMode + -- receiving inline + _ -> do + event <- withStore $ \db -> do + ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1 + sft <- createSndDirectInlineFT db ct ft + pure $ CRSndFileStart user ci' sft + toView event + ifM + (allowSendInline fileSize fileInline) + (sendDirectFileInline user ct ft sharedMsgId) + (messageError "x.file.acpt.inv: fileSize is bigger than allowed to send inline") + else messageError "x.file.acpt.inv: fileName is different from expected" + + assertSMPAcceptNotProhibited :: ChatItem c d -> CM () + assertSMPAcceptNotProhibited ChatItem {file = Just CIFile {fileId, fileProtocol}, content} + | fileProtocol == FPXFTP && not (imageOrVoice content) = throwChatError $ CEFallbackToSMPProhibited fileId + | otherwise = pure () + where + imageOrVoice :: CIContent d -> Bool + imageOrVoice (CISndMsgContent (MCImage _ _)) = True + imageOrVoice (CISndMsgContent (MCVoice _ _)) = True + imageOrVoice _ = False + assertSMPAcceptNotProhibited _ = pure () + + checkSndInlineFTComplete :: Connection -> AgentMsgId -> CM () + checkSndInlineFTComplete conn agentMsgId = do + sft_ <- withStore' $ \db -> getSndFTViaMsgDelivery db user conn agentMsgId + forM_ sft_ $ \sft@SndFileTransfer {fileId} -> do + ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do + liftIO $ updateSndFileStatus db sft FSComplete + liftIO $ deleteSndFileChunks db sft + updateDirectCIFileStatus db vr user fileId CIFSSndComplete + case file of + Just CIFile {fileProtocol = FPXFTP} -> do + ft <- withStore $ \db -> getFileTransferMeta db user fileId + toView $ CRSndFileCompleteXFTP user ci ft + _ -> toView $ CRSndFileComplete user ci sft + + allowSendInline :: Integer -> Maybe InlineFileMode -> CM Bool + allowSendInline fileSize = \case + Just IFMOffer -> do + ChatConfig {fileChunkSize, inlineFiles} <- asks config + pure $ fileSize <= fileChunkSize * offerChunks inlineFiles + _ -> pure False + + bFileChunk :: Contact -> SharedMsgId -> FileChunk -> MsgMeta -> CM () + bFileChunk ct sharedMsgId chunk meta = do + ft <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId >>= getRcvFileTransfer db user + receiveInlineChunk ft chunk meta + + bFileChunkGroup :: GroupInfo -> SharedMsgId -> FileChunk -> MsgMeta -> CM () + bFileChunkGroup GroupInfo {groupId} sharedMsgId chunk meta = do + ft <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId >>= getRcvFileTransfer db user + receiveInlineChunk ft chunk meta + + receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> CM () + receiveInlineChunk RcvFileTransfer {fileId, fileStatus = RFSNew} FileChunk {chunkNo} _ + | chunkNo == 1 = throwChatError $ CEInlineFileProhibited fileId + | otherwise = pure () + receiveInlineChunk ft@RcvFileTransfer {fileId} chunk meta = do + case chunk of + FileChunk {chunkNo} -> when (chunkNo == 1) $ startReceivingFile user fileId + _ -> pure () + receiveFileChunk ft Nothing meta chunk + + xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM () + xFileCancelGroup GroupInfo {groupId} GroupMember {groupMemberId, memberId} sharedMsgId = do + fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId + CChatItem msgDir ChatItem {chatDir} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId + case (msgDir, chatDir) of + (SMDRcv, CIGroupRcv m) -> do + if sameMemberId memberId m + then do + ft <- withStore (\db -> getRcvFileTransfer db user fileId) + unless (rcvFileCompleteOrCancelled ft) $ do + cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) + ci <- withStore $ \db -> getChatItemByFileId db vr user fileId + toView $ CRRcvFileSndCancelled user ci ft + else messageError "x.file.cancel: group member attempted to cancel file of another member" -- shouldn't happen now that query includes group member id + (SMDSnd, _) -> messageError "x.file.cancel: group member attempted invalid file cancel" + + xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM () + xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do + fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId + (AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId + assertSMPAcceptNotProhibited ci + -- TODO check that it's not already accepted + ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId) + if fName == fileName + then unless cancelled $ case (fileConnReq_, activeConn) of + (Just fileConnReq, _) -> do + subMode <- chatReadVar subscriptionMode + -- receiving via a separate connection + -- [async agent commands] no continuation needed, but command should be asynchronous for stability + dm <- encodeConnInfo XOk + connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode + withStore' $ \db -> createSndGroupFileTransferConnection db vr user fileId connIds m subMode + (_, Just conn) -> do + -- receiving inline + event <- withStore $ \db -> do + ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1 + sft <- liftIO $ createSndGroupInlineFT db m conn ft + pure $ CRSndFileStart user ci' sft + toView event + ifM + (allowSendInline fileSize fileInline) + (sendMemberFileInline m conn ft sharedMsgId) + (messageError "x.file.acpt.inv: fileSize is bigger than allowed to send inline") + _ -> messageError "x.file.acpt.inv: member connection is not active" + else messageError "x.file.acpt.inv: fileName is different from expected" + + groupMsgToView :: forall d. MsgDirectionI d => GroupInfo -> ChatItem 'CTGroup d -> CM () + groupMsgToView gInfo ci = + toView $ CRNewChatItems user [AChatItem SCTGroup (msgDirection @d) (GroupChat gInfo) ci] + + processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> CM () + processGroupInvitation ct inv msg msgMeta = do + let Contact {localDisplayName = c, activeConn} = ct + GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), invitedMember = (MemberIdRole memId memRole), connRequest, groupLinkId} = inv + forM_ activeConn $ \Connection {connId, connChatVersion, peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'} -> do + when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c) + when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId + -- [incognito] if direct connection with host is incognito, create membership using the same incognito profile + (gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId + let GroupMember {groupMemberId, memberId = membershipMemId} = membership + if sameGroupLinkId groupLinkId groupLinkId' + then do + subMode <- chatReadVar subscriptionMode + dm <- encodeConnInfo $ XGrpAcpt membershipMemId + connIds <- joinAgentConnectionAsync user True connRequest dm subMode + withStore' $ \db -> do + setViaGroupLinkHash db groupId connId + createMemberConnectionAsync db user hostId connIds connChatVersion peerChatVRange subMode + updateGroupMemberStatusById db userId hostId GSMemAccepted + updateGroupMemberStatus db userId membership GSMemAccepted + toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct) + else do + let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole + ci <- saveRcvChatItem user (CDDirectRcv ct) msg brokerTs content + withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] + toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole} + where + brokerTs = metaBrokerTs msgMeta + sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool + sameGroupLinkId (Just gli) (Just gli') = gli == gli' + sameGroupLinkId _ _ = False + + checkIntegrityCreateItem :: forall c. ChatTypeI c => ChatDirection c 'MDRcv -> MsgMeta -> CM () + checkIntegrityCreateItem cd MsgMeta {integrity, broker = (_, brokerTs)} = case integrity of + MsgOk -> pure () + MsgError e -> createInternalChatItem user cd (CIRcvIntegrityError e) (Just brokerTs) + + xInfo :: Contact -> Profile -> CM () + xInfo c p' = void $ processContactProfileUpdate c p' True + + xDirectDel :: Contact -> RcvMessage -> MsgMeta -> CM () + xDirectDel c msg msgMeta = + if directOrUsed c + then do + ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted + contactConns <- withStore' $ \db -> getContactConnections db vr userId ct' + deleteAgentConnectionsAsync user $ map aConnId contactConns + forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted + activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted} + let ct'' = ct' {activeConn = activeConn'} :: Contact + ci <- saveRcvChatItem user (CDDirectRcv ct'') msg brokerTs (CIRcvDirectEvent RDEContactDeleted) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct'') ci] + toView $ CRContactDeletedByContact user ct'' + else do + contactConns <- withStore' $ \db -> getContactConnections db vr userId c + deleteAgentConnectionsAsync user $ map aConnId contactConns + withStore $ \db -> deleteContact db user c + where + brokerTs = metaBrokerTs msgMeta + + processContactProfileUpdate :: Contact -> Profile -> Bool -> CM Contact + processContactProfileUpdate c@Contact {profile = lp} p' createItems + | p /= p' = do + c' <- withStore $ \db -> + if userTTL == rcvTTL + then updateContactProfile db user c p' + else do + c' <- liftIO $ updateContactUserPreferences db user c ctUserPrefs' + updateContactProfile db user c' p' + when (directOrUsed c' && createItems) $ do + createProfileUpdatedItem c' + lift $ createRcvFeatureItems user c c' + toView $ CRContactUpdated user c c' + pure c' + | otherwise = + pure c + where + p = fromLocalProfile lp + Contact {userPreferences = ctUserPrefs@Preferences {timedMessages = ctUserTMPref}} = c + userTTL = prefParam $ getPreference SCFTimedMessages ctUserPrefs + Profile {preferences = rcvPrefs_} = p' + rcvTTL = prefParam $ getPreference SCFTimedMessages rcvPrefs_ + ctUserPrefs' = + let userDefault = getPreference SCFTimedMessages (fullPreferences user) + userDefaultTTL = prefParam userDefault + ctUserTMPref' = case ctUserTMPref of + Just userTM -> Just (userTM :: TimedMessagesPreference) {ttl = rcvTTL} + _ + | rcvTTL /= userDefaultTTL -> Just (userDefault :: TimedMessagesPreference) {ttl = rcvTTL} + | otherwise -> Nothing + in setPreference_ SCFTimedMessages ctUserTMPref' ctUserPrefs + createProfileUpdatedItem c' = + when visibleProfileUpdated $ do + let ciContent = CIRcvDirectEvent $ RDEProfileUpdated p p' + createInternalChatItem user (CDDirectRcv c') ciContent Nothing + where + visibleProfileUpdated = + n' /= n || fn' /= fn || i' /= i || cl' /= cl + Profile {displayName = n, fullName = fn, image = i, contactLink = cl} = p + Profile {displayName = n', fullName = fn', image = i', contactLink = cl'} = p' + + xInfoMember :: GroupInfo -> GroupMember -> Profile -> UTCTime -> CM () + xInfoMember gInfo m p' brokerTs = void $ processMemberProfileUpdate gInfo m p' True (Just brokerTs) + + xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM () + xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do + xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId + if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived + then do + m' <- processMemberProfileUpdate gInfo m p' False Nothing + withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True + let connectedIncognito = memberIncognito membership + probeMatchingMemberContact m' connectedIncognito + else messageError "x.grp.link.mem error: invalid group link host profile update" + + processMemberProfileUpdate :: GroupInfo -> GroupMember -> Profile -> Bool -> Maybe UTCTime -> CM GroupMember + processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} p' createItems itemTs_ + | redactedMemberProfile (fromLocalProfile p) /= redactedMemberProfile p' = do + updateBusinessChatProfile gInfo + case memberContactId of + Nothing -> do + m' <- withStore $ \db -> updateMemberProfile db user m p' + createProfileUpdatedItem m' + toView $ CRGroupMemberUpdated user gInfo m m' + pure m' + Just mContactId -> do + mCt <- withStore $ \db -> getContact db vr user mContactId + if canUpdateProfile mCt + then do + (m', ct') <- withStore $ \db -> updateContactMemberProfile db user m mCt p' + createProfileUpdatedItem m' + toView $ CRGroupMemberUpdated user gInfo m m' + toView $ CRContactUpdated user mCt ct' + pure m' + else pure m + where + canUpdateProfile ct + | not (contactActive ct) = True + | otherwise = case contactConn ct of + Nothing -> True + Just conn -> not (connReady conn) || (authErrCounter conn >= 1) + | otherwise = + pure m + where + updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of + Just bc | isMainBusinessMember bc m -> do + g' <- withStore $ \db -> updateGroupProfileFromMember db user g p' + toView $ CRGroupUpdated user g g' (Just m) + _ -> pure () + isMainBusinessMember BusinessChatInfo {chatType, businessId, customerId} GroupMember {memberId} = case chatType of + BCBusiness -> businessId == memberId + BCCustomer -> customerId == memberId + createProfileUpdatedItem m' = + when createItems $ do + let ciContent = CIRcvGroupEvent $ RGEMemberProfileUpdated (fromLocalProfile p) p' + createInternalChatItem user (CDGroupRcv gInfo m') ciContent itemTs_ + + createFeatureEnabledItems :: Contact -> CM () + createFeatureEnabledItems ct@Contact {mergedPreferences} = + forM_ allChatFeatures $ \(ACF f) -> do + let state = featureState $ getContactUserPreference f mergedPreferences + createInternalChatItem user (CDDirectRcv ct) (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing + + xInfoProbe :: ContactOrMember -> Probe -> CM () + xInfoProbe cgm2 probe = do + contactMerge <- readTVarIO =<< asks contactMergeEnabled + -- [incognito] unless connected incognito + when (contactMerge && not (contactOrMemberIncognito cgm2)) $ do + cgm1s <- withStore' $ \db -> matchReceivedProbe db vr user cgm2 probe + let cgm1s' = filter (not . contactOrMemberIncognito) cgm1s + probeMatches cgm1s' cgm2 + where + probeMatches :: [ContactOrMember] -> ContactOrMember -> CM () + probeMatches [] _ = pure () + probeMatches (cgm1' : cgm1s') cgm2' = do + cgm2''_ <- probeMatch cgm1' cgm2' probe `catchChatError` \_ -> pure (Just cgm2') + let cgm2'' = fromMaybe cgm2' cgm2''_ + probeMatches cgm1s' cgm2'' + + xInfoProbeCheck :: ContactOrMember -> ProbeHash -> CM () + xInfoProbeCheck cgm1 probeHash = do + contactMerge <- readTVarIO =<< asks contactMergeEnabled + -- [incognito] unless connected incognito + when (contactMerge && not (contactOrMemberIncognito cgm1)) $ do + cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db vr user cgm1 probeHash + forM_ cgm2Probe_ $ \(cgm2, probe) -> + unless (contactOrMemberIncognito cgm2) . void $ + probeMatch cgm1 cgm2 probe + + probeMatch :: ContactOrMember -> ContactOrMember -> Probe -> CM (Maybe ContactOrMember) + probeMatch cgm1 cgm2 probe = + case cgm1 of + COMContact c1@Contact {contactId = cId1, profile = p1} -> + case cgm2 of + COMContact c2@Contact {contactId = cId2, profile = p2} + | cId1 /= cId2 && profilesMatch p1 p2 -> do + void . sendDirectContactMessage user c1 $ XInfoProbeOk probe + COMContact <$$> mergeContacts c1 c2 + | otherwise -> messageWarning "probeMatch ignored: profiles don't match or same contact id" >> pure Nothing + COMGroupMember m2@GroupMember {memberProfile = p2, memberContactId} + | isNothing memberContactId && profilesMatch p1 p2 -> do + void . sendDirectContactMessage user c1 $ XInfoProbeOk probe + COMContact <$$> associateMemberAndContact c1 m2 + | otherwise -> messageWarning "probeMatch ignored: profiles don't match or member already has contact" >> pure Nothing + COMGroupMember GroupMember {activeConn = Nothing} -> pure Nothing + COMGroupMember m1@GroupMember {groupId, memberProfile = p1, memberContactId, activeConn = Just conn} -> + case cgm2 of + COMContact c2@Contact {profile = p2} + | memberCurrent m1 && isNothing memberContactId && profilesMatch p1 p2 -> do + void $ sendDirectMemberMessage conn (XInfoProbeOk probe) groupId + COMContact <$$> associateMemberAndContact c2 m1 + | otherwise -> messageWarning "probeMatch ignored: profiles don't match or member already has contact or member not current" >> pure Nothing + COMGroupMember _ -> messageWarning "probeMatch ignored: members are not matched with members" >> pure Nothing + + xInfoProbeOk :: ContactOrMember -> Probe -> CM () + xInfoProbeOk cgm1 probe = do + cgm2 <- withStore' $ \db -> matchSentProbe db vr user cgm1 probe + case cgm1 of + COMContact c1@Contact {contactId = cId1} -> + case cgm2 of + Just (COMContact c2@Contact {contactId = cId2}) + | cId1 /= cId2 -> void $ mergeContacts c1 c2 + | otherwise -> messageWarning "xInfoProbeOk ignored: same contact id" + Just (COMGroupMember m2@GroupMember {memberContactId}) + | isNothing memberContactId -> void $ associateMemberAndContact c1 m2 + | otherwise -> messageWarning "xInfoProbeOk ignored: member already has contact" + _ -> pure () + COMGroupMember m1@GroupMember {memberContactId} -> + case cgm2 of + Just (COMContact c2) + | isNothing memberContactId -> void $ associateMemberAndContact c2 m1 + | otherwise -> messageWarning "xInfoProbeOk ignored: member already has contact" + Just (COMGroupMember _) -> messageWarning "xInfoProbeOk ignored: members are not matched with members" + _ -> pure () + + -- to party accepting call + xCallInv :: Contact -> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> CM () + xCallInv ct@Contact {contactId} callId CallInvitation {callType, callDhPubKey} msg@RcvMessage {sharedMsgId_} msgMeta = do + if featureAllowed SCFCalls forContact ct + then do + g <- asks random + dhKeyPair <- atomically $ if encryptedCall callType then Just <$> C.generateKeyPair g else pure Nothing + ci <- saveCallItem CISCallPending + callUUID <- UUID.toText <$> liftIO V4.nextRandom + let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> (snd <$> dhKeyPair)) + callState = CallInvitationReceived {peerCallType = callType, localDhPubKey = fst <$> dhKeyPair, sharedKey} + call' = Call {contactId, callId, callUUID, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci} + calls <- asks currentCalls + -- theoretically, the new call invitation for the current contact can mark the in-progress call as ended + -- (and replace it in ChatController) + -- practically, this should not happen + withStore' $ \db -> createCall db user call' $ chatItemTs' ci + call_ <- atomically (TM.lookupInsert contactId call' calls) + forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing + toView $ CRCallInvitation RcvCallInvitation {user, contact = ct, callType, sharedKey, callUUID, callTs = chatItemTs' ci} + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] + else featureRejected CFCalls + where + brokerTs = metaBrokerTs msgMeta + saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0) + featureRejected f = do + ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvChatFeatureRejected f) Nothing Nothing False + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] + + -- to party initiating call + xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> CM () + xCallOffer ct callId CallOffer {callType, rtcSession, callDhPubKey} msg = do + msgCurrentCall ct callId "x.call.offer" msg $ + \call -> case callState call of + CallInvitationSent {localCallType, localDhPrivKey} -> do + let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> localDhPrivKey) + callState' = CallOfferReceived {localCallType, peerCallType = callType, peerCallSession = rtcSession, sharedKey} + askConfirmation = encryptedCall localCallType && not (encryptedCall callType) + toView CRCallOffer {user, contact = ct, callType, offer = rtcSession, sharedKey, askConfirmation} + pure (Just call {callState = callState'}, Just . ACIContent SMDSnd $ CISndCall CISCallAccepted 0) + _ -> do + msgCallStateError "x.call.offer" call + pure (Just call, Nothing) + + -- to party accepting call + xCallAnswer :: Contact -> CallId -> CallAnswer -> RcvMessage -> CM () + xCallAnswer ct callId CallAnswer {rtcSession} msg = do + msgCurrentCall ct callId "x.call.answer" msg $ + \call -> case callState call of + CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey} -> do + let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession = rtcSession, sharedKey} + toView $ CRCallAnswer user ct rtcSession + pure (Just call {callState = callState'}, Just . ACIContent SMDRcv $ CIRcvCall CISCallNegotiated 0) + _ -> do + msgCallStateError "x.call.answer" call + pure (Just call, Nothing) + + -- to any call party + xCallExtra :: Contact -> CallId -> CallExtraInfo -> RcvMessage -> CM () + xCallExtra ct callId CallExtraInfo {rtcExtraInfo} msg = do + msgCurrentCall ct callId "x.call.extra" msg $ + \call -> case callState call of + CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey} -> do + -- TODO update the list of ice servers in peerCallSession + let callState' = CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey} + toView $ CRCallExtraInfo user ct rtcExtraInfo + pure (Just call {callState = callState'}, Nothing) + CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} -> do + -- TODO update the list of ice servers in peerCallSession + let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} + toView $ CRCallExtraInfo user ct rtcExtraInfo + pure (Just call {callState = callState'}, Nothing) + _ -> do + msgCallStateError "x.call.extra" call + pure (Just call, Nothing) + + -- to any call party + xCallEnd :: Contact -> CallId -> RcvMessage -> CM () + xCallEnd ct callId msg = + msgCurrentCall ct callId "x.call.end" msg $ \Call {chatItemId} -> do + toView $ CRCallEnded user ct + (Nothing,) <$> callStatusItemContent user ct chatItemId WCSDisconnected + + msgCurrentCall :: Contact -> CallId -> Text -> RcvMessage -> (Call -> CM (Maybe Call, Maybe ACIContent)) -> CM () + msgCurrentCall ct@Contact {contactId = ctId'} callId' eventName RcvMessage {msgId} action = do + calls <- asks currentCalls + atomically (TM.lookup ctId' calls) >>= \case + Nothing -> messageError $ eventName <> ": no current call" + Just call@Call {contactId, callId, chatItemId} + | contactId /= ctId' || callId /= callId' -> messageError $ eventName <> ": wrong contact or callId" + | otherwise -> do + (call_, aciContent_) <- action call + case call_ of + Just call' -> do + unless (isRcvInvitation call') $ withStore' $ \db -> deleteCalls db user ctId' + atomically $ TM.insert ctId' call' calls + _ -> do + withStore' $ \db -> deleteCalls db user ctId' + atomically $ TM.delete ctId' calls + forM_ aciContent_ $ \aciContent -> do + timed_ <- callTimed ct aciContent + updateDirectChatItemView user ct chatItemId aciContent False False timed_ $ Just msgId + forM_ (timed_ >>= timedDeleteAt') $ + startProximateTimedItemThread user (ChatRef CTDirect ctId', chatItemId) + + msgCallStateError :: Text -> Call -> CM () + msgCallStateError eventName Call {callState} = + messageError $ eventName <> ": wrong call state " <> T.pack (show $ callStateTag callState) + + mergeContacts :: Contact -> Contact -> CM (Maybe Contact) + mergeContacts c1 c2 = do + let Contact {localDisplayName = cLDN1, profile = LocalProfile {displayName}} = c1 + Contact {localDisplayName = cLDN2} = c2 + case (suffixOrd displayName cLDN1, suffixOrd displayName cLDN2) of + (Just cOrd1, Just cOrd2) + | cOrd1 < cOrd2 -> merge c1 c2 + | cOrd2 < cOrd1 -> merge c2 c1 + | otherwise -> pure Nothing + _ -> pure Nothing + where + merge c1' c2' = do + c2'' <- withStore $ \db -> mergeContactRecords db vr user c1' c2' + toView $ CRContactsMerged user c1' c2' c2'' + when (directOrUsed c2'') $ showSecurityCodeChanged c2'' + pure $ Just c2'' + where + showSecurityCodeChanged mergedCt = do + let sc1_ = contactSecurityCode c1' + sc2_ = contactSecurityCode c2' + scMerged_ = contactSecurityCode mergedCt + case (sc1_, sc2_) of + (Just sc1, Nothing) + | scMerged_ /= Just sc1 -> securityCodeChanged mergedCt + | otherwise -> pure () + (Nothing, Just sc2) + | scMerged_ /= Just sc2 -> securityCodeChanged mergedCt + | otherwise -> pure () + _ -> pure () + + associateMemberAndContact :: Contact -> GroupMember -> CM (Maybe Contact) + associateMemberAndContact c m = do + let Contact {localDisplayName = cLDN, profile = LocalProfile {displayName}} = c + GroupMember {localDisplayName = mLDN} = m + case (suffixOrd displayName cLDN, suffixOrd displayName mLDN) of + (Just cOrd, Just mOrd) + | cOrd < mOrd -> Just <$> associateMemberWithContact c m + | mOrd < cOrd -> Just <$> associateContactWithMember m c + | otherwise -> pure Nothing + _ -> pure Nothing + + suffixOrd :: ContactName -> ContactName -> Maybe Int + suffixOrd displayName localDisplayName + | localDisplayName == displayName = Just 0 + | otherwise = case T.stripPrefix (displayName <> "_") localDisplayName of + Just suffix -> readMaybe $ T.unpack suffix + Nothing -> Nothing + + associateMemberWithContact :: Contact -> GroupMember -> CM Contact + associateMemberWithContact c1 m2@GroupMember {groupId} = do + withStore' $ \db -> associateMemberWithContactRecord db user c1 m2 + g <- withStore $ \db -> getGroupInfo db vr user groupId + toView $ CRContactAndMemberAssociated user c1 g m2 c1 + pure c1 + + associateContactWithMember :: GroupMember -> Contact -> CM Contact + associateContactWithMember m1@GroupMember {groupId} c2 = do + c2' <- withStore $ \db -> associateContactWithMemberRecord db vr user m1 c2 + g <- withStore $ \db -> getGroupInfo db vr user groupId + toView $ CRContactAndMemberAssociated user c2 g m1 c2' + pure c2' + + saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Bool) + saveConnInfo activeConn connInfo = do + ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo + conn' <- updatePeerChatVRange activeConn chatVRange + case chatMsgEvent of + XInfo p -> do + let contactUsed = connDirect activeConn + ct <- withStore $ \db -> createDirectContact db user conn' p contactUsed + toView $ CRContactConnecting user ct + pure (conn', False) + XGrpLinkInv glInv -> do + (gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db vr user conn' glInv + toView $ CRGroupLinkConnecting user gInfo host + pure (conn', True) + -- TODO show/log error, other events in SMP confirmation + _ -> pure (conn', False) + + xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> RcvMessage -> UTCTime -> CM () + xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _) msg brokerTs = do + checkHostRole m memRole + unless (sameMemberId memId $ membership gInfo) $ + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case + Right unknownMember@GroupMember {memberStatus = GSMemUnknown} -> do + updatedMember <- withStore $ \db -> updateUnknownMemberAnnounced db vr user m unknownMember memInfo + toView $ CRUnknownMemberAnnounced user gInfo m unknownMember updatedMember + memberAnnouncedToView updatedMember + Right _ -> messageError "x.grp.mem.new error: member already exists" + Left _ -> do + newMember <- withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced + memberAnnouncedToView newMember + where + memberAnnouncedToView announcedMember@GroupMember {groupMemberId, memberProfile} = do + let event = RGEMemberAdded groupMemberId (fromLocalProfile memberProfile) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent event) + groupMsgToView gInfo ci + toView $ CRJoinedGroupMemberConnecting user gInfo m announcedMember + + xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM () + xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _) memRestrictions = do + case memberCategory m of + GCHostMember -> + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case + Right _ -> messageError "x.grp.mem.intro ignored: member already exists" + Left _ -> do + when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c) + subMode <- chatReadVar subscriptionMode + -- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second + groupConnIds <- createConn subMode + directConnIds <- case memChatVRange of + Nothing -> Just <$> createConn subMode + Just (ChatVersionRange mcvr) + | maxVersion mcvr >= groupDirectInvVersion -> pure Nothing + | otherwise -> Just <$> createConn subMode + let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo + chatV = maybe (minVersion vr) (\peerVR -> vr `peerConnChatVersion` fromChatVRange peerVR) memChatVRange + void $ withStore $ \db -> createIntroReMember db user gInfo m chatV memInfo memRestrictions groupConnIds directConnIds customUserProfileId subMode + _ -> messageError "x.grp.mem.intro can be only sent by host member" + where + createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation subMode + + sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> CM () + sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do + hostConn <- withStore $ \db -> getConnectionById db vr user hostConnId + let msg = XGrpMemInv memberId IntroInvitation {groupConnReq, directConnReq} + void $ sendDirectMemberMessage hostConn msg groupId + withStore' $ \db -> updateGroupMemberStatusById db userId groupMemberId GSMemIntroInvited + + xGrpMemInv :: GroupInfo -> GroupMember -> MemberId -> IntroInvitation -> CM () + xGrpMemInv gInfo m memId introInv = do + case memberCategory m of + GCInviteeMember -> + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case + Left _ -> messageError "x.grp.mem.inv error: referenced member does not exist" + Right reMember -> do + GroupMemberIntro {introId} <- withStore $ \db -> saveIntroInvitation db reMember m introInv + sendGroupMemberMessage user gInfo reMember (XGrpMemFwd (memberInfo m) introInv) (Just introId) $ + withStore' $ + \db -> updateIntroStatus db introId GMIntroInvForwarded + _ -> messageError "x.grp.mem.inv can be only sent by invitee member" + + xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> CM () + xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do + let GroupMember {memberId = membershipMemId} = membership + checkHostRole m memRole + toMember <- + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case + -- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent + -- the situation when member does not exist is an error + -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that. + -- For now, this branch compensates for the lack of delayed message delivery. + Left _ -> withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced + Right m' -> pure m' + withStore' $ \db -> saveMemberInvitation db toMember introInv + subMode <- chatReadVar subscriptionMode + -- [incognito] send membership incognito profile, create direct connection as incognito + let membershipProfile = redactedMemberProfile $ fromLocalProfile $ memberProfile membership + dm <- encodeConnInfo $ XGrpMemInfo membershipMemId membershipProfile + -- [async agent commands] no continuation needed, but commands should be asynchronous for stability + 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 memChatVRange + chatV = vr `peerConnChatVersion` mcvr + withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode + + xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM () + xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs + | membershipMemId == memId = + let gInfo' = gInfo {membership = membership {memberRole = memRole}} + in changeMemberRole gInfo' membership $ RGEUserRole memRole + | otherwise = + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case + Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole + Left _ -> messageError "x.grp.mem.role with unknown member ID" + where + GroupMember {memberId = membershipMemId} = membership + changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent + | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions" + | otherwise = do + withStore' $ \db -> updateGroupMemberRole db user member memRole + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent) + groupMsgToView gInfo ci + toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole} + + checkHostRole :: GroupMember -> GroupMemberRole -> CM () + checkHostRole GroupMember {memberRole, localDisplayName} memRole = + when (memberRole < GRAdmin || memberRole < memRole) $ throwChatError (CEGroupContactRole localDisplayName) + + xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM () + xGrpMemRestrict + gInfo@GroupInfo {groupId, membership = GroupMember {memberId = membershipMemId}} + m@GroupMember {memberRole = senderRole} + memId + MemberRestrictions {restriction} + msg + brokerTs + | membershipMemId == memId = + -- member shouldn't receive this message about themselves + messageError "x.grp.mem.restrict: admin blocks you" + | otherwise = + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case + Right bm@GroupMember {groupMemberId = bmId, memberRole, memberProfile = bmp} + | senderRole < GRAdmin || senderRole < memberRole -> messageError "x.grp.mem.restrict with insufficient member permissions" + | otherwise -> do + bm' <- setMemberBlocked bmId + toggleNtf user bm' (not blocked) + let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs ciContent + groupMsgToView gInfo ci + toView CRMemberBlockedForAll {user, groupInfo = gInfo, byMember = m, member = bm, blocked} + Left (SEGroupMemberNotFoundByMemberId _) -> do + bm <- createUnknownMember gInfo memId + bm' <- setMemberBlocked $ groupMemberId' bm + toView $ CRUnknownMemberBlocked user gInfo m bm' + Left e -> throwError $ ChatErrorStore e + where + setMemberBlocked bmId = + withStore $ \db -> do + liftIO $ updateGroupMemberBlocked db user groupId bmId restriction + getGroupMember db vr user groupId bmId + blocked = mrsBlocked restriction + + xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM () + xGrpMemCon gInfo sendingMember memId = do + refMember <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo memId + case (memberCategory sendingMember, memberCategory refMember) of + (GCInviteeMember, GCInviteeMember) -> + withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case + Right intro -> inviteeXGrpMemCon intro + Left _ -> + withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case + Right intro -> forwardMemberXGrpMemCon intro + Left _ -> messageWarning "x.grp.mem.con: no introduction" + (GCInviteeMember, _) -> + withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case + Right intro -> inviteeXGrpMemCon intro + Left _ -> messageWarning "x.grp.mem.con: no introduction" + (_, GCInviteeMember) -> + withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case + Right intro -> forwardMemberXGrpMemCon intro + Left _ -> messageWarning "x.grp.mem.con: no introductiosupportn" + -- Note: we can allow XGrpMemCon to all member categories if we decide to support broader group forwarding, + -- deduplication (see saveGroupRcvMsg, saveGroupFwdRcvMsg) already supports sending XGrpMemCon + -- to any forwarding member, not only host/inviting member; + -- database would track all members connections then + -- (currently it's done via group_member_intros for introduced connections only) + _ -> + messageWarning "x.grp.mem.con: neither member is invitee" + where + inviteeXGrpMemCon :: GroupMemberIntro -> CM () + inviteeXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of + GMIntroReConnected -> updateStatus introId GMIntroConnected + GMIntroToConnected -> pure () + GMIntroConnected -> pure () + _ -> updateStatus introId GMIntroToConnected + forwardMemberXGrpMemCon :: GroupMemberIntro -> CM () + forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of + GMIntroToConnected -> updateStatus introId GMIntroConnected + GMIntroReConnected -> pure () + GMIntroConnected -> pure () + _ -> updateStatus introId GMIntroReConnected + updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status + + xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> CM () + xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg brokerTs = do + let GroupMember {memberId = membershipMemId} = membership + if membershipMemId == memId + then checkRole membership $ do + deleteGroupLinkIfExists user gInfo + -- member records are not deleted to keep history + members <- withStore' $ \db -> getGroupMembers db vr user gInfo + deleteMembersConnections user members + withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved + deleteMemberItem RGEUserDeleted + toView $ CRDeletedMemberUser user gInfo {membership = membership {memberStatus = GSMemRemoved}} m + else + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case + Left _ -> messageError "x.grp.mem.del with unknown member ID" + Right member@GroupMember {groupMemberId, memberProfile} -> + checkRole member $ do + -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave + deleteMemberConnection user member + -- undeleted "member connected" chat item will prevent deletion of member record + deleteOrUpdateMemberRecord user member + deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) + toView $ CRDeletedMember user gInfo m member {memberStatus = GSMemRemoved} + where + checkRole GroupMember {memberRole} a + | senderRole < GRAdmin || senderRole < memberRole = + messageError "x.grp.mem.del with insufficient member permissions" + | otherwise = a + deleteMemberItem gEvent = do + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent) + groupMsgToView gInfo ci + + xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () + xGrpLeave gInfo m msg brokerTs = do + deleteMemberConnection user m + -- member record is not deleted to allow creation of "member left" chat item + withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEMemberLeft) + groupMsgToView gInfo ci + toView $ CRLeftMember user gInfo m {memberStatus = GSMemLeft} + + xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () + xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do + when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner + ms <- withStore' $ \db -> do + members <- getGroupMembers db vr user gInfo + updateGroupMemberStatus db userId membership GSMemGroupDeleted + pure members + -- member records are not deleted to keep history + deleteMembersConnections user ms + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEGroupDeleted) + groupMsgToView gInfo ci + toView $ CRGroupDeleted user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m + + xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM () + xGrpInfo g@GroupInfo {groupProfile = p, businessChat} m@GroupMember {memberRole} p' msg brokerTs + | memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" + | otherwise = case businessChat of + Nothing -> unless (p == p') $ do + g' <- withStore $ \db -> updateGroupProfile db user g p' + toView $ CRGroupUpdated user g g' (Just m) + let cd = CDGroupRcv g' m + unless (sameGroupProfileInfo p p') $ do + ci <- saveRcvChatItem user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p') + groupMsgToView g' ci + createGroupFeatureChangedItems user cd CIRcvGroupFeature g g' + Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' + + xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM () + xGrpPrefs g m@GroupMember {memberRole} ps' + | memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions" + | otherwise = updateGroupPrefs_ g m ps' + + updateGroupPrefs_ :: GroupInfo -> GroupMember -> GroupPreferences -> CM () + updateGroupPrefs_ g@GroupInfo {groupProfile = p} m ps' = + unless (groupPreferences p == Just ps') $ do + g' <- withStore' $ \db -> updateGroupPreferences db user g ps' + toView $ CRGroupUpdated user g g' (Just m) + let cd = CDGroupRcv g' m + createGroupFeatureChangedItems user cd CIRcvGroupFeature g g' + + xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> CM () + xGrpDirectInv g m mConn connReq mContent_ msg brokerTs = do + unless (groupFeatureMemberAllowed SGFDirectMessages m g) $ messageError "x.grp.direct.inv: direct messages not allowed" + let GroupMember {memberContactId} = m + subMode <- chatReadVar subscriptionMode + case memberContactId of + Nothing -> createNewContact subMode + Just mContactId -> do + mCt <- withStore $ \db -> getContact db vr user mContactId + let Contact {activeConn, contactGrpInvSent} = mCt + forM_ activeConn $ \Connection {connId} -> + if contactGrpInvSent + then do + ownConnReq <- withStore $ \db -> getConnReqInv db connId + -- in case both members sent x.grp.direct.inv before receiving other's for processing, + -- only the one who received greater connReq joins, the other creates items and waits for confirmation + if strEncode connReq > strEncode ownConnReq + then joinExistingContact subMode mCt + else createItems mCt m + else joinExistingContact subMode mCt + where + joinExistingContact subMode mCt = do + connIds <- joinConn subMode + mCt' <- withStore $ \db -> updateMemberContactInvited db user connIds g mConn mCt subMode + createItems mCt' m + securityCodeChanged mCt' + createNewContact subMode = do + connIds <- joinConn subMode + -- [incognito] reuse membership incognito profile + (mCt', m') <- withStore' $ \db -> createMemberContactInvited db user connIds g m mConn subMode + createItems mCt' m' + joinConn subMode = do + -- [incognito] send membership incognito profile + let p = userProfileToSend user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing False + -- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ) + dm <- encodeConnInfo $ XInfo p + joinAgentConnectionAsync user True connReq dm subMode + createItems mCt' m' = do + createInternalChatItem user (CDGroupRcv g m') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing + toView $ CRNewMemberContactReceivedInv user mCt' g m' + forM_ mContent_ $ \mc -> do + ci <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat mCt') ci] + + securityCodeChanged :: Contact -> CM () + securityCodeChanged ct = do + toView $ CRContactVerificationReset user ct + createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing + + xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> ChatMessage 'Json -> UTCTime -> CM () + xGrpMsgForward gInfo@GroupInfo {groupId} m@GroupMember {memberRole, localDisplayName} memberId msg msgTs = do + when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole localDisplayName) + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case + Right author -> processForwardedMsg author msg + Left (SEGroupMemberNotFoundByMemberId _) -> do + unknownAuthor <- createUnknownMember gInfo memberId + toView $ CRUnknownMemberCreated user gInfo m unknownAuthor + processForwardedMsg unknownAuthor msg + Left e -> throwError $ ChatErrorStore e + where + -- Note: forwarded group events (see forwardedGroupMsg) should include msgId to be deduplicated + processForwardedMsg :: GroupMember -> ChatMessage 'Json -> CM () + processForwardedMsg author chatMsg = do + let body = LB.toStrict $ J.encode msg + rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg + case event of + XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs True + XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr + XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live + XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs + XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs + XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId + XInfo p -> xInfoMember gInfo author p msgTs + XGrpMemNew memInfo -> xGrpMemNew gInfo author memInfo rcvMsg msgTs + XGrpMemRole memId memRole -> xGrpMemRole gInfo author memId memRole rcvMsg msgTs + XGrpMemDel memId -> xGrpMemDel gInfo author memId rcvMsg msgTs + XGrpLeave -> xGrpLeave gInfo author rcvMsg msgTs + XGrpDel -> xGrpDel gInfo author rcvMsg msgTs + XGrpInfo p' -> xGrpInfo gInfo author p' rcvMsg msgTs + XGrpPrefs ps' -> xGrpPrefs gInfo author ps' + _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) + + createUnknownMember :: GroupInfo -> MemberId -> CM GroupMember + createUnknownMember gInfo memberId = do + let name = T.take 7 . safeDecodeUtf8 . B64.encode . unMemberId $ memberId + withStore $ \db -> createNewUnknownGroupMember db vr user gInfo memberId name + + directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM () + directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do + checkIntegrityCreateItem (CDDirectRcv ct) msgMeta `catchChatError` \_ -> pure () + forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do + withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus + updateDirectItemStatus ct conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete + + groupMsgReceived :: GroupInfo -> GroupMember -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM () + groupMsgReceived gInfo m conn@Connection {connId} msgMeta msgRcpts = do + checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure () + forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do + withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus + updateGroupItemsStatus gInfo m conn agentMsgId (GSSRcvd msgRcptStatus) Nothing + + -- Searches chat items for many agent message IDs and updates their status + updateDirectItemsStatusMsgs :: Contact -> Connection -> [AgentMsgId] -> CIStatus 'MDSnd -> CM () + updateDirectItemsStatusMsgs ct conn msgIds newStatus = do + cis <- withStore' $ \db -> forM msgIds $ \msgId -> runExceptT $ updateDirectItemsStatus' db ct conn msgId newStatus + let acis = map ctItem $ concat $ rights cis + unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis + where + ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct) + + updateDirectItemStatus :: Contact -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> CM () + updateDirectItemStatus ct conn msgId newStatus = do + cis <- withStore $ \db -> updateDirectItemsStatus' db ct conn msgId newStatus + let acis = map ctItem cis + unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis + where + ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct) + + updateDirectItemsStatus' :: DB.Connection -> Contact -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd] + updateDirectItemsStatus' db ct@Contact {contactId} Connection {connId} msgId newStatus = do + items <- liftIO $ getDirectChatItemsByAgentMsgId db user contactId connId msgId + catMaybes <$> mapM updateItem items + where + updateItem :: CChatItem 'CTDirect -> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd)) + updateItem = \case + (CChatItem SMDSnd ChatItem {meta = CIMeta {itemStatus = CISSndRcvd _ _}}) -> pure Nothing + (CChatItem SMDSnd ChatItem {meta = CIMeta {itemId, itemStatus}}) + | itemStatus == newStatus -> pure Nothing + | otherwise -> Just <$> updateDirectChatItemStatus db user ct itemId newStatus + _ -> pure Nothing + + updateGroupMemSndStatus' :: DB.Connection -> ChatItemId -> GroupMemberId -> GroupSndStatus -> IO Bool + updateGroupMemSndStatus' db itemId groupMemberId newStatus = + runExceptT (getGroupSndStatus db itemId groupMemberId) >>= \case + Right (GSSRcvd _) -> pure False + Right memStatus + | memStatus == newStatus -> pure False + | otherwise -> updateGroupSndStatus db itemId groupMemberId newStatus $> True + _ -> pure False + + updateGroupItemsStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> GroupSndStatus -> Maybe Bool -> CM () + updateGroupItemsStatus gInfo@GroupInfo {groupId} GroupMember {groupMemberId} Connection {connId} msgId newMemStatus viaProxy_ = do + items <- withStore' (\db -> getGroupChatItemsByAgentMsgId db user groupId connId msgId) + cis <- catMaybes <$> withStore (\db -> mapM (updateItem db) items) + let acis = map gItem cis + unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis + where + gItem = AChatItem SCTGroup SMDSnd (GroupChat gInfo) + updateItem :: DB.Connection -> CChatItem 'CTGroup -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd)) + updateItem db = \case + (CChatItem SMDSnd ChatItem {meta = CIMeta {itemStatus = CISSndRcvd _ SSPComplete}}) -> pure Nothing + (CChatItem SMDSnd ChatItem {meta = CIMeta {itemId, itemStatus}}) -> do + forM_ viaProxy_ $ \viaProxy -> liftIO $ setGroupSndViaProxy db itemId groupMemberId viaProxy + memStatusChanged <- liftIO $ updateGroupMemSndStatus' db itemId groupMemberId newMemStatus + if memStatusChanged + then do + memStatusCounts <- liftIO $ getGroupSndStatusCounts db itemId + let newStatus = membersGroupItemStatus memStatusCounts + if newStatus /= itemStatus + then Just <$> updateGroupChatItemStatus db user gInfo itemId newStatus + else pure Nothing + else pure Nothing + _ -> pure Nothing diff --git a/src/Simplex/Chat/Migrations/M20241206_chat_tags.hs b/src/Simplex/Chat/Migrations/M20241206_chat_tags.hs new file mode 100644 index 0000000000..2476512814 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20241206_chat_tags.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20241206_chat_tags where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20241206_chat_tags :: Query +m20241206_chat_tags = + [sql| +CREATE TABLE chat_tags ( + chat_tag_id INTEGER PRIMARY KEY AUTOINCREMENT, + user_id INTEGER REFERENCES users, + chat_tag_text TEXT NOT NULL, + chat_tag_emoji TEXT, + tag_order INTEGER NOT NULL +); + +CREATE TABLE chat_tags_chats ( + contact_id INTEGER REFERENCES contacts ON DELETE CASCADE, + group_id INTEGER REFERENCES groups ON DELETE CASCADE, + chat_tag_id INTEGER NOT NULL REFERENCES chat_tags ON DELETE CASCADE +); + +CREATE INDEX idx_chat_tags_user_id ON chat_tags(user_id); +CREATE UNIQUE INDEX idx_chat_tags_user_id_chat_tag_text ON chat_tags(user_id, chat_tag_text); +CREATE UNIQUE INDEX idx_chat_tags_user_id_chat_tag_emoji ON chat_tags(user_id, chat_tag_emoji); + +CREATE INDEX idx_chat_tags_chats_chat_tag_id ON chat_tags_chats(chat_tag_id); +CREATE UNIQUE INDEX idx_chat_tags_chats_chat_tag_id_contact_id ON chat_tags_chats(contact_id, chat_tag_id); +CREATE UNIQUE INDEX idx_chat_tags_chats_chat_tag_id_group_id ON chat_tags_chats(group_id, chat_tag_id); +|] + +down_m20241206_chat_tags :: Query +down_m20241206_chat_tags = + [sql| +DROP INDEX idx_chat_tags_user_id; +DROP INDEX idx_chat_tags_user_id_chat_tag_text; +DROP INDEX idx_chat_tags_user_id_chat_tag_emoji; + +DROP INDEX idx_chat_tags_chats_chat_tag_id; +DROP INDEX idx_chat_tags_chats_chat_tag_id_contact_id; +DROP INDEX idx_chat_tags_chats_chat_tag_id_group_id; + +DROP TABLE chat_tags_chats; +DROP TABLE chat_tags; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 94ccc65b7f..5f48f4d63e 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -623,6 +623,18 @@ CREATE TABLE operator_usage_conditions( accepted_at TEXT, created_at TEXT NOT NULL DEFAULT(datetime('now')) ); +CREATE TABLE chat_tags( + chat_tag_id INTEGER PRIMARY KEY AUTOINCREMENT, + user_id INTEGER REFERENCES users, + chat_tag_text TEXT NOT NULL, + chat_tag_emoji TEXT, + tag_order INTEGER NOT NULL +); +CREATE TABLE chat_tags_chats( + contact_id INTEGER REFERENCES contacts ON DELETE CASCADE, + group_id INTEGER REFERENCES groups ON DELETE CASCADE, + chat_tag_id INTEGER NOT NULL REFERENCES chat_tags ON DELETE CASCADE +); CREATE INDEX contact_profiles_index ON contact_profiles( display_name, full_name @@ -929,3 +941,21 @@ CREATE INDEX idx_chat_items_notes ON chat_items( created_at ); CREATE INDEX idx_groups_business_xcontact_id ON groups(business_xcontact_id); +CREATE INDEX idx_chat_tags_user_id ON chat_tags(user_id); +CREATE UNIQUE INDEX idx_chat_tags_user_id_chat_tag_text ON chat_tags( + user_id, + chat_tag_text +); +CREATE UNIQUE INDEX idx_chat_tags_user_id_chat_tag_emoji ON chat_tags( + user_id, + chat_tag_emoji +); +CREATE INDEX idx_chat_tags_chats_chat_tag_id ON chat_tags_chats(chat_tag_id); +CREATE UNIQUE INDEX idx_chat_tags_chats_chat_tag_id_contact_id ON chat_tags_chats( + contact_id, + chat_tag_id +); +CREATE UNIQUE INDEX idx_chat_tags_chats_chat_tag_id_group_id ON chat_tags_chats( + group_id, + chat_tag_id +); diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 4a881a59ca..5af24434e9 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -38,6 +38,7 @@ import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEnco import Simplex.Chat import Simplex.Chat.Controller import Simplex.Chat.Image (readResizeable, resizeImageToSize) +import Simplex.Chat.Library.Commands import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList) import Simplex.Chat.Mobile.File import Simplex.Chat.Mobile.Shared diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index db787b0112..6783dae99e 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -21,11 +21,14 @@ where import Control.Applicative ((<|>)) import Control.Monad import Control.Monad.Except +import Control.Monad.IO.Class +import Data.Bitraversable (bitraverse) import Data.Int (Int64) import Data.Maybe (catMaybes, fromMaybe) import Database.SQLite.Simple (Only (..), (:.) (..)) import Database.SQLite.Simple.QQ (sql) import Simplex.Chat.Protocol +import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Files import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Profiles @@ -93,8 +96,9 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do (userId, agentConnId) getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact getContactRec_ contactId c = ExceptT $ do - toContact' contactId c - <$> DB.query + chatTags <- getDirectChatTags db contactId + firstRow (toContact' contactId c chatTags) (SEInternalError "referenced contact not found") $ + DB.query db [sql| SELECT @@ -105,17 +109,16 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0 |] (userId, contactId) - toContact' :: Int64 -> Connection -> [ContactRow'] -> Either StoreError Contact - toContact' contactId conn [(profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. (contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData)] = + toContact' :: Int64 -> Connection -> [ChatTagId] -> ContactRow' -> Contact + toContact' contactId conn chatTags ((profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. (contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData)) = let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn activeConn = Just conn - in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData} - toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" + in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, chatTags, uiThemes, chatDeleted, customData} getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) - getGroupAndMember_ groupMemberId c = ExceptT $ do - firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $ + getGroupAndMember_ groupMemberId c = do + gm <- ExceptT $ firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $ DB.query db [sql| @@ -141,9 +144,10 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? |] (groupMemberId, userId, userContactId) + liftIO $ bitraverse (addGroupChatTags db) pure gm toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember) toGroupAndMember c (groupInfoRow :. memberRow) = - let groupInfo = toGroupInfo vr userContactId groupInfoRow + let groupInfo = toGroupInfo vr userContactId [] groupInfoRow member = toGroupMember userContactId memberRow in (groupInfo, (member :: GroupMember) {activeConn = Just c}) getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index d5396a0fef..7697f5d5d8 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -79,6 +79,8 @@ module Simplex.Chat.Store.Direct setContactCustomData, setContactUIThemes, setContactChatDeleted, + getDirectChatTags, + updateDirectChatTags, ) where @@ -180,8 +182,8 @@ getConnReqContactXContactId db vr user@User {userId} cReqHash = do (userId, cReqHash) getContactByConnReqHash :: DB.Connection -> VersionRangeChat -> User -> ConnReqUriHash -> IO (Maybe Contact) -getContactByConnReqHash db vr user@User {userId} cReqHash = - maybeFirstRow (toContact vr user) $ +getContactByConnReqHash db vr user@User {userId} cReqHash = do + ct_ <- maybeFirstRow (toContact vr user []) $ DB.query db [sql| @@ -201,6 +203,7 @@ getContactByConnReqHash db vr user@User {userId} cReqHash = LIMIT 1 |] (userId, cReqHash, CSActive) + mapM (addDirectChatTags db) ct_ createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> SubscriptionMode -> VersionChat -> PQSupport -> IO PendingContactConnection createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile subMode chatV pqSup = do @@ -251,6 +254,7 @@ createDirectContact db user@User {userId} conn@Connection {connId, localAlias} p chatTs = Just currentTs, contactGroupMemberId = Nothing, contactGrpInvSent = False, + chatTags = [], uiThemes = Nothing, chatDeleted = False, customData = Nothing @@ -636,8 +640,8 @@ createOrUpdateContactRequest db vr user@User {userId, userContactId} userContact ) insertedRowId db getContact' :: XContactId -> IO (Maybe Contact) - getContact' xContactId = - maybeFirstRow (toContact vr user) $ + getContact' xContactId = do + ct_ <- maybeFirstRow (toContact vr user []) $ DB.query db [sql| @@ -657,13 +661,15 @@ createOrUpdateContactRequest db vr user@User {userId, userContactId} userContact LIMIT 1 |] (userId, xContactId) + mapM (addDirectChatTags db) ct_ getGroupInfo' :: XContactId -> IO (Maybe GroupInfo) - getGroupInfo' xContactId = - maybeFirstRow (toGroupInfo vr userContactId) $ + getGroupInfo' xContactId = do + g_ <- maybeFirstRow (toGroupInfo vr userContactId []) $ DB.query db (groupInfoQuery <> " WHERE g.business_xcontact_id = ? AND g.user_id = ? AND mu.contact_id = ?") (xContactId, userId, userContactId) + mapM (addGroupChatTags db) g_ getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest) getContactRequestByXContactId xContactId = maybeFirstRow toContactRequest $ @@ -819,6 +825,7 @@ createAcceptedContact db user@User {userId, profile = LocalProfile {preferences} chatTs = Just createdAt, contactGroupMemberId = Nothing, contactGrpInvSent = False, + chatTags = [], uiThemes = Nothing, chatDeleted = False, customData = Nothing @@ -845,8 +852,9 @@ getContact :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT Stor getContact db vr user contactId = getContact_ db vr user contactId False getContact_ :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact -getContact_ db vr user@User {userId} contactId deleted = - ExceptT . firstRow (toContact vr user) (SEContactNotFound contactId) $ +getContact_ db vr user@User {userId} contactId deleted = do + chatTags <- liftIO $ getDirectChatTags db contactId + ExceptT . firstRow (toContact vr user chatTags) (SEContactNotFound contactId) $ DB.query db [sql| @@ -1018,3 +1026,39 @@ setContactChatDeleted :: DB.Connection -> User -> Contact -> Bool -> IO () setContactChatDeleted db User {userId} Contact {contactId} chatDeleted = do updatedAt <- getCurrentTime DB.execute db "UPDATE contacts SET chat_deleted = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" (chatDeleted, updatedAt, userId, contactId) + +updateDirectChatTags :: DB.Connection -> ContactId -> [ChatTagId] -> IO () +updateDirectChatTags db contactId tIds = do + currentTags <- getDirectChatTags db contactId + let tagsToAdd = filter (`notElem` currentTags) tIds + tagsToDelete = filter (`notElem` tIds) currentTags + forM_ tagsToDelete $ untagDirectChat db contactId + forM_ tagsToAdd $ tagDirectChat db contactId + +tagDirectChat :: DB.Connection -> ContactId -> ChatTagId -> IO () +tagDirectChat db contactId tId = + DB.execute + db + [sql| + INSERT INTO chat_tags_chats (contact_id, chat_tag_id) + VALUES (?,?) + |] + (contactId, tId) + +untagDirectChat :: DB.Connection -> ContactId -> ChatTagId -> IO () +untagDirectChat db contactId tId = + DB.execute + db + [sql| + DELETE FROM chat_tags_chats + WHERE contact_id = ? AND chat_tag_id = ? + |] + (contactId, tId) + +getDirectChatTags :: DB.Connection -> ContactId -> IO [ChatTagId] +getDirectChatTags db contactId = map fromOnly <$> DB.query db "SELECT chat_tag_id FROM chat_tags_chats WHERE contact_id = ?" (Only contactId) + +addDirectChatTags :: DB.Connection -> Contact -> IO Contact +addDirectChatTags db ct = do + chatTags <- getDirectChatTags db $ contactId' ct + pure (ct :: Contact) {chatTags} diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 36ce7f3575..98173800cc 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -122,6 +122,8 @@ module Simplex.Chat.Store.Groups updateUserMemberProfileSentAt, setGroupCustomData, setGroupUIThemes, + updateGroupChatTags, + getGroupChatTags, ) where @@ -130,6 +132,7 @@ import Control.Monad.Except import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG) import Data.Bifunctor (second) +import Data.Bitraversable (bitraverse) import Data.Either (rights) import Data.Int (Int64) import Data.List (partition, sortOn) @@ -249,8 +252,8 @@ setGroupLinkMemberRole db User {userId} userContactLinkId memberRole = DB.execute db "UPDATE user_contact_links SET group_link_member_role = ? WHERE user_id = ? AND user_contact_link_id = ?" (memberRole, userId, userContactLinkId) getGroupAndMember :: DB.Connection -> User -> Int64 -> VersionRangeChat -> ExceptT StoreError IO (GroupInfo, GroupMember) -getGroupAndMember db User {userId, userContactId} groupMemberId vr = - ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $ +getGroupAndMember db User {userId, userContactId} groupMemberId vr = do + gm <- ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $ DB.query db [sql| @@ -285,10 +288,11 @@ getGroupAndMember db User {userId, userContactId} groupMemberId vr = WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? |] (userId, groupMemberId, userId, userContactId) + liftIO $ bitraverse (addGroupChatTags db) pure gm where toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) toGroupAndMember (groupInfoRow :. memberRow :. connRow) = - let groupInfo = toGroupInfo vr userContactId groupInfoRow + let groupInfo = toGroupInfo vr userContactId [] groupInfoRow member = toGroupMember userContactId memberRow in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection vr connRow}) @@ -333,6 +337,7 @@ createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = Exc updatedAt = currentTs, chatTs = Just currentTs, userMemberProfileSentAt = Just currentTs, + chatTags = [], uiThemes = Nothing, customData = Nothing } @@ -401,6 +406,7 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ updatedAt = currentTs, chatTs = Just currentTs, userMemberProfileSentAt = Just currentTs, + chatTags = [], uiThemes = Nothing, customData = Nothing }, @@ -624,8 +630,8 @@ getUserGroups db vr user@User {userId} = do rights <$> mapM (runExceptT . getGroup db vr user) groupIds getUserGroupDetails :: DB.Connection -> VersionRangeChat -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo] -getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ = - map (toGroupInfo vr userContactId) +getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ = do + g_ <- map (toGroupInfo vr userContactId []) <$> DB.query db [sql| @@ -643,6 +649,7 @@ getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ = AND (gp.display_name LIKE '%' || ? || '%' OR gp.full_name LIKE '%' || ? || '%' OR gp.description LIKE '%' || ? || '%') |] (userId, userContactId, search, search, search) + mapM (addGroupChatTags db) g_ where search = fromMaybe "" search_ @@ -1362,8 +1369,8 @@ createMemberConnection_ db userId groupMemberId agentConnId chatV peerChatVRange createConnection_ db userId ConnMember (Just groupMemberId) agentConnId ConnNew chatV peerChatVRange viaContact Nothing Nothing connLevel currentTs subMode PQSupportOff getViaGroupMember :: DB.Connection -> VersionRangeChat -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember)) -getViaGroupMember db vr User {userId, userContactId} Contact {contactId} = - maybeFirstRow toGroupAndMember $ +getViaGroupMember db vr User {userId, userContactId} Contact {contactId} = do + gm_ <- maybeFirstRow toGroupAndMember $ DB.query db [sql| @@ -1399,10 +1406,11 @@ getViaGroupMember db vr User {userId, userContactId} Contact {contactId} = WHERE ct.user_id = ? AND ct.contact_id = ? AND mu.contact_id = ? AND ct.deleted = 0 |] (userId, userId, contactId, userContactId) + mapM (bitraverse (addGroupChatTags db) pure) gm_ where toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) toGroupAndMember (groupInfoRow :. memberRow :. connRow) = - let groupInfo = toGroupInfo vr userContactId groupInfoRow + let groupInfo = toGroupInfo vr userContactId [] groupInfoRow member = toGroupMember userContactId memberRow in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection vr connRow}) @@ -1482,22 +1490,24 @@ updateGroupProfileFromMember db user g@GroupInfo {groupId} Profile {displayName updateGroupProfile db user g' p' where getGroupProfile = - ExceptT $ firstRow toGroupProfile (SEGroupNotFound groupId) $ - DB.query - db - [sql| + ExceptT $ + firstRow toGroupProfile (SEGroupNotFound groupId) $ + DB.query + db + [sql| SELECT gp.display_name, gp.full_name, gp.description, gp.image, gp.preferences FROM group_profiles gp JOIN groups g ON gp.group_profile_id = g.group_profile_id WHERE g.group_id = ? |] - (Only groupId) + (Only groupId) toGroupProfile (displayName, fullName, description, image, groupPreferences) = GroupProfile {displayName, fullName, description, image, groupPreferences} getGroupInfo :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO GroupInfo -getGroupInfo db vr User {userId, userContactId} groupId = - ExceptT . firstRow (toGroupInfo vr userContactId) (SEGroupNotFound groupId) $ +getGroupInfo db vr User {userId, userContactId} groupId = ExceptT $ do + chatTags <- getGroupChatTags db groupId + firstRow (toGroupInfo vr userContactId chatTags) (SEGroupNotFound groupId) $ DB.query db (groupInfoQuery <> " WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ?") @@ -2053,7 +2063,7 @@ createMemberContact quotaErrCounter = 0 } mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn - pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False, uiThemes = Nothing, chatDeleted = False, customData = Nothing} + pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False, chatTags = [], uiThemes = Nothing, chatDeleted = False, customData = Nothing} getMemberContact :: DB.Connection -> VersionRangeChat -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation) getMemberContact db vr user contactId = do @@ -2090,7 +2100,7 @@ createMemberContactInvited contactId <- createContactUpdateMember currentTs userPreferences ctConn <- createMemberContactConn_ db user connIds gInfo mConn contactId subMode let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn - mCt' = Contact {contactId, localDisplayName = memberLDN, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Nothing, contactGrpInvSent = False, uiThemes = Nothing, chatDeleted = False, customData = Nothing} + mCt' = Contact {contactId, localDisplayName = memberLDN, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Nothing, contactGrpInvSent = False, chatTags = [], uiThemes = Nothing, chatDeleted = False, customData = Nothing} m' = m {memberContactId = Just contactId} pure (mCt', m') where @@ -2301,3 +2311,31 @@ setGroupUIThemes :: DB.Connection -> User -> GroupInfo -> Maybe UIThemeEntityOve setGroupUIThemes db User {userId} GroupInfo {groupId} uiThemes = do updatedAt <- getCurrentTime DB.execute db "UPDATE groups SET ui_themes = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (uiThemes, updatedAt, userId, groupId) + +updateGroupChatTags :: DB.Connection -> GroupId -> [ChatTagId] -> IO () +updateGroupChatTags db gId tIds = do + currentTags <- getGroupChatTags db gId + let tagsToAdd = filter (`notElem` currentTags) tIds + tagsToDelete = filter (`notElem` tIds) currentTags + forM_ tagsToDelete $ untagGroupChat db gId + forM_ tagsToAdd $ tagGroupChat db gId + +tagGroupChat :: DB.Connection -> GroupId -> ChatTagId -> IO () +tagGroupChat db groupId tId = + DB.execute + db + [sql| + INSERT INTO chat_tags_chats (group_id, chat_tag_id) + VALUES (?,?) + |] + (groupId, tId) + +untagGroupChat :: DB.Connection -> GroupId -> ChatTagId -> IO () +untagGroupChat db groupId tId = + DB.execute + db + [sql| + DELETE FROM chat_tags_chats + WHERE group_id = ? AND chat_tag_id = ? + |] + (groupId, tId) diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index 65fe8223fe..aaf7ecdca1 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -119,6 +119,7 @@ import Simplex.Chat.Migrations.M20241027_server_operators import Simplex.Chat.Migrations.M20241125_indexes import Simplex.Chat.Migrations.M20241128_business_chats import Simplex.Chat.Migrations.M20241205_business_chat_members +import Simplex.Chat.Migrations.M20241206_chat_tags import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -237,7 +238,8 @@ schemaMigrations = ("20241027_server_operators", m20241027_server_operators, Just down_m20241027_server_operators), ("20241125_indexes", m20241125_indexes, Just down_m20241125_indexes), ("20241128_business_chats", m20241128_business_chats, Just down_m20241128_business_chats), - ("20241205_business_chat_members", m20241205_business_chat_members, Just down_m20241205_business_chat_members) + ("20241205_business_chat_members", m20241205_business_chat_members, Just down_m20241205_business_chat_members), + ("20241206_chat_tags", m20241206_chat_tags, Just down_m20241206_chat_tags) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 851078ec1f..c6ac85dbd3 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Shared where @@ -391,14 +392,14 @@ type ContactRow' = (ProfileId, ContactName, Maybe Int64, ContactName, Text, Mayb type ContactRow = Only ContactId :. ContactRow' -toContact :: VersionRangeChat -> User -> ContactRow :. MaybeConnectionRow -> Contact -toContact vr user ((Only contactId :. (profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. (contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData)) :. connRow) = +toContact :: VersionRangeChat -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact +toContact vr user chatTags ((Only contactId :. (profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. (contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData)) :. connRow) = let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} activeConn = toMaybeConnection vr connRow chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} incognito = maybe False connIncognito activeConn mergedPreferences = contactUserPreferences user userPreferences preferences incognito - in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData} + in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, chatTags, uiThemes, chatDeleted, customData} getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile getProfileById db userId profileId = @@ -552,14 +553,14 @@ type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageD type GroupMemberRow = ((Int64, Int64, MemberId, VersionChat, VersionChat, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Bool, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences)) -toGroupInfo :: VersionRangeChat -> Int64 -> GroupInfoRow -> GroupInfo -toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. businessRow :. (uiThemes, customData) :. userMemberRow) = +toGroupInfo :: VersionRangeChat -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo +toGroupInfo vr userContactId chatTags ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. businessRow :. (uiThemes, customData) :. userMemberRow) = let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} fullGroupPreferences = mergeGroupPreferences groupPreferences groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences} businessChat = toBusinessChatInfo businessRow - in GroupInfo {groupId, localDisplayName, groupProfile, businessChat, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, uiThemes, customData} + in GroupInfo {groupId, localDisplayName, groupProfile, businessChat, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, chatTags, uiThemes, customData} toGroupMember :: Int64 -> GroupMemberRow -> GroupMember toGroupMember userContactId ((groupMemberId, groupId, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) = @@ -592,3 +593,76 @@ groupInfoQuery = JOIN group_members mu ON mu.group_id = g.group_id JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) |] + +createChatTag :: DB.Connection -> User -> Maybe Text -> Text -> IO ChatTagId +createChatTag db User {userId} emoji text = do + DB.execute + db + [sql| + INSERT INTO chat_tags (user_id, chat_tag_emoji, chat_tag_text, tag_order) + VALUES (?,?,?, COALESCE((SELECT MAX(tag_order) + 1 FROM chat_tags WHERE user_id = ?), 1)) + |] + (userId, emoji, text, userId) + insertedRowId db + +deleteChatTag :: DB.Connection -> User -> ChatTagId -> IO () +deleteChatTag db User {userId} tId = + DB.execute + db + [sql| + DELETE FROM chat_tags + WHERE user_id = ? AND chat_tag_id = ? + |] + (userId, tId) + +updateChatTag :: DB.Connection -> User -> ChatTagId -> Maybe Text -> Text -> IO () +updateChatTag db User {userId} tId emoji text = + DB.execute + db + [sql| + UPDATE chat_tags + SET chat_tag_emoji = ?, chat_tag_text = ? + WHERE user_id = ? AND chat_tag_id = ? + |] + (emoji, text, userId, tId) + +updateChatTagOrder :: DB.Connection -> User -> ChatTagId -> Int -> IO () +updateChatTagOrder db User {userId} tId order = + DB.execute + db + [sql| + UPDATE chat_tags + SET tag_order = ? + WHERE user_id = ? AND chat_tag_id = ? + |] + (order, userId, tId) + +reorderChatTags :: DB.Connection -> User -> [ChatTagId] -> IO () +reorderChatTags db user tIds = + forM_ (zip [1 ..] tIds) $ \(order, tId) -> + updateChatTagOrder db user tId order + +getUserChatTags :: DB.Connection -> User -> IO [ChatTag] +getUserChatTags db User {userId} = + map toChatTag + <$> DB.query + db + [sql| + SELECT chat_tag_id, chat_tag_emoji, chat_tag_text + FROM chat_tags + WHERE user_id = ? + ORDER BY tag_order + |] + (Only userId) + where + toChatTag :: (ChatTagId, Maybe Text, Text) -> ChatTag + toChatTag (chatTagId, chatTagEmoji, chatTagText) = ChatTag {chatTagId, chatTagEmoji, chatTagText} + +getGroupChatTags :: DB.Connection -> GroupId -> IO [ChatTagId] +getGroupChatTags db groupId = + map fromOnly <$> DB.query db "SELECT chat_tag_id FROM chat_tags_chats WHERE group_id = ?" (Only groupId) + +addGroupChatTags :: DB.Connection -> GroupInfo -> IO GroupInfo +addGroupChatTags db g@GroupInfo {groupId} = do + chatTags <- getGroupChatTags db groupId + pure (g :: GroupInfo) {chatTags} diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index aa6babfcbd..2ff9e60699 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -14,10 +14,11 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Database.SQLite.Simple (SQLError (..)) import qualified Database.SQLite.Simple as DB -import Simplex.Chat (_defaultNtfServers, defaultChatConfig, operatorSimpleXChat) +import Simplex.Chat (defaultChatConfig, operatorSimpleXChat) import Simplex.Chat.Controller import Simplex.Chat.Core import Simplex.Chat.Help (chatWelcome) +import Simplex.Chat.Library.Commands (_defaultNtfServers) import Simplex.Chat.Operators import Simplex.Chat.Options import Simplex.Chat.Terminal.Input diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 4f6d66d2c1..836bcd7ec8 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -29,8 +29,8 @@ import Database.SQLite.Simple (Only (..)) import qualified Database.SQLite.Simple as SQL import Database.SQLite.Simple.QQ (sql) import GHC.Weak (deRefWeak) -import Simplex.Chat import Simplex.Chat.Controller +import Simplex.Chat.Library.Commands import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent import Simplex.Chat.Styled diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 37c5c039c1..6c914c7c6d 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -21,8 +21,8 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone) -import Simplex.Chat (execChatCommand, processChatCommand) import Simplex.Chat.Controller +import Simplex.Chat.Library.Commands (execChatCommand, processChatCommand) import Simplex.Chat.Markdown import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..)) diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 77a02a4bc1..716925a0d7 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -160,6 +160,8 @@ type ContactId = Int64 type ProfileId = Int64 +type ChatTagId = Int64 + data Contact = Contact { contactId :: ContactId, localDisplayName :: ContactName, @@ -176,6 +178,7 @@ data Contact = Contact chatTs :: Maybe UTCTime, contactGroupMemberId :: Maybe GroupMemberId, contactGrpInvSent :: Bool, + chatTags :: [ChatTagId], uiThemes :: Maybe UIThemeEntityOverrides, chatDeleted :: Bool, customData :: Maybe CustomData @@ -380,6 +383,7 @@ data GroupInfo = GroupInfo updatedAt :: UTCTime, chatTs :: Maybe UTCTime, userMemberProfileSentAt :: Maybe UTCTime, + chatTags :: [ChatTagId], uiThemes :: Maybe UIThemeEntityOverrides, customData :: Maybe CustomData } @@ -1637,6 +1641,13 @@ data CommandData = CommandData } deriving (Show) +data ChatTag = ChatTag + { chatTagId :: Int64, + chatTagText :: Text, + chatTagEmoji :: Maybe Text + } + deriving (Show) + -- ad-hoc type for data required for XGrpMemIntro continuation data XGrpMemIntroCont = XGrpMemIntroCont { groupId :: GroupId, @@ -1791,3 +1802,5 @@ $(JQ.deriveJSON defaultJSON ''Contact) $(JQ.deriveJSON defaultJSON ''ContactRef) $(JQ.deriveJSON defaultJSON ''NoteFolder) + +$(JQ.deriveJSON defaultJSON ''ChatTag) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 8b6a545637..cb117cd4a5 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -36,10 +36,11 @@ import Data.Time.Format (defaultTimeLocale, formatTime) import qualified Data.Version as V import qualified Network.HTTP.Types as Q import Numeric (showFFloat) -import Simplex.Chat (defaultChatConfig, maxImageSize) +import Simplex.Chat (defaultChatConfig) import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Help +import Simplex.Chat.Library.Commands (maxImageSize) import Simplex.Chat.Markdown import Simplex.Chat.Messages hiding (NewChatItem (..)) import Simplex.Chat.Messages.CIContent @@ -96,6 +97,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRApiChats u chats -> ttyUser u $ if testView then testViewChats chats else [viewJSON chats] CRChats chats -> viewChats ts tz chats CRApiChat u chat _ -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat] + CRChatTags u tags -> ttyUser u $ [viewJSON tags] CRApiParsedMarkdown ft -> [viewJSON ft] CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure CRServerOperatorConditions (ServerOperatorConditions ops _ ca) -> viewServerOperators ops ca @@ -149,6 +151,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe | otherwise -> [] CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewItemUpdate chat item liveItems ts tz CRChatItemNotChanged u ci -> ttyUser u $ viewItemNotChanged ci + CRTagsUpdated u _ _ -> ttyUser u ["chat tags updated"] CRChatItemsDeleted u deletions byUser timed -> case deletions of [ChatItemDeletion (AChatItem _ _ chat deletedItem) toItem] -> ttyUser u $ unmuted u chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 8b7e8fcd32..585ef70f6e 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -27,6 +27,7 @@ import Network.Socket import Simplex.Chat import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg) import Simplex.Chat.Core +import Simplex.Chat.Library.Commands import Simplex.Chat.Options import Simplex.Chat.Protocol (currentChatVersion, pqEncryptionCompressionVersion) import Simplex.Chat.Store @@ -463,6 +464,8 @@ smpServerCfg = logStatsStartTime = 0, serverStatsLogFile = "tests/smp-server-stats.daily.log", serverStatsBackupFile = Nothing, + prometheusInterval = Nothing, + prometheusMetricsFile = "tests/smp-server-metrics.txt", pendingENDInterval = 500000, ntfDeliveryInterval = 200000, smpServerVRange = supportedServerSMPRelayVRange, diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs index 797f2a17b4..2244b214c0 100644 --- a/tests/ChatTests/Files.hs +++ b/tests/ChatTests/Files.hs @@ -14,8 +14,8 @@ import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Network.HTTP.Types.URI (urlEncode) -import Simplex.Chat (roundedFDCount) import Simplex.Chat.Controller (ChatConfig (..)) +import Simplex.Chat.Library.Internal (roundedFDCount) import Simplex.Chat.Mobile.File import Simplex.Chat.Options (ChatOpts (..)) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) diff --git a/tests/ChatTests/Forward.hs b/tests/ChatTests/Forward.hs index 3b861a8417..f347e1a396 100644 --- a/tests/ChatTests/Forward.hs +++ b/tests/ChatTests/Forward.hs @@ -9,9 +9,9 @@ import Control.Concurrent (threadDelay) import qualified Data.ByteString.Char8 as B import Data.List (intercalate) import qualified Data.Text as T -import System.Directory (copyFile, doesFileExist, removeFile) -import Simplex.Chat (fixedImagePreview) +import Simplex.Chat.Library.Commands (fixedImagePreview) import Simplex.Chat.Types (ImageData (..)) +import System.Directory (copyFile, doesFileExist, removeFile) import Test.Hspec hiding (it) chatForwardTests :: SpecWith FilePath @@ -740,7 +740,7 @@ testMultiForwardFiles = -- IDs to forward let msgId1 = (read msgIdZero :: Int) + 1 - msgIds = intercalate "," $ map (show . (msgId1 +)) [0..5] + msgIds = intercalate "," $ map (show . (msgId1 +)) [0 .. 5] bob ##> ("/_forward plan @2 " <> msgIds) bob <## "Files can be received: 1, 2, 3, 4" bob <## "5 message(s) out of 6 can be forwarded" diff --git a/tests/ValidNames.hs b/tests/ValidNames.hs index 0700d80846..bbc9c853ea 100644 --- a/tests/ValidNames.hs +++ b/tests/ValidNames.hs @@ -1,6 +1,6 @@ module ValidNames where -import Simplex.Chat +import Simplex.Chat.Library.Commands import Test.Hspec validNameTests :: Spec