Compare commits

..

76 Commits

Author SHA1 Message Date
Diogo 0a22706d01 comments 2024-11-04 10:28:55 +00:00
Diogo bfac8bd58a fix repeated loading on bottom section 2024-11-04 09:21:08 +00:00
Avently 34c10fc12f refactor 2024-11-04 13:18:04 +07:00
Avently 22fc2e5151 refactor 2024-11-04 12:51:29 +07:00
Avently 2396531414 refactor 2024-11-04 12:35:34 +07:00
Diogo a3906cf88f reduce looping 2024-11-02 22:27:20 +00:00
Avently d03fc53151 one more place 2024-11-02 12:17:14 +07:00
Avently 69138dd99f fix rememberSaveable on Android 2024-11-02 11:48:53 +07:00
Diogo f9d01f6f8e fix 2024-11-01 23:16:05 +00:00
Diogo b90f7a932f Merge branch 'dc/core-initial-landing-for-chat' into dc/android-desktop-infinite-scroll 2024-11-01 22:12:06 +00:00
Diogo 40db6686c1 throw when search is sent for initial 2024-11-01 22:11:10 +00:00
Diogo 21f9c7fd50 Revert "propagate search"
This reverts commit 01611fd719.
2024-11-01 21:57:26 +00:00
Diogo d15560a29f fix scroll to bottom race condition after a few lands 2024-11-01 21:26:33 +00:00
Diogo f197c4174c stability improvements and race conditions 2024-11-01 18:20:05 +00:00
Diogo 99719088e5 Merge branch 'dc/core-initial-landing-for-chat' into dc/android-desktop-infinite-scroll 2024-11-01 16:10:32 +00:00
Diogo 01611fd719 propagate search 2024-11-01 16:09:12 +00:00
Diogo 0ce7d16a59 refactor: use foldr everywhere 2024-11-01 16:00:38 +00:00
Diogo bf20b73893 refactor to make landingSection reusable 2024-11-01 15:56:15 +00:00
Diogo c9ae77e9f3 Merge branch 'dc/core-initial-landing-for-chat' into dc/android-desktop-infinite-scroll 2024-11-01 15:17:12 +00:00
Diogo d875fc99f4 revealedItemCount while loop 2024-11-01 15:03:57 +00:00
Diogo 1c4c48f168 prepareItems perf and fixes 2024-11-01 14:52:35 +00:00
Diogo 122d5948af consistent type for chatItemsSectionArea 2024-11-01 14:13:36 +00:00
spaced4ndy fd5e5d295f foldr 2024-11-01 17:30:58 +04:00
Diogo 3a2e59a6e8 fix dropTemporarySections 2024-11-01 12:36:37 +00:00
Avently 494724de01 one more 2024-11-01 19:09:54 +07:00
Avently 089e5f6ec1 fix stale chatInfo 2024-11-01 19:05:42 +07:00
Diogo 74c6a425b3 fix reveals and other range operations, performance improvement 2024-11-01 10:45:57 +00:00
Diogo 0698f4acfc revealed fixed 2024-11-01 10:06:16 +00:00
Avently 779a91f5cb removeIf -> removeAll 2024-11-01 15:00:21 +07:00
Avently 20c4c02f63 fix 2024-11-01 14:59:38 +07:00
Avently d2a473c908 refactor 2024-11-01 14:31:16 +07:00
Avently 01d0c4ef96 Merge remote-tracking branch 'origin/dc/core-initial-landing-for-chat' into dc/android-desktop-infinite-scroll 2024-11-01 13:57:24 +07:00
Diogo bab2341406 more concise pagination handling 2024-10-31 23:40:08 +00:00
Diogo c98e8e774f single api for simple pagination loads 2024-10-31 22:55:01 +00:00
Diogo cf32d1d950 simplify 2024-10-31 22:40:28 +00:00
Diogo 065cc170da Merge branch 'dc/core-pagination' into dc/core-initial-landing-for-chat 2024-10-31 22:08:30 +00:00
Diogo a84b56d39d Merge branch 'master' into dc/core-pagination 2024-10-31 22:07:59 +00:00
Diogo 937e66b3b8 fix occasional race condition on long navigation 2024-10-31 16:55:53 +00:00
Diogo 638b237b8c Merge branch 'dc/core-initial-landing-for-chat' into dc/android-desktop-infinite-scroll 2024-10-31 16:11:05 +00:00
Diogo 37a5c353ea descriptive view message 2024-10-31 16:09:56 +00:00
Diogo 31eca1687c total accuracy on landing section 2024-10-31 16:03:45 +00:00
Diogo 7e9ab7cd85 avoid recompose when revealed is clean 2024-10-31 16:02:00 +00:00
Diogo 8ff2f66bb9 disable auto scroll when loading bottom section 2024-10-31 14:58:45 +00:00
Diogo e2de454426 fix mark read for ranges 2024-10-31 13:24:56 +00:00
Diogo f87a4a43c9 tracking positions correctly on scroll 2024-10-31 11:42:22 +00:00
Diogo 83ce1f5808 Merge branch 'dc/core-initial-landing-for-chat' into dc/android-desktop-infinite-scroll 2024-10-31 10:50:56 +00:00
Diogo 4bbee43602 fix ChatLandingSection serialized type 2024-10-31 10:50:13 +00:00
Diogo 0ee2769e15 fixed enum 2024-10-31 10:49:04 +00:00
Diogo 82e6b2eefc fixed bottom section load 2024-10-31 10:10:05 +00:00
Diogo 97894c7f53 load bottom section if loaded section is unread 2024-10-30 22:20:51 +00:00
Diogo ff42ca69de open on first unread message 2024-10-30 21:48:01 +00:00
Diogo 5ccf00f70e Merge branch 'dc/core-initial-landing-for-chat' into dc/android-desktop-infinite-scroll 2024-10-30 16:09:51 +00:00
Diogo 22be251862 refactor names 2024-10-30 16:08:40 +00:00
Diogo 84bd23a99d api for landing section 2024-10-30 16:07:36 +00:00
Diogo 9737f6baa6 multiple destination section jumps 2024-10-30 12:38:31 +00:00
Diogo 39e3a8cb70 trim section on jump to bottom 2024-10-29 21:56:43 +00:00
Diogo 649561fbc9 refactor 2024-10-29 21:27:23 +00:00
Diogo c681c89657 not use snapshot inside derived state of to avoid crash 2024-10-29 21:22:46 +00:00
Diogo 7ad0a2dd87 remove other sections when jump to bottom clicked 2024-10-29 16:52:43 +00:00
Diogo 71d891acc2 scroll to bottom safer 2024-10-29 16:28:53 +00:00
Diogo 7faa5b4f6a fix reveal and hide items 2024-10-29 16:03:05 +00:00
Diogo c93ed87228 fix group avatar show 2024-10-29 14:11:43 +00:00
Diogo 2b170830df add item separation and date back 2024-10-29 14:01:44 +00:00
Diogo 19755e359d scroll down fixed 2024-10-29 11:35:11 +00:00
Diogo 53c77d310a fetch both sides poc 2024-10-28 22:23:48 +00:00
Diogo 796d3916bd track scroll direction 2024-10-27 16:01:04 +00:00
Diogo b93abb9555 jump to quote base 2024-10-27 15:47:21 +00:00
Diogo c31560238a basic structure 2024-10-27 14:42:32 +00:00
Diogo 2b7ad80dfd fixed sqls 2024-10-27 00:25:05 +01:00
Diogo d8f5b6e813 controller parse 2024-10-27 00:01:52 +01:00
Diogo b6359559c1 support for initial 2024-10-26 23:44:43 +01:00
Diogo 5826d14866 Merge branch 'dc/core-pagination' into dc/core-initial-landing-for-chat 2024-10-26 22:22:04 +01:00
Diogo a9ca467a80 Merge branch 'master' into dc/core-pagination 2024-10-26 22:21:44 +01:00
Diogo 185e307e70 initial work on initial param for loading chat 2024-10-25 17:12:23 +01:00
Diogo f738d2731c core: initial api support for items around a given item (#5092)
* core: initial api support for items around a given item

* implementation and tests for local messages

* pass entities down

* unused

* getAllChatItems implementation and tests

* pagination for getting chat and tests

* remove unused import

* group implementation and tests

* refactor

* order by created at for local and direct chats
2024-10-25 16:30:16 +01:00
Diogo ea61fd7e2b core: auto increment chat item ids (#5088)
* core: auto increment chat item ids

* file name

* down name

* update schema

* ignore down migration on schema dump test

* fix testDirectMessageDelete test

* fix testNotes test
2024-10-25 16:30:04 +01:00
59 changed files with 1717 additions and 2230 deletions
+1 -1
View File
@@ -29,7 +29,7 @@ RUN cp ./scripts/cabal.project.local.linux ./cabal.project.local
# Compile simplex-chat
RUN cabal update
RUN cabal build exe:simplex-chat --constraint 'simplexmq +client_library'
RUN cabal build exe:simplex-chat
# Strip the binary from debug symbols to reduce size
RUN bin=$(find /project/dist-newstyle -name "simplex-chat" -type f -executable) && \
+13 -21
View File
@@ -149,9 +149,9 @@
6419EC582AB97507004A607A /* CIMemberCreatedContactView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 6419EC572AB97507004A607A /* CIMemberCreatedContactView.swift */; };
6432857C2925443C00FBE5C8 /* GroupPreferencesView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 6432857B2925443C00FBE5C8 /* GroupPreferencesView.swift */; };
643B3B452CCBEB080083A2CF /* libgmpxx.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B402CCBEB080083A2CF /* libgmpxx.a */; };
643B3B462CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a */; };
643B3B462CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a */; };
643B3B472CCBEB080083A2CF /* libffi.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B422CCBEB080083A2CF /* libffi.a */; };
643B3B482CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a */; };
643B3B482CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a */; };
643B3B492CCBEB080083A2CF /* libgmp.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 643B3B442CCBEB080083A2CF /* libgmp.a */; };
6440CA00288857A10062C672 /* CIEventView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 6440C9FF288857A10062C672 /* CIEventView.swift */; };
6440CA03288AECA70062C672 /* AddGroupMembersView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 6440CA02288AECA70062C672 /* AddGroupMembersView.swift */; };
@@ -492,9 +492,9 @@
6419EC572AB97507004A607A /* CIMemberCreatedContactView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = CIMemberCreatedContactView.swift; sourceTree = "<group>"; };
6432857B2925443C00FBE5C8 /* GroupPreferencesView.swift */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.swift; path = GroupPreferencesView.swift; sourceTree = "<group>"; };
643B3B402CCBEB080083A2CF /* libgmpxx.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = libgmpxx.a; path = Libraries/libgmpxx.a; sourceTree = "<group>"; };
643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = "libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a"; path = "Libraries/libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a"; sourceTree = "<group>"; };
643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = "libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a"; path = "Libraries/libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a"; sourceTree = "<group>"; };
643B3B422CCBEB080083A2CF /* libffi.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = libffi.a; path = Libraries/libffi.a; sourceTree = "<group>"; };
643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = "libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a"; path = "Libraries/libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a"; sourceTree = "<group>"; };
643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = "libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a"; path = "Libraries/libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a"; sourceTree = "<group>"; };
643B3B442CCBEB080083A2CF /* libgmp.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; name = libgmp.a; path = Libraries/libgmp.a; sourceTree = "<group>"; };
6440C9FF288857A10062C672 /* CIEventView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = CIEventView.swift; sourceTree = "<group>"; };
6440CA02288AECA70062C672 /* AddGroupMembersView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = AddGroupMembersView.swift; sourceTree = "<group>"; };
@@ -663,8 +663,8 @@
5CE2BA93284534B000EC33A6 /* libiconv.tbd in Frameworks */,
5CE2BA94284534BB00EC33A6 /* libz.tbd in Frameworks */,
CE38A29C2C3FCD72005ED185 /* SwiftyGif in Frameworks */,
643B3B482CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a in Frameworks */,
643B3B462CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a in Frameworks */,
643B3B482CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a in Frameworks */,
643B3B462CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a in Frameworks */,
);
runOnlyForDeploymentPostprocessing = 0;
};
@@ -815,8 +815,8 @@
643B3B422CCBEB080083A2CF /* libffi.a */,
643B3B442CCBEB080083A2CF /* libgmp.a */,
643B3B402CCBEB080083A2CF /* libgmpxx.a */,
643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5-ghc9.6.3.a */,
643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-CTfGB7l09cqEHVIdvhrnH5.a */,
643B3B412CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9-ghc9.6.3.a */,
643B3B432CCBEB080083A2CF /* libHSsimplex-chat-6.1.1.0-KwHIA7FZqPI5ZTCAoi00n9.a */,
5CA059C2279559F40002BEB4 /* Shared */,
5CDCAD462818589900503DA2 /* SimpleX NSE */,
CEE723A82C3BD3D70009AE93 /* SimpleX SE */,
@@ -912,9 +912,10 @@
5CB924DF27A8678B00ACCCDD /* UserSettings */ = {
isa = PBXGroup;
children = (
643B3B4C2CCFD34B0083A2CF /* NetworkAndServers */,
5CB924D627A8563F00ACCCDD /* SettingsView.swift */,
5CB346E62868D76D001FD2EF /* NotificationsView.swift */,
5C9C2DA6289957AE00CC63B1 /* AdvancedNetworkSettings.swift */,
5C9C2DA82899DA6F00CC63B1 /* NetworkAndServers.swift */,
5CADE79929211BB900072E13 /* PreferencesView.swift */,
5C5DB70D289ABDD200730FFF /* AppearanceSettings.swift */,
5C05DF522840AA1D00C683F9 /* CallSettings.swift */,
@@ -922,6 +923,9 @@
5CC036DF29C488D500C0EF20 /* HiddenProfileView.swift */,
5C577F7C27C83AA10006112D /* MarkdownHelp.swift */,
5C3F1D57284363C400EC8A82 /* PrivacySettings.swift */,
5C93292E29239A170090FFF9 /* ProtocolServersView.swift */,
5C93293029239BED0090FFF9 /* ProtocolServerView.swift */,
5C9329402929248A0090FFF9 /* ScanProtocolServer.swift */,
5CB2084E28DA4B4800D024EC /* RTCServers.swift */,
64F1CC3A28B39D8600CD1FB1 /* IncognitoHelp.swift */,
18415845648CA4F5A8BCA272 /* UserProfilesView.swift */,
@@ -1052,18 +1056,6 @@
path = Database;
sourceTree = "<group>";
};
643B3B4C2CCFD34B0083A2CF /* NetworkAndServers */ = {
isa = PBXGroup;
children = (
5C9329402929248A0090FFF9 /* ScanProtocolServer.swift */,
5C93293029239BED0090FFF9 /* ProtocolServerView.swift */,
5C93292E29239A170090FFF9 /* ProtocolServersView.swift */,
5C9C2DA6289957AE00CC63B1 /* AdvancedNetworkSettings.swift */,
5C9C2DA82899DA6F00CC63B1 /* NetworkAndServers.swift */,
);
path = NetworkAndServers;
sourceTree = "<group>";
};
6440CA01288AEC770062C672 /* Group */ = {
isa = PBXGroup;
children = (
@@ -11,6 +11,7 @@ import androidx.compose.ui.text.style.TextDecoration
import chat.simplex.common.platform.*
import chat.simplex.common.ui.theme.*
import chat.simplex.common.views.call.*
import chat.simplex.common.views.chat.ChatSectionArea
import chat.simplex.common.views.chat.ComposeState
import chat.simplex.common.views.helpers.*
import chat.simplex.common.views.migration.MigrationToDeviceState
@@ -65,6 +66,8 @@ object ChatModel {
// current chat
val chatId = mutableStateOf<String?>(null)
val chatItems = mutableStateOf(SnapshotStateList<ChatItem>())
// chatItemId, SectionArea
val chatItemsSectionArea = mutableMapOf<Long, ChatSectionArea>()
// rhId, chatId
val deletedChats = mutableStateOf<List<Pair<Long?, String>>>(emptyList())
val chatItemStatuses = mutableMapOf<Long, CIStatus>()
@@ -329,6 +332,7 @@ object ChatModel {
if (chatId.value == cInfo.id) {
// Prevent situation when chat item already in the list received from backend
if (chatItems.value.none { it.id == cItem.id }) {
chatItemsSectionArea[cItem.id] = ChatSectionArea.Bottom
if (chatItems.value.lastOrNull()?.id == ChatItem.TEMP_LIVE_CHAT_ITEM_ID) {
chatItems.add(kotlin.math.max(0, chatItems.value.lastIndex), cItem)
} else {
@@ -377,6 +381,7 @@ object ChatModel {
} else {
cItem
}
chatItemsSectionArea[ci.id] = ChatSectionArea.Bottom
chatItems.add(ci)
true
}
@@ -608,6 +613,7 @@ object ChatModel {
val cItem = ChatItem.liveDummy(chatInfo is ChatInfo.Direct)
withContext(Dispatchers.Main) {
chatItems.add(cItem)
chatItemsSectionArea[cItem.id] = ChatSectionArea.Bottom
}
return cItem
}
@@ -615,6 +621,7 @@ object ChatModel {
fun removeLiveDummy() {
if (chatItems.value.lastOrNull()?.id == ChatItem.TEMP_LIVE_CHAT_ITEM_ID) {
chatItems.removeLast()
chatItemsSectionArea.remove(ChatItem.TEMP_LIVE_CHAT_ITEM_ID)
}
}
@@ -2307,6 +2314,10 @@ fun <T> MutableState<SnapshotStateList<T>>.removeAt(index: Int): T {
return res
}
fun <T> MutableState<SnapshotStateList<T>>.removeRange(fromIndex: Int, toIndex: Int) {
value = SnapshotStateList<T>().apply { addAll(value); removeRange(fromIndex, toIndex) }
}
fun <T> MutableState<SnapshotStateList<T>>.removeLast() {
value = SnapshotStateList<T>().apply { addAll(value); removeLast() }
}
@@ -865,11 +865,15 @@ object ChatController {
return emptyList()
}
suspend fun apiGetChat(rh: Long?, type: ChatType, id: Long, pagination: ChatPagination = ChatPagination.Last(ChatPagination.INITIAL_COUNT), search: String = ""): Chat? {
suspend fun apiGetChat(rh: Long?, type: ChatType, id: Long, pagination: ChatPagination = ChatPagination.Last(ChatPagination.INITIAL_COUNT), search: String = ""): Pair<Chat, ChatLandingSection>? {
val r = sendCmd(rh, CC.ApiGetChat(type, id, pagination, search))
if (r is CR.ApiChat) return if (rh == null) r.chat else r.chat.copy(remoteHostId = rh)
Log.e(TAG, "apiGetChat bad response: ${r.responseType} ${r.details}")
AlertManager.shared.showAlertMsg(generalGetString(MR.strings.failed_to_parse_chat_title), generalGetString(MR.strings.contact_developers))
if (r is CR.ApiChat) return if (rh == null) Pair(r.chat, r.section) else Pair(r.chat.copy(remoteHostId = rh), r.section)
if (r is CR.ChatCmdError && r.chatError is ChatError.ChatErrorStore && r.chatError.storeError is StoreError.ChatItemNotFound) {
AlertManager.shared.showAlertMsg(generalGetString(MR.strings.failed_to_get_chat_item_not_found_title), generalGetString(MR.strings.failed_to_get_chat_item_not_found_description))
} else {
Log.e(TAG, "apiGetChat bad response: ${r.responseType} ${r.details}")
AlertManager.shared.showAlertMsg(generalGetString(MR.strings.failed_to_parse_chat_title), generalGetString(MR.strings.contact_developers))
}
return null
}
@@ -3468,11 +3472,15 @@ sealed class ChatPagination {
class Last(val count: Int): ChatPagination()
class After(val chatItemId: Long, val count: Int): ChatPagination()
class Before(val chatItemId: Long, val count: Int): ChatPagination()
class Around(val chatItemId: Long, val count: Int): ChatPagination()
class Initial(val count: Int): ChatPagination()
val cmdString: String get() = when (this) {
is Last -> "count=${this.count}"
is After -> "after=${this.chatItemId} count=${this.count}"
is Before -> "before=${this.chatItemId} count=${this.count}"
is Around -> "around=${this.chatItemId} count=${this.count}"
is Initial -> "initial=${this.count}"
}
companion object {
@@ -4857,7 +4865,10 @@ class APIResponse(val resp: CR, val remoteHostId: Long?, val corr: String? = nul
} else if (type == "apiChat") {
val user: UserRef = json.decodeFromJsonElement(resp["user"]!!.jsonObject)
val chat = parseChatData(resp["chat"]!!)
return APIResponse(CR.ApiChat(user, chat), remoteHostId, corr)
val section = resp["section"]?.let {
json.decodeFromJsonElement<ChatLandingSection>(it)
} ?: ChatLandingSection.Latest
return APIResponse(CR.ApiChat(user, chat, section), remoteHostId, corr)
} else if (type == "chatCmdError") {
val userObject = resp["user_"]?.jsonObject
val user = runCatching<UserRef?> { json.decodeFromJsonElement(userObject!!) }.getOrNull()
@@ -4914,7 +4925,7 @@ sealed class CR {
@Serializable @SerialName("chatRunning") class ChatRunning: CR()
@Serializable @SerialName("chatStopped") class ChatStopped: CR()
@Serializable @SerialName("apiChats") class ApiChats(val user: UserRef, val chats: List<Chat>): CR()
@Serializable @SerialName("apiChat") class ApiChat(val user: UserRef, val chat: Chat): CR()
@Serializable @SerialName("apiChat") class ApiChat(val user: UserRef, val chat: Chat, val section: ChatLandingSection): CR()
@Serializable @SerialName("chatItemInfo") class ApiChatItemInfo(val user: UserRef, val chatItem: AChatItem, val chatItemInfo: ChatItemInfo): CR()
@Serializable @SerialName("userProtoServers") class UserProtoServers(val user: UserRef, val servers: UserProtocolServers): CR()
@Serializable @SerialName("serverTestResult") class ServerTestResult(val user: UserRef, val testServer: String, val testFailure: ProtocolTestFailure? = null): CR()
@@ -5264,7 +5275,7 @@ sealed class CR {
is ChatRunning -> noDetails()
is ChatStopped -> noDetails()
is ApiChats -> withUser(user, json.encodeToString(chats))
is ApiChat -> withUser(user, json.encodeToString(chat))
is ApiChat -> withUser(user, "section: ${json.encodeToString(section)}\n${json.encodeToString(chat)}")
is ApiChatItemInfo -> withUser(user, "chatItem: ${json.encodeToString(chatItem)}\n${json.encodeToString(chatItemInfo)}")
is UserProtoServers -> withUser(user, "servers: ${json.encodeToString(servers)}")
is ServerTestResult -> withUser(user, "server: $testServer\nresult: ${json.encodeToString(testFailure)}")
@@ -5504,6 +5515,12 @@ sealed class GroupLinkPlan {
@Serializable @SerialName("known") class Known(val groupInfo: GroupInfo): GroupLinkPlan()
}
@Serializable
enum class ChatLandingSection {
@SerialName("latest") Latest,
@SerialName("unread") Unread,
}
abstract class TerminalItem {
abstract val id: Long
abstract val remoteHostId: Long?
@@ -0,0 +1,287 @@
package chat.simplex.common.views.chat
import androidx.compose.runtime.toMutableStateList
import chat.simplex.common.model.*
import chat.simplex.common.platform.chatController
import chat.simplex.common.platform.chatModel
import kotlinx.coroutines.Dispatchers
import kotlinx.coroutines.withContext
import kotlin.math.max
const val MAX_SECTION_SIZE = 500
enum class ChatSectionArea {
Bottom,
Current,
Destination
}
data class ChatSectionAreaBoundary (
var minIndex: Int,
var maxIndex: Int,
val area: ChatSectionArea
)
data class ChatSection (
val items: MutableList<SectionItems>,
val boundary: ChatSectionAreaBoundary,
// chatItemId, index in rendered LazyColumn
val itemPositions: MutableMap<Long, Int>
)
data class SectionItems (
val mergeCategory: CIMergeCategory?,
val items: MutableList<ChatItem>,
val revealed: Boolean,
val showAvatar: MutableSet<Long>,
var originalItemsRange: IntRange
)
data class ChatSectionLoader (
val position: Int,
val sectionArea: ChatSectionArea
) {
fun prepareItems(items: List<ChatItem>): List<ChatItem> {
val chatItemsSectionArea = chatModel.chatItemsSectionArea
val itemsToAdd = mutableListOf<ChatItem>()
val sectionsToMerge = mutableMapOf<ChatSectionArea, ChatSectionArea>()
val itemsThatCouldRequireMerge = mutableListOf<ChatItem>()
for (cItem in items) {
val itemSectionArea = chatItemsSectionArea[cItem.id]
if (itemSectionArea == null) {
itemsToAdd.add(cItem)
val targetSection = sectionsToMerge[sectionArea] ?: this.sectionArea
chatItemsSectionArea[cItem.id] = targetSection
if (targetSection == this.sectionArea) {
itemsThatCouldRequireMerge.add(cItem)
}
} else if (itemSectionArea != this.sectionArea) {
val (targetSection, sectionToDrop) = when (itemSectionArea) {
ChatSectionArea.Bottom -> ChatSectionArea.Bottom to this.sectionArea
ChatSectionArea.Current -> if (this.sectionArea == ChatSectionArea.Bottom) ChatSectionArea.Bottom to itemSectionArea else itemSectionArea to this.sectionArea
ChatSectionArea.Destination -> if (this.sectionArea == ChatSectionArea.Bottom) ChatSectionArea.Bottom to itemSectionArea else itemSectionArea to this.sectionArea
}
if (targetSection != sectionToDrop) {
sectionsToMerge[sectionToDrop] = targetSection
}
}
}
if (sectionsToMerge.isNotEmpty()) {
chatModel.chatItems.value.forEach {
val currentSection = chatItemsSectionArea[it.id]
val newSection = sectionsToMerge[currentSection]
if (newSection != null) {
chatItemsSectionArea[it.id] = newSection
}
}
itemsThatCouldRequireMerge.forEach {
val targetSection = sectionsToMerge[sectionArea] ?: sectionArea
chatItemsSectionArea[it.id] = targetSection
}
}
return itemsToAdd
}
}
fun ChatSection.getPreviousShownItem(sectionIndex: Int, itemIndex: Int): ChatItem? {
val section = items.getOrNull(sectionIndex) ?: return null
return if (section.mergeCategory == null) {
section.items.getOrNull(itemIndex + 1) ?: items.getOrNull(sectionIndex + 1)?.items?.firstOrNull()
} else {
items.getOrNull(sectionIndex + 1)?.items?.firstOrNull()
}
}
fun ChatSection.getNextShownItem(sectionIndex: Int, itemIndex: Int): ChatItem? {
val section = items.getOrNull(sectionIndex) ?: return null
return if (section.mergeCategory == null) {
section.items.getOrNull(itemIndex - 1) ?: items.getOrNull(sectionIndex - 1)?.items?.lastOrNull()
} else {
items.getOrNull(sectionIndex - 1)?.items?.lastOrNull()
}
}
fun List<ChatItem>.putIntoSections(revealedItems: Set<Long>): List<ChatSection> {
if (isEmpty()) return emptyList()
val chatItemsSectionArea = chatModel.chatItemsSectionArea
val sections = mutableListOf<ChatSection>()
val first = this[0]
val showAvatar = mutableSetOf<Long>()
if (first.chatDir is CIDirection.GroupRcv) {
val second = getOrNull(1)
if (second != null) {
if (second.chatDir !is CIDirection.GroupRcv || second.chatDir.groupMember.memberId != first.chatDir.groupMember.memberId) {
showAvatar.add(first.id)
}
} else {
showAvatar.add(first.id)
}
}
var recent = SectionItems(
mergeCategory = first.mergeCategory,
items = mutableListOf(first),
revealed = first.mergeCategory == null || revealedItems.contains(first.id),
showAvatar = showAvatar,
originalItemsRange = 0..0
)
val area = chatItemsSectionArea[recent.items[0].id] ?: ChatSectionArea.Bottom
sections.add(
ChatSection(
items = mutableListOf(recent),
boundary = ChatSectionAreaBoundary(minIndex = 0, maxIndex = 0, area = area),
itemPositions = mutableMapOf(recent.items[0].id to 0)
)
)
var prev = this[0]
var index = 0
var positionInList = 0;
while (index < size) {
if (index == 0) {
index++
continue
}
val item = this[index]
val itemArea = chatItemsSectionArea[item.id] ?: ChatSectionArea.Bottom
val existingSection = sections.find { it.boundary.area == itemArea }
if (existingSection == null) {
positionInList++
val newSection = SectionItems(
mergeCategory = item.mergeCategory,
items = mutableListOf(item),
revealed = item.mergeCategory == null || revealedItems.contains(item.id),
showAvatar = mutableSetOf(item.id),
originalItemsRange = index..index
)
sections.add(
ChatSection(
items = mutableListOf(newSection),
boundary = ChatSectionAreaBoundary(minIndex = index, maxIndex = index, area = itemArea),
itemPositions = mutableMapOf(item.id to positionInList)
)
)
} else {
recent = existingSection.items.last()
val category = item.mergeCategory
if (recent.mergeCategory == category) {
if (category == null || recent.revealed || revealedItems.contains(item.id)) {
positionInList++
}
if (item.chatDir is CIDirection.GroupRcv && prev.chatDir is CIDirection.GroupRcv && item.chatDir.groupMember.memberId != (prev.chatDir as CIDirection.GroupRcv).groupMember.memberId) {
recent.showAvatar.add(item.id)
}
recent.items.add(item)
recent.originalItemsRange = recent.originalItemsRange.first..index
existingSection.itemPositions[item.id] = positionInList
} else {
positionInList++
val newSectionItems = SectionItems(
mergeCategory = item.mergeCategory,
items = mutableListOf(item),
revealed = item.mergeCategory == null || revealedItems.contains(item.id),
showAvatar = if (item.chatDir is CIDirection.GroupRcv && (prev.chatDir !is CIDirection.GroupRcv || (prev.chatDir as CIDirection.GroupRcv).groupMember.memberId != item.chatDir.groupMember.memberId)) {
mutableSetOf(item.id)
} else {
mutableSetOf()
},
originalItemsRange = index..index
)
existingSection.itemPositions[item.id] = positionInList
existingSection.items.add(newSectionItems)
}
existingSection.boundary.maxIndex = index
}
prev = item
index++
}
return sections
}
fun List<ChatSection>.chatItemPosition(chatItemId: Long): Int? {
for (section in this) {
val position = section.itemPositions[chatItemId]
if (position != null) {
return position
}
}
return null
}
fun List<ChatSection>.revealedItemCount(): Int {
var count = 0
for (section in this) {
var i = 0;
while (i < section.items.size) {
val item = section.items[i]
if (item.revealed) {
count += item.items.size
} else {
count++
}
i++
}
}
return count
}
fun List<ChatSection>.dropTemporarySections() {
val bottomSection = this.find { it.boundary.area == ChatSectionArea.Bottom }
if (bottomSection != null) {
val itemsOutsideOfSection = chatModel.chatItems.value.lastIndex - bottomSection.boundary.maxIndex
chatModel.chatItems.removeRange(fromIndex = 0, toIndex = itemsOutsideOfSection + bottomSection.excessItemCount())
chatModel.chatItemsSectionArea.clear()
chatModel.chatItems.value.associateTo(chatModel.chatItemsSectionArea) { it.id to ChatSectionArea.Bottom }
}
}
private fun ChatSection.excessItemCount(): Int {
return max(boundary.maxIndex - boundary.minIndex + 1 - MAX_SECTION_SIZE, 0)
}
fun landingSectionToArea(chatLandingSection: ChatLandingSection) = when (chatLandingSection) {
ChatLandingSection.Latest -> ChatSectionArea.Bottom
ChatLandingSection.Unread -> ChatSectionArea.Current
}
suspend fun apiLoadBottomSection(chatInfo: ChatInfo, rhId: Long?) {
val chat = chatController.apiGetChat(rh = rhId, type = chatInfo.chatType, id = chatInfo.apiId)
if (chatModel.chatId.value != chatInfo.id || chat == null) return
withContext(Dispatchers.Main) {
val updatedItems = chatModel.chatItems.value.toMutableStateList()
var insertIndex = updatedItems.size
var needsMerge = false
for (cItem in chat.first.chatItems.asReversed()) {
if (chatModel.chatItemsSectionArea[cItem.id] == null) {
updatedItems.add(insertIndex, cItem)
chatModel.chatItemsSectionArea[cItem.id] = ChatSectionArea.Bottom
} else {
needsMerge = true
chatModel.chatItemsSectionArea[cItem.id] = ChatSectionArea.Bottom
insertIndex = max(0, insertIndex - 1)
}
}
if (needsMerge) {
updatedItems.associateTo(chatModel.chatItemsSectionArea) { it.id to ChatSectionArea.Bottom }
}
chatModel.chatItems.replaceAll(updatedItems)
}
}
@@ -47,8 +47,7 @@ import kotlinx.coroutines.flow.*
import kotlinx.datetime.*
import java.io.File
import java.net.URI
import kotlin.math.abs
import kotlin.math.sign
import kotlin.math.*
data class ItemSeparation(val timestamp: Boolean, val largeGap: Boolean, val date: Instant?)
@@ -292,13 +291,35 @@ fun ChatView(staleChatId: State<String?>, onComposed: suspend (chatId: String) -
}
}
},
loadPrevMessages = { chatId ->
val c = chatModel.getChat(chatId)
loadMessages = { chatId, scrollDirection, (itemId, idx, area) ->
val c = chatModel.getChat(chatId) ?: return@ChatLayout
if (chatModel.chatId.value != chatId) return@ChatLayout
val firstId = chatModel.chatItems.value.firstOrNull()?.id
if (c != null && firstId != null) {
withBGApi {
apiLoadPrevMessages(c, chatModel, firstId, searchText.value)
withBGApi {
when (scrollDirection) {
ScrollDirection.Up -> {
val chatSectionLoader = ChatSectionLoader(idx, area)
apiLoadMessages(
rhId = c.remoteHostId,
chatInfo = c.chatInfo,
chatModel = chatModel,
itemId = itemId,
search = "",
chatSectionLoader = chatSectionLoader,
)
}
ScrollDirection.Down -> {
val chatSectionLoader = ChatSectionLoader(idx + 1, area)
apiLoadMessages(
rhId = c.remoteHostId,
chatInfo = c.chatInfo,
chatModel = chatModel,
itemId = itemId,
search = "",
chatSectionLoader = chatSectionLoader,
pagination = ChatPagination.After(itemId, ChatPagination.PRELOAD_COUNT)
)
}
else -> {}
}
}
},
@@ -583,7 +604,7 @@ fun ChatLayout(
back: () -> Unit,
info: () -> Unit,
showMemberInfo: (GroupInfo, GroupMember) -> Unit,
loadPrevMessages: (ChatId) -> Unit,
loadMessages: (ChatId, ScrollDirection, Triple<Long, Int, ChatSectionArea>) -> Unit,
deleteMessage: (Long, CIDeleteMode) -> Unit,
deleteMessages: (List<Long>) -> Unit,
receiveFile: (Long) -> Unit,
@@ -611,7 +632,7 @@ fun ChatLayout(
onComposed: suspend (chatId: String) -> Unit,
developerTools: Boolean,
showViaProxy: Boolean,
showSearch: MutableState<Boolean>
showSearch: MutableState<Boolean>,
) {
val scope = rememberCoroutineScope()
val attachmentDisabled = remember { derivedStateOf { composeState.value.attachmentDisabled } }
@@ -649,10 +670,10 @@ fun ChatLayout(
Box(Modifier.fillMaxSize()) {
ChatItemsList(
remoteHostId, chatInfo, unreadCount, composeState, composeViewHeight, searchValue,
useLinkPreviews, linkMode, selectedChatItems, showMemberInfo, loadPrevMessages, deleteMessage, deleteMessages,
useLinkPreviews, linkMode, selectedChatItems, showMemberInfo, loadMessages, deleteMessage, deleteMessages,
receiveFile, cancelFile, joinGroup, acceptCall, acceptFeature, openDirectChat, forwardItem,
updateContactStats, updateMemberStats, syncContactConnection, syncMemberConnection, findModelChat, findModelMember,
setReaction, showItemDetails, markRead, remember { { onComposed(it) } }, developerTools, showViaProxy,
setReaction, showItemDetails, markRead, remember { { onComposed(it) } }, developerTools, showViaProxy
)
}
}
@@ -922,7 +943,7 @@ fun BoxScope.ChatItemsList(
linkMode: SimplexLinkMode,
selectedChatItems: MutableState<Set<Long>?>,
showMemberInfo: (GroupInfo, GroupMember) -> Unit,
loadPrevMessages: (ChatId) -> Unit,
loadMessages: (ChatId, ScrollDirection, Triple<Long, Int, ChatSectionArea>) -> Unit,
deleteMessage: (Long, CIDeleteMode) -> Unit,
deleteMessages: (List<Long>) -> Unit,
receiveFile: (Long) -> Unit,
@@ -943,11 +964,12 @@ fun BoxScope.ChatItemsList(
markRead: (CC.ItemRange, unreadCountAfter: Int?) -> Unit,
onComposed: suspend (chatId: String) -> Unit,
developerTools: Boolean,
showViaProxy: Boolean
showViaProxy: Boolean,
) {
val listState = rememberLazyListState()
val scope = rememberCoroutineScope()
ScrollToBottom(chatInfo.id, listState, chatModel.chatItems)
val scrollAdjustmentEnabled = remember { mutableStateOf(true) }
ScrollToBottom(chatInfo.id, listState, chatModel.chatItems, scrollAdjustmentEnabled)
var prevSearchEmptiness by rememberSaveable { mutableStateOf(searchValue.value.isEmpty()) }
// Scroll to bottom when search value changes from something to nothing and back
LaunchedEffect(searchValue.value.isEmpty()) {
@@ -961,21 +983,106 @@ fun BoxScope.ChatItemsList(
}
}
PreloadItems(chatInfo.id, listState, ChatPagination.UNTIL_PRELOAD_COUNT, loadPrevMessages)
Spacer(Modifier.size(8.dp))
val reversedChatItems = remember { derivedStateOf { chatModel.chatItems.asReversed() } }
val revealedItems = rememberSaveable(stateSaver = serializableSaver()) { mutableStateOf(setOf<Long>()) }
val sections = remember { derivedStateOf { reversedChatItems.value.putIntoSections(revealedItems.value) } }
val preloadItemsEnabled = remember { mutableStateOf(true) }
val boundaries = remember { derivedStateOf { sections.value.map { it.boundary } } }
val scrollPosition: State<(Int) -> Int> = remember { mutableStateOf({ idx -> min(sections.value.revealedItemCount() - 1, idx + 1 ) }) }
PreloadItems(chatInfo.id, listState, ChatPagination.UNTIL_PRELOAD_COUNT, preloadItemsEnabled, boundaries, loadMessages)
val topPaddingToContentPx = rememberUpdatedState(with(LocalDensity.current) { topPaddingToContent().roundToPx() })
val maxHeight = remember { derivedStateOf { listState.layoutInfo.viewportEndOffset - topPaddingToContentPx.value } }
val chatInfoUpdated = rememberUpdatedState(chatInfo)
LaunchedEffect(Unit) {
launch {
snapshotFlow { chatInfoUpdated.value.id }
.distinctUntilChanged()
.collect {
if (revealedItems.value.isNotEmpty()) {
revealedItems.value = setOf()
}
val firstUnreadItem = reversedChatItems.value.findLast { it.isRcvNew }
if (firstUnreadItem != null) {
val firstUnreadItemIndexIdx = sections.value.chatItemPosition(firstUnreadItem.id)
if (firstUnreadItemIndexIdx != null) {
scrollAdjustmentEnabled.value = false
listState.scrollToItem(scrollPosition.value(firstUnreadItemIndexIdx), -maxHeight.value)
}
if (chatModel.chatItemsSectionArea[firstUnreadItem.id] != ChatSectionArea.Bottom) {
withBGApi {
scrollAdjustmentEnabled.value = false
try {
apiLoadBottomSection(chatInfoUpdated.value, remoteHostId)
} finally {
delay(600)
scrollAdjustmentEnabled.value = true
preloadItemsEnabled.value = true
}
}
} else {
scrollAdjustmentEnabled.value = true
}
}
preloadItemsEnabled.value = true
}
}
}
val scrollToItem: State<(Long) -> Unit> = remember {
mutableStateOf(
{ itemId: Long ->
val index = reversedChatItems.value.indexOfFirst { it.id == itemId }
if (index != -1) {
scope.launch { listState.animateScrollToItem(kotlin.math.min(reversedChatItems.value.lastIndex, index + 1), -maxHeight.value) }
mutableStateOf({ itemId: Long ->
val index = sections.value.chatItemPosition(itemId)
preloadItemsEnabled.value = false
if (index != null) {
scope.launch {
listState.animateScrollToItem(scrollPosition.value(index), -maxHeight.value)
preloadItemsEnabled.value = true
}
} else {
withBGApi {
try {
val destinationSection = sections.value.find { it.boundary.area == ChatSectionArea.Destination }
val itemsToDrop = destinationSection?.items?.flatMap { it.items }?.toList()
withContext(Dispatchers.Main) {
itemsToDrop?.forEach {
chatModel.chatItemsSectionArea[it.id] = ChatSectionArea.Current
}
}
val chatSectionLoader = ChatSectionLoader(0, ChatSectionArea.Destination)
apiLoadMessages(
rhId = remoteHostId,
chatInfo = chatInfoUpdated.value,
chatModel = chatModel,
itemId = itemId,
search = "",
chatSectionLoader = chatSectionLoader,
pagination = ChatPagination.Around(itemId, ChatPagination.PRELOAD_COUNT * 2)
)
val idx = sections.value.chatItemPosition(itemId)
scope.launch {
if (idx != null) {
listState.animateScrollToItem(scrollPosition.value(idx), -maxHeight.value)
if (!itemsToDrop.isNullOrEmpty()) {
itemsToDrop.forEach {
chatModel.chatItemsSectionArea.remove(it.id)
}
chatModel.chatItems.removeAll { chatModel.chatItemsSectionArea[it.id] == null }
val newIdx = reversedChatItems.value.indexOfFirst { it.id == itemId }
listState.scrollToItem(scrollPosition.value(newIdx), -maxHeight.value)
}
}
preloadItemsEnabled.value = true
}
} catch (ex: Exception) {
preloadItemsEnabled.value = true
}
}
}
)
})
}
// TODO: Having this block on desktop makes ChatItemsList() to recompose twice on chatModel.chatId update instead of once
LaunchedEffect(chatInfo.id) {
@@ -993,23 +1100,14 @@ fun BoxScope.ChatItemsList(
VideoPlayerHolder.releaseAll()
}
)
LazyColumnWithScrollBar(
Modifier.align(Alignment.BottomCenter),
state = listState,
reverseLayout = true,
contentPadding = PaddingValues(
top = topPaddingToContent(),
bottom = composeViewHeight.value
),
additionalBarOffset = composeViewHeight
) {
itemsIndexed(reversedChatItems.value, key = { _, item -> item.id to item.meta.createdAt.toEpochMilliseconds() }) { i, cItem ->
val itemScope = rememberCoroutineScope()
@Composable
fun ChatViewListItem(i: Int, range: IntRange?, showAvatar: Boolean, cItem: ChatItem, prevItem: ChatItem?, nextItem: ChatItem?) {
CompositionLocalProvider(
// Makes horizontal and vertical scrolling to coexist nicely.
// With default touchSlop when you scroll LazyColumn, you can unintentionally open reply view
LocalViewConfiguration provides LocalViewConfiguration.current.bigTouchSlop()
) {
val itemScope = rememberCoroutineScope()
val provider = {
providerForGallery(i, chatModel.chatItems.value, cItem.id) { indexInReversed ->
itemScope.launch {
@@ -1021,246 +1119,293 @@ fun BoxScope.ChatItemsList(
}
}
val revealed = remember { mutableStateOf(false) }
val revealed = remember { mutableStateOf(revealedItems.value.contains(cItem.id)) }
KeyChangeEffect(revealed.value) {
val revealIds = if (range == null) setOf(cItem.id) else reversedChatItems.value.subList(range.first, range.last + 1).map { it.id }.toSet()
if (revealIds.isNotEmpty()) {
if (revealed.value) {
revealedItems.value = revealedItems.value.toMutableSet().apply { addAll(revealIds) }
} else {
revealedItems.value = revealedItems.value.toMutableSet().apply { removeAll(revealIds) }
}
}
}
@Composable
fun ChatItemViewShortHand(cItem: ChatItem, itemSeparation: ItemSeparation, range: IntRange?, fillMaxWidth: Boolean = true) {
tryOrShowError("${cItem.id}ChatItem", error = {
CIBrokenComposableView(if (cItem.chatDir.sent) Alignment.CenterEnd else Alignment.CenterStart)
}) {
ChatItemView(remoteHostId, chatInfo, cItem, composeState, provider, useLinkPreviews = useLinkPreviews, linkMode = linkMode, revealed = revealed, range = range, fillMaxWidth = fillMaxWidth, selectedChatItems = selectedChatItems, selectChatItem = { selectUnselectChatItem(true, cItem, revealed, selectedChatItems) }, deleteMessage = deleteMessage, deleteMessages = deleteMessages, receiveFile = receiveFile, cancelFile = cancelFile, joinGroup = joinGroup, acceptCall = acceptCall, acceptFeature = acceptFeature, openDirectChat = openDirectChat, forwardItem = forwardItem, updateContactStats = updateContactStats, updateMemberStats = updateMemberStats, syncContactConnection = syncContactConnection, syncMemberConnection = syncMemberConnection, findModelChat = findModelChat, findModelMember = findModelMember, scrollToItem = scrollToItem.value, setReaction = setReaction, showItemDetails = showItemDetails, developerTools = developerTools, showViaProxy = showViaProxy, itemSeparation = itemSeparation, showTimestamp = itemSeparation.timestamp)
}
}
@Composable
fun ChatItemView(cItem: ChatItem, range: IntRange?, prevItem: ChatItem?, itemSeparation: ItemSeparation, previousItemSeparation: ItemSeparation?) {
val dismissState = rememberDismissState(initialValue = DismissValue.Default) {
if (it == DismissValue.DismissedToStart) {
itemScope.launch {
if ((cItem.content is CIContent.SndMsgContent || cItem.content is CIContent.RcvMsgContent) && chatInfo !is ChatInfo.Local) {
if (composeState.value.editing) {
composeState.value = ComposeState(contextItem = ComposeContextItem.QuotedItem(cItem), useLinkPreviews = useLinkPreviews)
} else if (cItem.id != ChatItem.TEMP_LIVE_CHAT_ITEM_ID) {
composeState.value = composeState.value.copy(contextItem = ComposeContextItem.QuotedItem(cItem))
}
}
}
}
false
}
val swipeableModifier = SwipeToDismissModifier(
state = dismissState,
directions = setOf(DismissDirection.EndToStart),
swipeDistance = with(LocalDensity.current) { 30.dp.toPx() },
)
val sent = cItem.chatDir.sent
@Composable
fun ChatItemViewShortHand(cItem: ChatItem, itemSeparation: ItemSeparation, range: IntRange?, fillMaxWidth: Boolean = true) {
tryOrShowError("${cItem.id}ChatItem", error = {
CIBrokenComposableView(if (cItem.chatDir.sent) Alignment.CenterEnd else Alignment.CenterStart)
}) {
ChatItemView(remoteHostId, chatInfo, cItem, composeState, provider, useLinkPreviews = useLinkPreviews, linkMode = linkMode, revealed = revealed, range = range, fillMaxWidth = fillMaxWidth, selectedChatItems = selectedChatItems, selectChatItem = { selectUnselectChatItem(true, cItem, revealed, selectedChatItems) }, deleteMessage = deleteMessage, deleteMessages = deleteMessages, receiveFile = receiveFile, cancelFile = cancelFile, joinGroup = joinGroup, acceptCall = acceptCall, acceptFeature = acceptFeature, openDirectChat = openDirectChat, forwardItem = forwardItem, updateContactStats = updateContactStats, updateMemberStats = updateMemberStats, syncContactConnection = syncContactConnection, syncMemberConnection = syncMemberConnection, findModelChat = findModelChat, findModelMember = findModelMember, scrollToItem = scrollToItem.value, setReaction = setReaction, showItemDetails = showItemDetails, developerTools = developerTools, showViaProxy = showViaProxy, itemSeparation = itemSeparation, showTimestamp = itemSeparation.timestamp)
fun ChatItemBox(modifier: Modifier = Modifier, content: @Composable () -> Unit = { }) {
Box(
modifier = modifier.padding(
bottom = if (itemSeparation.largeGap) {
if (i == 0) {
8.dp
} else {
4.dp
}
} else 1.dp, top = if (previousItemSeparation?.largeGap == true) 4.dp else 1.dp
),
contentAlignment = Alignment.CenterStart
) {
content()
}
}
@Composable
fun ChatItemView(cItem: ChatItem, range: IntRange?, prevItem: ChatItem?, itemSeparation: ItemSeparation, previousItemSeparation: ItemSeparation?) {
val dismissState = rememberDismissState(initialValue = DismissValue.Default) {
if (it == DismissValue.DismissedToStart) {
itemScope.launch {
if ((cItem.content is CIContent.SndMsgContent || cItem.content is CIContent.RcvMsgContent) && chatInfo !is ChatInfo.Local) {
if (composeState.value.editing) {
composeState.value = ComposeState(contextItem = ComposeContextItem.QuotedItem(cItem), useLinkPreviews = useLinkPreviews)
} else if (cItem.id != ChatItem.TEMP_LIVE_CHAT_ITEM_ID) {
composeState.value = composeState.value.copy(contextItem = ComposeContextItem.QuotedItem(cItem))
}
fun adjustTailPaddingOffset(originalPadding: Dp, start: Boolean): Dp {
val chatItemTail = remember { appPreferences.chatItemTail.state }
val style = shapeStyle(cItem, chatItemTail.value, itemSeparation.largeGap, true)
val tailRendered = style is ShapeStyle.Bubble && style.tailVisible
return originalPadding + (if (tailRendered) 0.dp else if (start) msgTailWidthDp * 2 else msgTailWidthDp)
}
Box {
val voiceWithTransparentBack = cItem.content.msgContent is MsgContent.MCVoice && cItem.content.text.isEmpty() && cItem.quotedItem == null && cItem.meta.itemForwarded == null
val selectionVisible = selectedChatItems.value != null && cItem.canBeDeletedForSelf
val selectionOffset by animateDpAsState(if (selectionVisible && !sent) 4.dp + 22.dp * fontSizeMultiplier else 0.dp)
val swipeableOrSelectionModifier = (if (selectionVisible) Modifier else swipeableModifier).graphicsLayer { translationX = selectionOffset.toPx() }
if (chatInfo is ChatInfo.Group) {
if (cItem.chatDir is CIDirection.GroupRcv) {
val member = cItem.chatDir.groupMember
val (prevMember, memCount) =
if (range != null) {
chatModel.getPrevHiddenMember(member, range)
} else {
null to 1
}
}
}
false
}
val swipeableModifier = SwipeToDismissModifier(
state = dismissState,
directions = setOf(DismissDirection.EndToStart),
swipeDistance = with(LocalDensity.current) { 30.dp.toPx() },
)
val sent = cItem.chatDir.sent
@Composable
fun ChatItemBox(modifier: Modifier = Modifier, content: @Composable () -> Unit = { }) {
Box(
modifier = modifier.padding(
bottom = if (itemSeparation.largeGap) {
if (i == 0) {
8.dp
} else {
4.dp
}
} else 1.dp, top = if (previousItemSeparation?.largeGap == true) 4.dp else 1.dp
),
contentAlignment = Alignment.CenterStart
) {
content()
}
}
if (showMemberImage(member, prevItem) || showAvatar) {
Column(
Modifier
.padding(top = 8.dp)
.padding(start = 8.dp, end = if (voiceWithTransparentBack) 12.dp else adjustTailPaddingOffset(66.dp, start = false))
.fillMaxWidth()
.then(swipeableModifier),
verticalArrangement = Arrangement.spacedBy(4.dp),
horizontalAlignment = Alignment.Start
) {
@Composable
fun MemberNameAndRole() {
Row(Modifier.padding(bottom = 2.dp).graphicsLayer { translationX = selectionOffset.toPx() }, horizontalArrangement = Arrangement.SpaceBetween) {
Text(
memberNames(member, prevMember, memCount),
Modifier
.padding(start = (MEMBER_IMAGE_SIZE * fontSizeSqrtMultiplier) + DEFAULT_PADDING_HALF)
.weight(1f, false),
fontSize = 13.5.sp,
color = MaterialTheme.colors.secondary,
overflow = TextOverflow.Ellipsis,
maxLines = 1
)
if (memCount == 1 && member.memberRole > GroupMemberRole.Member) {
val chatItemTail = remember { appPreferences.chatItemTail.state }
val style = shapeStyle(cItem, chatItemTail.value, itemSeparation.largeGap, true)
val tailRendered = style is ShapeStyle.Bubble && style.tailVisible
@Composable
fun adjustTailPaddingOffset(originalPadding: Dp, start: Boolean): Dp {
val chatItemTail = remember { appPreferences.chatItemTail.state }
val style = shapeStyle(cItem, chatItemTail.value, itemSeparation.largeGap, true)
val tailRendered = style is ShapeStyle.Bubble && style.tailVisible
return originalPadding + (if (tailRendered) 0.dp else if (start) msgTailWidthDp * 2 else msgTailWidthDp)
}
Box {
val voiceWithTransparentBack = cItem.content.msgContent is MsgContent.MCVoice && cItem.content.text.isEmpty() && cItem.quotedItem == null && cItem.meta.itemForwarded == null
val selectionVisible = selectedChatItems.value != null && cItem.canBeDeletedForSelf
val selectionOffset by animateDpAsState(if (selectionVisible && !sent) 4.dp + 22.dp * fontSizeMultiplier else 0.dp)
val swipeableOrSelectionModifier = (if (selectionVisible) Modifier else swipeableModifier).graphicsLayer { translationX = selectionOffset.toPx() }
if (chatInfo is ChatInfo.Group) {
if (cItem.chatDir is CIDirection.GroupRcv) {
val member = cItem.chatDir.groupMember
val (prevMember, memCount) =
if (range != null) {
chatModel.getPrevHiddenMember(member, range)
} else {
null to 1
}
if (prevItem == null || showMemberImage(member, prevItem) || prevMember != null) {
Column(
Modifier
.padding(top = 8.dp)
.padding(start = 8.dp, end = if (voiceWithTransparentBack) 12.dp else adjustTailPaddingOffset(66.dp, start = false))
.fillMaxWidth()
.then(swipeableModifier),
verticalArrangement = Arrangement.spacedBy(4.dp),
horizontalAlignment = Alignment.Start
) {
@Composable
fun MemberNameAndRole() {
Row(Modifier.padding(bottom = 2.dp).graphicsLayer { translationX = selectionOffset.toPx() }, horizontalArrangement = Arrangement.SpaceBetween) {
Text(
memberNames(member, prevMember, memCount),
Modifier
.padding(start = (MEMBER_IMAGE_SIZE * fontSizeSqrtMultiplier) + DEFAULT_PADDING_HALF)
.weight(1f, false),
member.memberRole.text,
Modifier.padding(start = DEFAULT_PADDING_HALF * 1.5f, end = DEFAULT_PADDING_HALF + if (tailRendered) msgTailWidthDp else 0.dp),
fontSize = 13.5.sp,
fontWeight = FontWeight.Medium,
color = MaterialTheme.colors.secondary,
overflow = TextOverflow.Ellipsis,
maxLines = 1
)
if (memCount == 1 && member.memberRole > GroupMemberRole.Member) {
val chatItemTail = remember { appPreferences.chatItemTail.state }
val style = shapeStyle(cItem, chatItemTail.value, itemSeparation.largeGap, true)
val tailRendered = style is ShapeStyle.Bubble && style.tailVisible
Text(
member.memberRole.text,
Modifier.padding(start = DEFAULT_PADDING_HALF * 1.5f, end = DEFAULT_PADDING_HALF + if (tailRendered) msgTailWidthDp else 0.dp),
fontSize = 13.5.sp,
fontWeight = FontWeight.Medium,
color = MaterialTheme.colors.secondary,
maxLines = 1
)
}
}
}
@Composable
fun Item() {
ChatItemBox(Modifier.layoutId(CHAT_BUBBLE_LAYOUT_ID)) {
androidx.compose.animation.AnimatedVisibility(selectionVisible, enter = fadeIn(), exit = fadeOut()) {
SelectedChatItem(Modifier, cItem.id, selectedChatItems)
}
Row(Modifier.graphicsLayer { translationX = selectionOffset.toPx() }) {
Box(Modifier.clickable { showMemberInfo(chatInfo.groupInfo, member) }) {
MemberImage(member)
}
Box(modifier = Modifier.padding(top = 2.dp, start = 4.dp).chatItemOffset(cItem, itemSeparation.largeGap, revealed = revealed.value)) {
ChatItemViewShortHand(cItem, itemSeparation, range, false)
}
}
}
}
if (cItem.content.showMemberName) {
DependentLayout(Modifier, CHAT_BUBBLE_LAYOUT_ID) {
MemberNameAndRole()
Item()
}
} else {
Item()
}
}
} else {
ChatItemBox {
AnimatedVisibility (selectionVisible, enter = fadeIn(), exit = fadeOut()) {
SelectedChatItem(Modifier.padding(start = 8.dp), cItem.id, selectedChatItems)
@Composable
fun Item() {
ChatItemBox(Modifier.layoutId(CHAT_BUBBLE_LAYOUT_ID)) {
androidx.compose.animation.AnimatedVisibility(selectionVisible, enter = fadeIn(), exit = fadeOut()) {
SelectedChatItem(Modifier, cItem.id, selectedChatItems)
}
Row(Modifier.graphicsLayer { translationX = selectionOffset.toPx() }) {
Box(Modifier.clickable { showMemberInfo(chatInfo.groupInfo, member) }) {
MemberImage(member)
}
Box(modifier = Modifier.padding(top = 2.dp, start = 4.dp).chatItemOffset(cItem, itemSeparation.largeGap, revealed = revealed.value)) {
ChatItemViewShortHand(cItem, itemSeparation, range, false)
}
}
}
Row(
Modifier
.padding(start = 8.dp + (MEMBER_IMAGE_SIZE * fontSizeSqrtMultiplier) + 4.dp, end = if (voiceWithTransparentBack) 12.dp else adjustTailPaddingOffset(66.dp, start = false))
.chatItemOffset(cItem, itemSeparation.largeGap, revealed = revealed.value)
.then(swipeableOrSelectionModifier)
) {
ChatItemViewShortHand(cItem, itemSeparation, range)
}
if (cItem.content.showMemberName) {
DependentLayout(Modifier, CHAT_BUBBLE_LAYOUT_ID) {
MemberNameAndRole()
Item()
}
} else {
Item()
}
}
} else {
ChatItemBox {
AnimatedVisibility (selectionVisible, enter = fadeIn(), exit = fadeOut()) {
AnimatedVisibility(selectionVisible, enter = fadeIn(), exit = fadeOut()) {
SelectedChatItem(Modifier.padding(start = 8.dp), cItem.id, selectedChatItems)
}
Box(
Row(
Modifier
.padding(start = if (voiceWithTransparentBack) 12.dp else adjustTailPaddingOffset(104.dp, start = true), end = 12.dp)
.padding(start = 8.dp + (MEMBER_IMAGE_SIZE * fontSizeSqrtMultiplier) + 4.dp, end = if (voiceWithTransparentBack) 12.dp else adjustTailPaddingOffset(66.dp, start = false))
.chatItemOffset(cItem, itemSeparation.largeGap, revealed = revealed.value)
.then(if (selectionVisible) Modifier else swipeableModifier)
.then(swipeableOrSelectionModifier)
) {
ChatItemViewShortHand(cItem, itemSeparation, range)
}
}
}
} else { // direct message
} else {
ChatItemBox {
AnimatedVisibility (selectionVisible, enter = fadeIn(), exit = fadeOut()) {
AnimatedVisibility(selectionVisible, enter = fadeIn(), exit = fadeOut()) {
SelectedChatItem(Modifier.padding(start = 8.dp), cItem.id, selectedChatItems)
}
Box(
Modifier.padding(
start = if (sent && !voiceWithTransparentBack) adjustTailPaddingOffset(76.dp, start = true) else 12.dp,
end = if (sent || voiceWithTransparentBack) 12.dp else adjustTailPaddingOffset(76.dp, start = false),
)
Modifier
.padding(start = if (voiceWithTransparentBack) 12.dp else adjustTailPaddingOffset(104.dp, start = true), end = 12.dp)
.chatItemOffset(cItem, itemSeparation.largeGap, revealed = revealed.value)
.then(if (!selectionVisible || !sent) swipeableOrSelectionModifier else Modifier)
.then(if (selectionVisible) Modifier else swipeableModifier)
) {
ChatItemViewShortHand(cItem, itemSeparation, range)
}
}
}
if (selectionVisible) {
Box(Modifier.matchParentSize().clickable {
val checked = selectedChatItems.value?.contains(cItem.id) == true
selectUnselectChatItem(select = !checked, cItem, revealed, selectedChatItems)
})
} else { // direct message
ChatItemBox {
AnimatedVisibility(selectionVisible, enter = fadeIn(), exit = fadeOut()) {
SelectedChatItem(Modifier.padding(start = 8.dp), cItem.id, selectedChatItems)
}
Box(
Modifier.padding(
start = if (sent && !voiceWithTransparentBack) adjustTailPaddingOffset(76.dp, start = true) else 12.dp,
end = if (sent || voiceWithTransparentBack) 12.dp else adjustTailPaddingOffset(76.dp, start = false),
)
.chatItemOffset(cItem, itemSeparation.largeGap, revealed = revealed.value)
.then(if (!selectionVisible || !sent) swipeableOrSelectionModifier else Modifier)
) {
ChatItemViewShortHand(cItem, itemSeparation, range)
}
}
}
}
val (currIndex, nextItem) = chatModel.getNextChatItem(cItem)
val ciCategory = cItem.mergeCategory
if (ciCategory != null && ciCategory == nextItem?.mergeCategory) {
// memberConnected events and deleted items are aggregated at the last chat item in a row, see ChatItemView
} else {
val (prevHidden, prevItem) = chatModel.getPrevShownChatItem(currIndex, ciCategory)
val itemSeparation = getItemSeparation(cItem, nextItem)
val previousItemSeparation = if (prevItem != null) getItemSeparation(prevItem, cItem) else null
if (itemSeparation.date != null) {
DateSeparator(itemSeparation.date)
if (selectionVisible) {
Box(Modifier.matchParentSize().clickable {
val checked = selectedChatItems.value?.contains(cItem.id) == true
selectUnselectChatItem(select = !checked, cItem, revealed, selectedChatItems)
})
}
}
}
val range = chatViewItemsRange(currIndex, prevHidden)
val reversed = reversedChatItems.value
if (revealed.value && range != null) {
reversed.subList(range.first, range.last + 1).forEachIndexed { index, ci ->
val prev = if (index + range.first == prevHidden) prevItem else reversed[index + range.first + 1]
ChatItemView(ci, null, prev, itemSeparation, previousItemSeparation)
if (cItem.isRcvNew && chatInfo.id == ChatModel.chatId.value) {
LaunchedEffect(cItem.id) {
itemScope.launch {
delay(600)
val itemRange = if (range != null) {
val firstItem = reversedChatItems.value.getOrNull(range.first)
val lastItem = reversedChatItems.value.getOrNull(range.last)
if (lastItem != null && firstItem != null) {
CC.ItemRange(lastItem.id, firstItem.id)
} else {
null
}
} else {
CC.ItemRange(cItem.id, cItem.id)
}
} else {
ChatItemView(cItem, range, prevItem, itemSeparation, previousItemSeparation)
}
if (i == reversed.lastIndex) {
DateSeparator(cItem.meta.itemTs)
}
}
if (cItem.isRcvNew && chatInfo.id == ChatModel.chatId.value) {
LaunchedEffect(cItem.id) {
itemScope.launch {
delay(600)
markRead(CC.ItemRange(cItem.id, cItem.id), null)
if (itemRange != null) {
markRead(itemRange, null)
}
}
}
}
val itemSeparation = getItemSeparation(cItem, nextItem)
val previousItemSeparation = if (prevItem != null) getItemSeparation(prevItem, cItem) else null
if (itemSeparation.date != null) {
DateSeparator(itemSeparation.date)
}
ChatItemView(cItem, range, prevItem, itemSeparation, previousItemSeparation)
}
}
LazyColumnWithScrollBar(
Modifier.align(Alignment.BottomCenter),
state = listState,
reverseLayout = true,
contentPadding = PaddingValues(
top = topPaddingToContent(),
bottom = composeViewHeight.value
),
additionalBarOffset = composeViewHeight
) {
for (area in sections.value) {
for ((sIdx, section) in area.items.withIndex()) {
if (section.revealed) {
itemsIndexed(section.items, key = { _, item -> item.id to item.meta.createdAt.toEpochMilliseconds() }) { i, cItem ->
// index here is just temporary, should be removed at all or put in the section items
val prevItem = area.getPreviousShownItem(sIdx, i)
val nextItem = area.getNextShownItem(sIdx, i)
ChatViewListItem(area.itemPositions[cItem.id] ?: -1, section.originalItemsRange.takeIf { cItem.mergeCategory != null }, section.showAvatar.contains(cItem.id), cItem, prevItem, nextItem, )
}
} else {
val item = section.items.first()
item(key = item.id to item.meta.createdAt.toEpochMilliseconds()) {
// here you make one collapsed item from multiple items (should be already in section items)
val prevItem = area.getPreviousShownItem(sIdx, section.items.lastIndex)
val nextItem = area.getNextShownItem(sIdx, section.items.lastIndex)
ChatViewListItem(area.itemPositions[item.id] ?: -1, section.originalItemsRange, section.showAvatar.contains(item.id), item, prevItem, nextItem)
}
}
}
}
if (reversedChatItems.value.isNotEmpty()) {
item {
DateSeparator(reversedChatItems.value.last().meta.itemTs)
}
}
}
FloatingButtons(chatModel.chatItems, unreadCount, composeViewHeight, remoteHostId, chatInfo, searchValue, markRead, listState) {
preloadItemsEnabled.value = false
scope.launch {
listState.animateScrollToItem(0)
preloadItemsEnabled.value = true
sections.value.dropTemporarySections()
}
}
FloatingButtons(chatModel.chatItems, unreadCount, composeViewHeight, remoteHostId, chatInfo, searchValue, markRead, listState)
FloatingDate(
Modifier.padding(top = 10.dp + topPaddingToContent()).align(Alignment.TopCenter),
@@ -1276,13 +1421,13 @@ fun BoxScope.ChatItemsList(
}
@Composable
private fun ScrollToBottom(chatId: ChatId, listState: LazyListState, chatItems: State<List<ChatItem>>) {
private fun ScrollToBottom(chatId: ChatId, listState: LazyListState, chatItems: State<List<ChatItem>>, enabled: State<Boolean>) {
val scope = rememberCoroutineScope()
// Helps to scroll to bottom after moving from Group to Direct chat
// and prevents scrolling to bottom on orientation change
var shouldAutoScroll by rememberSaveable { mutableStateOf(true to chatId) }
LaunchedEffect(chatId, shouldAutoScroll) {
if ((shouldAutoScroll.first || shouldAutoScroll.second != chatId) && listState.firstVisibleItemIndex != 0) {
if ((shouldAutoScroll.first || shouldAutoScroll.second != chatId) && listState.firstVisibleItemIndex != 0 && enabled.value) {
scope.launch { listState.scrollToItem(0) }
}
// Don't autoscroll next time until it will be needed
@@ -1296,7 +1441,7 @@ private fun ScrollToBottom(chatId: ChatId, listState: LazyListState, chatItems:
LaunchedEffect(Unit) {
snapshotFlow { chatItems.value.lastOrNull()?.id }
.distinctUntilChanged()
.filter { listState.layoutInfo.visibleItemsInfo.firstOrNull()?.key != it }
.filter { listState.layoutInfo.visibleItemsInfo.firstOrNull()?.key != it && enabled.value }
.collect {
try {
if (listState.firstVisibleItemIndex == 0 || (listState.firstVisibleItemIndex == 1 && listState.layoutInfo.totalItemsCount == chatItems.value.size)) {
@@ -1326,7 +1471,8 @@ fun BoxScope.FloatingButtons(
chatInfo: ChatInfo,
searchValue: State<String>,
markRead: (CC.ItemRange, unreadCountAfter: Int?) -> Unit,
listState: LazyListState
listState: LazyListState,
scrollToLatestItem: () -> Unit
) {
val scope = rememberCoroutineScope()
val maxHeight = remember { derivedStateOf { listState.layoutInfo.viewportSize.height } }
@@ -1348,9 +1494,7 @@ fun BoxScope.FloatingButtons(
showBottomButtonWithCounter,
showBottomButtonWithArrow,
composeViewHeight,
onClickArrowDown = {
scope.launch { listState.animateScrollToItem(0) }
},
onClickArrowDown = scrollToLatestItem,
onClickCounter = {
val firstVisibleOffset = (-maxHeight.value * 0.8).toInt()
scope.launch { listState.animateScrollToItem(kotlin.math.max(0, bottomUnreadCount.value - 1), firstVisibleOffset) }
@@ -1397,12 +1541,35 @@ fun PreloadItems(
chatId: String,
listState: LazyListState,
remaining: Int = 10,
onLoadMore: (ChatId) -> Unit,
enabled: State<Boolean>,
boundaries: State<List<ChatSectionAreaBoundary>>,
onLoadMore: (ChatId, ScrollDirection, Triple<Long, Int, ChatSectionArea>) -> Unit,
) {
// Prevent situation when initial load and load more happens one after another after selecting a chat with long scroll position from previous selection
val allowLoad = remember { mutableStateOf(false) }
val chatId = rememberUpdatedState(chatId)
val onLoadMore = rememberUpdatedState(onLoadMore)
var scrollDirection by remember { mutableStateOf(ScrollDirection.Idle) }
var previousIndex by remember { mutableStateOf(0) }
var previousScrollOffset by remember { mutableStateOf(0) }
LaunchedEffect(listState.firstVisibleItemIndex, listState.firstVisibleItemScrollOffset) {
val currentIndex = listState.firstVisibleItemIndex
val currentScrollOffset = listState.firstVisibleItemScrollOffset
val threshold = 25
scrollDirection = when {
currentIndex > previousIndex -> ScrollDirection.Up
currentIndex < previousIndex -> ScrollDirection.Down
currentScrollOffset > previousScrollOffset + threshold -> ScrollDirection.Up
currentScrollOffset < previousScrollOffset - threshold -> ScrollDirection.Down
currentScrollOffset == previousScrollOffset -> ScrollDirection.Idle
else -> scrollDirection
}
previousIndex = currentIndex
previousScrollOffset = currentScrollOffset
}
LaunchedEffect(Unit) {
snapshotFlow { chatId.value }
.filterNotNull()
@@ -1412,19 +1579,41 @@ fun PreloadItems(
allowLoad.value = true
}
}
KeyChangeEffect(allowLoad.value) {
KeyChangeEffect(allowLoad.value, enabled.value) {
snapshotFlow {
val lInfo = listState.layoutInfo
val totalItemsNumber = lInfo.totalItemsCount
val lastVisibleItemIndex = (lInfo.visibleItemsInfo.lastOrNull()?.index ?: 0) + 1
if (allowLoad.value && lastVisibleItemIndex > (totalItemsNumber - remaining) && totalItemsNumber >= ChatPagination.INITIAL_COUNT)
totalItemsNumber + ChatPagination.PRELOAD_COUNT
else
0
val section = if (scrollDirection == ScrollDirection.Up) {
boundaries.value.find { lastVisibleItemIndex in it.minIndex..it.maxIndex }
} else if (scrollDirection == ScrollDirection.Down) {
boundaries.value.find { listState.firstVisibleItemIndex in it.minIndex..it.maxIndex }
} else {
null
}
val request = if (allowLoad.value && section != null && enabled.value) {
val itemIdx = when {
scrollDirection == ScrollDirection.Up && lastVisibleItemIndex > (section.maxIndex - remaining) -> {
chatModel.chatItems.size - 1 - section.maxIndex
}
scrollDirection == ScrollDirection.Down && section.area != ChatSectionArea.Bottom && listState.firstVisibleItemIndex < (section.minIndex + remaining) && totalItemsNumber > remaining -> {
chatModel.chatItems.size - 1 - section.minIndex
}
else -> null
}
val itemId = itemIdx?.let { chatModel.chatItems.value.getOrNull(it)?.id }
itemId?.let { Triple(it, itemIdx, section.area) }
} else {
null
}
request
}
.filter { it > 0 }
.distinctUntilChanged()
.filterNotNull()
.collect {
onLoadMore.value(chatId.value)
onLoadMore.value(chatId.value, scrollDirection, it)
}
}
}
@@ -2102,7 +2291,7 @@ fun PreviewChatLayout() {
back = {},
info = {},
showMemberInfo = { _, _ -> },
loadPrevMessages = {},
loadMessages = { _, _, _ -> },
deleteMessage = { _, _ -> },
deleteMessages = { _ -> },
receiveFile = { _ -> },
@@ -2174,7 +2363,7 @@ fun PreviewGroupChatLayout() {
back = {},
info = {},
showMemberInfo = { _, _ -> },
loadPrevMessages = {},
loadMessages = { _, _, _ -> },
deleteMessage = { _, _ -> },
deleteMessages = {},
receiveFile = { _ -> },
@@ -70,8 +70,9 @@ fun GroupMemberInfoView(
getContactChat = { chatModel.getContactChat(it) },
openDirectChat = {
withBGApi {
val c = chatModel.controller.apiGetChat(rhId, ChatType.Direct, it)
if (c != null) {
val r = chatModel.controller.apiGetChat(rhId, ChatType.Direct, it, ChatPagination.Initial(ChatPagination.INITIAL_COUNT))
if (r != null) {
val (c) = r
withChats {
if (chatModel.getContactChat(it) == null) {
addChat(c)
@@ -129,7 +129,13 @@ fun FramedItemView(
.fillMaxWidth()
.combinedClickable(
onLongClick = { showMenu.value = true },
onClick = { scrollToItem(qi.itemId?: return@combinedClickable) }
onClick = {
if (qi.itemId == null) {
AlertManager.shared.showAlertMsg(generalGetString(MR.strings.failed_to_get_chat_item_not_found_title), generalGetString(MR.strings.failed_to_get_chat_item_not_found_description))
} else {
scrollToItem(qi.itemId)
}
}
)
.onRightClick { showMenu.value = true }
) {
@@ -1,7 +1,6 @@
package chat.simplex.common.views.chatlist
import SectionItemView
import androidx.compose.animation.core.animateFloatAsState
import androidx.compose.foundation.layout.*
import androidx.compose.material.*
import androidx.compose.runtime.*
@@ -32,6 +31,7 @@ import chat.simplex.common.views.helpers.*
import chat.simplex.common.views.newchat.*
import chat.simplex.res.MR
import kotlinx.coroutines.*
import kotlinx.coroutines.flow.map
import kotlinx.datetime.Clock
@Composable
@@ -204,43 +204,56 @@ suspend fun noteFolderChatAction(rhId: Long?, noteFolder: NoteFolder) {
}
suspend fun openDirectChat(rhId: Long?, contactId: Long, chatModel: ChatModel) = coroutineScope {
val chat = chatModel.controller.apiGetChat(rhId, ChatType.Direct, contactId)
val chat = chatModel.controller.apiGetChat(rhId, ChatType.Direct, contactId, ChatPagination.Initial(ChatPagination.INITIAL_COUNT))
if (chat != null && isActive) {
openLoadedChat(chat, chatModel)
openLoadedChat(chat.first, chatModel, chat.second)
}
}
suspend fun openGroupChat(rhId: Long?, groupId: Long, chatModel: ChatModel) = coroutineScope {
val chat = chatModel.controller.apiGetChat(rhId, ChatType.Group, groupId)
val chat = chatModel.controller.apiGetChat(rhId, ChatType.Group, groupId, ChatPagination.Initial(ChatPagination.INITIAL_COUNT))
if (chat != null && isActive) {
openLoadedChat(chat, chatModel)
openLoadedChat(chat.first, chatModel, chat.second)
}
}
suspend fun openChat(rhId: Long?, chatInfo: ChatInfo, chatModel: ChatModel) = coroutineScope {
val chat = chatModel.controller.apiGetChat(rhId, chatInfo.chatType, chatInfo.apiId)
val chat = chatModel.controller.apiGetChat(rhId, chatInfo.chatType, chatInfo.apiId, ChatPagination.Initial(ChatPagination.INITIAL_COUNT))
if (chat != null && isActive) {
openLoadedChat(chat, chatModel)
openLoadedChat(chat.first, chatModel, chat.second)
}
}
fun openLoadedChat(chat: Chat, chatModel: ChatModel) {
fun openLoadedChat(chat: Chat, chatModel: ChatModel, landingSection: ChatLandingSection = ChatLandingSection.Latest) {
chatModel.chatItemStatuses.clear()
chatModel.chatItems.replaceAll(chat.chatItems)
chatModel.chatId.value = chat.chatInfo.id
chatModel.chatItemsSectionArea.clear()
chatModel.chatItems.value.associateTo(chatModel.chatItemsSectionArea) { it.id to landingSectionToArea(landingSection) }
}
suspend fun apiLoadPrevMessages(ch: Chat, chatModel: ChatModel, beforeChatItemId: Long, search: String) {
val chatInfo = ch.chatInfo
val pagination = ChatPagination.Before(beforeChatItemId, ChatPagination.PRELOAD_COUNT)
val chat = chatModel.controller.apiGetChat(ch.remoteHostId, chatInfo.chatType, chatInfo.apiId, pagination, search) ?: return
suspend fun apiLoadMessages(
rhId: Long?,
chatInfo: ChatInfo,
chatModel: ChatModel,
itemId: Long,
search: String,
chatSectionLoader: ChatSectionLoader,
pagination: ChatPagination = ChatPagination.Before(itemId, ChatPagination.PRELOAD_COUNT)
) {
val (chat) = chatModel.controller.apiGetChat(rhId, chatInfo.chatType, chatInfo.apiId, pagination, search) ?: return
if (chatModel.chatId.value != chat.id) return
chatModel.chatItems.addAll(0, chat.chatItems)
withContext(Dispatchers.Main) {
val itemsToAdd = chatSectionLoader.prepareItems(chat.chatItems)
if (itemsToAdd.isNotEmpty()) {
chatModel.chatItems.addAll(chatSectionLoader.position, itemsToAdd)
}
}
}
suspend fun apiFindMessages(ch: Chat, chatModel: ChatModel, search: String) {
val chatInfo = ch.chatInfo
val chat = chatModel.controller.apiGetChat(ch.remoteHostId, chatInfo.chatType, chatInfo.apiId, search = search) ?: return
val (chat) = chatModel.controller.apiGetChat(ch.remoteHostId, chatInfo.chatType, chatInfo.apiId, search = search) ?: return
if (chatModel.chatId.value != chat.id) return
chatModel.chatItems.replaceAll(chat.chatItems)
}
@@ -105,7 +105,7 @@ class ModalManager(private val placement: ModalPlacement? = null) {
// Means, animation is in progress or not started yet. Do not wait until animation finishes, just remove all from screen.
// This is useful when invoking close() and ShowCustomModal one after another without delay. Otherwise, screen will hold prev view
if (toRemove.isNotEmpty()) {
runAtomically { toRemove.removeIf { elem -> modalViews.removeAt(elem); true } }
runAtomically { toRemove.removeAll { elem -> modalViews.removeAt(elem); true } }
}
// Make animated appearance only on Android (everytime) and on Desktop (when it's on the start part of the screen or modals > 0)
// to prevent unneeded animation on different situations
@@ -184,7 +184,7 @@ class ModalManager(private val placement: ModalPlacement? = null) {
}
// This is needed because if we delete from modalViews immediately on request, animation will be bad
if (toRemove.isNotEmpty() && it == modalCount.value && transition.currentState == EnterExitState.Visible && !transition.isRunning) {
runAtomically { toRemove.removeIf { elem -> modalViews.removeAt(elem); true } }
runAtomically { toRemove.removeAll { elem -> modalViews.removeAt(elem); true } }
}
}
}
@@ -101,6 +101,8 @@
<string name="error_loading_xftp_servers">Error loading XFTP servers</string>
<string name="error_setting_network_config">Error updating network configuration</string>
<string name="failed_to_parse_chat_title">Failed to load chat</string>
<string name="failed_to_get_chat_item_not_found_title">Message no longer available</string>
<string name="failed_to_get_chat_item_not_found_description">The quoted message you are trying to access has been deleted.</string>
<string name="failed_to_parse_chats_title">Failed to load chats</string>
<string name="contact_developers">Please update the app and contact developers.</string>
<string name="failed_to_create_user_title">Error creating profile!</string>
+4 -6
View File
@@ -9,7 +9,6 @@ module Main where
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Chat.Bot
import Simplex.Chat.Controller
@@ -19,7 +18,6 @@ import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Options
import Simplex.Chat.Terminal (terminalChatConfig)
import Simplex.Chat.Types
import Simplex.Messaging.Util (tshow)
import System.Directory (getAppUserDataDirectory)
import Text.Read
@@ -36,7 +34,7 @@ welcomeGetOpts = do
putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
pure opts
welcomeMessage :: Text
welcomeMessage :: String
welcomeMessage = "Hello! I am a simple squaring bot.\nIf you send me a number, I will calculate its square"
mySquaringBot :: User -> ChatController -> IO ()
@@ -49,10 +47,10 @@ mySquaringBot _user cc = do
contactConnected contact
sendMessage cc contact welcomeMessage
CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) : _} -> do
let msg = ciContentToText mc
number_ = readMaybe (T.unpack msg) :: Maybe Integer
let msg = T.unpack $ ciContentToText mc
number_ = readMaybe msg :: Maybe Integer
sendMessage cc contact $ case number_ of
Just n -> msg <> " * " <> msg <> " = " <> tshow (n * n)
Just n -> msg <> " * " <> msg <> " = " <> show (n * n)
_ -> "\"" <> msg <> "\" is not a number"
_ -> pure ()
where
@@ -21,7 +21,6 @@ import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Types
import Simplex.Messaging.Util (tshow)
import System.Directory (getAppUserDataDirectory)
welcomeGetOpts :: IO BroadcastBotOpts
@@ -49,14 +48,14 @@ broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _u
CRContactsList _ cts -> void . forkIO $ do
let cts' = filter broadcastTo cts
forM_ cts' $ \ct' -> sendComposedMessage cc ct' Nothing mc
sendReply $ "Forwarded to " <> tshow (length cts') <> " contact(s)"
sendReply $ "Forwarded to " <> show (length cts') <> " contact(s)"
r -> putStrLn $ "Error getting contacts list: " <> show r
else sendReply "!1 Message is not supported!"
| otherwise -> do
sendReply prohibitedMessage
deleteMessage cc ct $ chatItemId' ci
where
sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . MCText
sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . textMsgContent
publisher = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
allowContent = \case
MCText _ -> True
@@ -7,7 +7,6 @@
module Broadcast.Options where
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Options.Applicative
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
@@ -16,14 +15,14 @@ import Simplex.Chat.Options (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, coreC
data BroadcastBotOpts = BroadcastBotOpts
{ coreOptions :: CoreChatOpts,
publishers :: [KnownContact],
welcomeMessage :: Text,
prohibitedMessage :: Text
welcomeMessage :: String,
prohibitedMessage :: String
}
defaultWelcomeMessage :: [KnownContact] -> Text
defaultWelcomeMessage :: [KnownContact] -> String
defaultWelcomeMessage ps = "Hello! I am a broadcast bot.\nI broadcast messages to all connected users from " <> knownContactNames ps <> "."
defaultProhibitedMessage :: [KnownContact] -> Text
defaultProhibitedMessage :: [KnownContact] -> String
defaultProhibitedMessage ps = "Sorry, only these users can broadcast messages: " <> knownContactNames ps <> ". Your message is deleted."
broadcastBotOpts :: FilePath -> FilePath -> Parser BroadcastBotOpts
@@ -89,11 +89,10 @@ crDirectoryEvent = \case
CRChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors)
_ -> Nothing
data DirectoryRole = DRUser | DRAdmin | DRSuperUser
data DirectoryRole = DRUser | DRSuperUser
data SDirectoryRole (r :: DirectoryRole) where
SDRUser :: SDirectoryRole 'DRUser
SDRAdmin :: SDirectoryRole 'DRAdmin
SDRSuperUser :: SDirectoryRole 'DRSuperUser
deriving instance Show (SDirectoryRole r)
@@ -108,14 +107,12 @@ data DirectoryCmdTag (r :: DirectoryRole) where
DCListUserGroups_ :: DirectoryCmdTag 'DRUser
DCDeleteGroup_ :: DirectoryCmdTag 'DRUser
DCSetRole_ :: DirectoryCmdTag 'DRUser
DCApproveGroup_ :: DirectoryCmdTag 'DRAdmin
DCRejectGroup_ :: DirectoryCmdTag 'DRAdmin
DCSuspendGroup_ :: DirectoryCmdTag 'DRAdmin
DCResumeGroup_ :: DirectoryCmdTag 'DRAdmin
DCListLastGroups_ :: DirectoryCmdTag 'DRAdmin
DCListPendingGroups_ :: DirectoryCmdTag 'DRAdmin
DCShowGroupLink_ :: DirectoryCmdTag 'DRAdmin
DCSendToGroupOwner_ :: DirectoryCmdTag 'DRAdmin
DCApproveGroup_ :: DirectoryCmdTag 'DRSuperUser
DCRejectGroup_ :: DirectoryCmdTag 'DRSuperUser
DCSuspendGroup_ :: DirectoryCmdTag 'DRSuperUser
DCResumeGroup_ :: DirectoryCmdTag 'DRSuperUser
DCListLastGroups_ :: DirectoryCmdTag 'DRSuperUser
DCListPendingGroups_ :: DirectoryCmdTag 'DRSuperUser
DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser
deriving instance Show (DirectoryCmdTag r)
@@ -133,14 +130,12 @@ data DirectoryCmd (r :: DirectoryRole) where
DCListUserGroups :: DirectoryCmd 'DRUser
DCDeleteGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
DCSetRole :: GroupId -> GroupName -> GroupMemberRole -> DirectoryCmd 'DRUser
DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRAdmin
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCListLastGroups :: Int -> DirectoryCmd 'DRAdmin
DCListPendingGroups :: Int -> DirectoryCmd 'DRAdmin
DCShowGroupLink :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCSendToGroupOwner :: GroupId -> GroupName -> Text -> DirectoryCmd 'DRAdmin
DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRSuperUser
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
DCListLastGroups :: Int -> DirectoryCmd 'DRSuperUser
DCListPendingGroups :: Int -> DirectoryCmd 'DRSuperUser
DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser
DCUnknownCommand :: DirectoryCmd 'DRUser
DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
@@ -173,20 +168,17 @@ directoryCmdP =
"ls" -> u DCListUserGroups_
"delete" -> u DCDeleteGroup_
"role" -> u DCSetRole_
"approve" -> au DCApproveGroup_
"reject" -> au DCRejectGroup_
"suspend" -> au DCSuspendGroup_
"resume" -> au DCResumeGroup_
"last" -> au DCListLastGroups_
"pending" -> au DCListPendingGroups_
"link" -> au DCShowGroupLink_
"owner" -> au DCSendToGroupOwner_
"approve" -> su DCApproveGroup_
"reject" -> su DCRejectGroup_
"suspend" -> su DCSuspendGroup_
"resume" -> su DCResumeGroup_
"last" -> su DCListLastGroups_
"pending" -> su DCListPendingGroups_
"exec" -> su DCExecuteCommand_
"x" -> su DCExecuteCommand_
_ -> fail "bad command tag"
where
u = pure . ADCT SDRUser
au = pure . ADCT SDRAdmin
su = pure . ADCT SDRSuperUser
cmdP :: DirectoryCmdTag r -> Parser (DirectoryCmd r)
cmdP = \case
@@ -211,11 +203,6 @@ directoryCmdP =
DCResumeGroup_ -> gc DCResumeGroup
DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10)
DCListPendingGroups_ -> DCListPendingGroups <$> (A.space *> A.decimal <|> pure 10)
DCShowGroupLink_ -> gc DCShowGroupLink
DCSendToGroupOwner_ -> do
(groupId, displayName) <- gc (,)
msg <- A.space *> A.takeText
pure $ DCSendToGroupOwner groupId displayName msg
DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText)
where
gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> displayNameP
@@ -226,8 +213,8 @@ directoryCmdP =
quoted c = A.char c *> takeNameTill (== c) <* A.char c
refChar c = c > ' ' && c /= '#' && c /= '@'
viewName :: Text -> Text
viewName n = if any (== ' ') (T.unpack n) then "'" <> n <> "'" else n
viewName :: String -> String
viewName n = if ' ' `elem` n then "'" <> n <> "'" else n
directoryCmdTag :: DirectoryCmd r -> Text
directoryCmdTag = \case
@@ -247,8 +234,6 @@ directoryCmdTag = \case
DCResumeGroup {} -> "resume"
DCListLastGroups _ -> "last"
DCListPendingGroups _ -> "pending"
DCShowGroupLink {} -> "link"
DCSendToGroupOwner {} -> "owner"
DCExecuteCommand _ -> "exec"
DCUnknownCommand -> "unknown"
DCCommandError _ -> "error"
@@ -11,7 +11,6 @@ module Directory.Options
)
where
import qualified Data.Text as T
import Options.Applicative
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
@@ -19,10 +18,9 @@ import Simplex.Chat.Options (ChatOpts (..), ChatCmdLog (..), CoreChatOpts, coreC
data DirectoryOpts = DirectoryOpts
{ coreOptions :: CoreChatOpts,
adminUsers :: [KnownContact],
superUsers :: [KnownContact],
directoryLog :: Maybe FilePath,
serviceName :: T.Text,
serviceName :: String,
searchResults :: Int,
testing :: Bool
}
@@ -30,13 +28,6 @@ data DirectoryOpts = DirectoryOpts
directoryOpts :: FilePath -> FilePath -> Parser DirectoryOpts
directoryOpts appDir defaultDbFileName = do
coreOptions <- coreChatOptsP appDir defaultDbFileName
adminUsers <-
option
parseKnownContacts
( long "admin-users"
<> metavar "ADMIN_USERS"
<> help "Comma-separated list of admin-users in the format CONTACT_ID:DISPLAY_NAME who will be allowed to manage the directory"
)
superUsers <-
option
parseKnownContacts
@@ -61,10 +52,9 @@ directoryOpts appDir defaultDbFileName = do
pure
DirectoryOpts
{ coreOptions,
adminUsers,
superUsers,
directoryLog,
serviceName = T.pack serviceName,
serviceName,
searchResults = 10,
testing = False
}
@@ -17,11 +17,13 @@ import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Logger.Simple
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromMaybe, maybeToList)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Directory.Events
@@ -35,7 +37,6 @@ import Simplex.Chat.Core
import Simplex.Chat.Messages
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Store.Shared (StoreError (..))
import Simplex.Chat.Types
import Simplex.Chat.Types.Shared
import Simplex.Chat.View (serializeChatResponse, simplexChatContact, viewContactName, viewGroupName)
@@ -78,7 +79,7 @@ welcomeGetOpts = do
pure opts
directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> IO ()
directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchResults, testing} user@User {userId} cc = do
directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testing} user@User {userId} cc = do
initializeBotAddress' (not testing) cc
env <- newServiceState
race_ (forever $ void getLine) . forever $ do
@@ -101,7 +102,6 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
logInfo $ "command received " <> directoryCmdTag cmd
case sUser of
SDRUser -> deUserCommand env ct ciId cmd
SDRAdmin -> deAdminCommand ct ciId cmd
SDRSuperUser -> deSuperUserCommand ct ciId cmd
DELogChatResponse r -> logInfo r
where
@@ -118,9 +118,9 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
userGroupReference gr GroupInfo {groupProfile = GroupProfile {displayName}} = userGroupReference' gr displayName
userGroupReference' GroupReg {userGroupRegId} displayName = groupReference' userGroupRegId displayName
groupReference GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = groupReference' groupId displayName
groupReference' groupId displayName = "ID " <> tshow groupId <> " (" <> displayName <> ")"
groupReference' groupId displayName = "ID " <> show groupId <> " (" <> T.unpack displayName <> ")"
groupAlreadyListed GroupInfo {groupProfile = GroupProfile {displayName, fullName}} =
"The group " <> displayName <> " (" <> fullName <> ") is already listed in the directory, please choose another name."
T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already listed in the directory, please choose another name."
getGroups :: Text -> IO (Maybe [(GroupInfo, GroupSummary)])
getGroups = getGroups_ . Just
@@ -151,7 +151,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = do
void $ addGroupReg st ct g GRSProposed
r <- sendChatCmd cc $ APIJoinGroup groupId
sendMessage cc ct $ case r of
sendMessage cc ct $ T.unpack $ case r of
CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> ""
_ -> "Error joining group " <> displayName <> ", please re-send the invitation!"
@@ -179,10 +179,10 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
where
askConfirmation = do
ugrId <- addGroupReg st ct g GRSPendingConfirmation
sendMessage cc ct $ "The group " <> displayName <> " (" <> fullName <> ") is already submitted to the directory.\nTo confirm the registration, please send:"
sendMessage cc ct $ "/confirm " <> tshow ugrId <> ":" <> viewName displayName
sendMessage cc ct $ T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already submitted to the directory.\nTo confirm the registration, please send:"
sendMessage cc ct $ "/confirm " <> show ugrId <> ":" <> viewName (T.unpack displayName)
badRolesMsg :: GroupRolesStatus -> Maybe Text
badRolesMsg :: GroupRolesStatus -> Maybe String
badRolesMsg = \case
GRSOk -> Nothing
GRSServiceNotAdmin -> Just "You must grant directory service *admin* role to register the group"
@@ -218,7 +218,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
when (ctId `isOwner` gr) $ do
setGroupRegOwner st gr owner
let GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = g
notifyOwner gr $ "Joined the group " <> displayName <> ", creating the link…"
notifyOwner gr $ T.unpack $ "Joined the group " <> displayName <> ", creating the link…"
sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case
CRGroupLinkCreated {connReqContact} -> do
setGroupStatus st gr GRSPendingUpdate
@@ -227,7 +227,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
"Created the public link to join the group via this directory service that is always online.\n\n\
\Please add it to the group welcome message.\n\
\For example, add:"
notifyOwner gr $ "Link to join the group " <> displayName <> ": " <> strEncodeTxt (simplexChatContact connReqContact)
notifyOwner gr $ "Link to join the group " <> T.unpack displayName <> ": " <> B.unpack (strEncode $ simplexChatContact connReqContact)
CRChatCmdError _ (ChatError e) -> case e of
CEGroupUserRole {} -> notifyOwner gr "Failed creating group link, as service is no longer an admin."
CEGroupMemberUserRemoved -> notifyOwner gr "Failed creating group link, as service is removed from the group."
@@ -256,7 +256,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
GPHasServiceLink -> when (ctId `isOwner` gr) $ groupLinkAdded gr
GPServiceLinkError -> do
when (ctId `isOwner` gr) $ notifyOwner gr $ "Error: " <> serviceName <> " has no group link for " <> userGroupRef <> ". Please report the error to the developers."
logError $ "Error: no group link for " <> userGroupRef
logError $ "Error: no group link for " <> T.pack userGroupRef
GRSPendingApproval n -> processProfileChange gr $ n + 1
GRSActive -> processProfileChange gr 1
GRSSuspended -> processProfileChange gr 1
@@ -277,7 +277,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
_ -> do
let gaId = 1
setGroupStatus st gr $ GRSPendingApproval gaId
notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 48 hours."
notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 24 hours."
checkRolesSendToApprove gr gaId
processProfileChange gr n' = do
setGroupStatus st gr GRSPendingUpdate
@@ -299,13 +299,13 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
notifyOwner gr $ "The group " <> userGroupRef <> " is updated!\nIt is hidden from the directory until approved."
notifySuperUsers $ "The group " <> groupRef <> " is updated."
checkRolesSendToApprove gr n'
GPServiceLinkError -> logError $ "Error: no group link for " <> groupRef <> " pending approval."
GPServiceLinkError -> logError $ "Error: no group link for " <> T.pack groupRef <> " pending approval."
groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId)
where
profileUpdate = \case
CRGroupLink {connReqContact} ->
let groupLink1 = strEncodeTxt connReqContact
groupLink2 = strEncodeTxt $ simplexChatContact connReqContact
let groupLink1 = safeDecodeUtf8 $ strEncode connReqContact
groupLink2 = safeDecodeUtf8 $ strEncode $ simplexChatContact connReqContact
hadLinkBefore = groupLink1 `isInfix` description p || groupLink2 `isInfix` description p
hasLinkNow = groupLink1 `isInfix` description p' || groupLink2 `isInfix` description p'
in if
@@ -331,7 +331,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
msg = maybe (MCText text) (\image -> MCImage {text, image}) image'
withSuperUsers $ \cId -> do
sendComposedMessage' cc cId Nothing msg
sendMessage' cc cId $ "/approve " <> tshow dbGroupId <> ":" <> viewName displayName <> " " <> tshow gaId
sendMessage' cc cId $ "/approve " <> show dbGroupId <> ":" <> viewName (T.unpack displayName) <> " " <> show gaId
deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO ()
deContactRoleChanged g@GroupInfo {membership = GroupMember {memberRole = serviceRole}} ctId contactRole = do
@@ -356,7 +356,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
where
rStatus = groupRolesStatus contactRole serviceRole
groupRef = groupReference g
ctRole = "*" <> strEncodeTxt contactRole <> "*"
ctRole = "*" <> B.unpack (strEncode contactRole) <> "*"
suCtRole = "(user role is set to " <> ctRole <> ")."
deServiceRoleChanged :: GroupInfo -> GroupMemberRole -> IO ()
@@ -382,7 +382,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
_ -> pure ()
where
groupRef = groupReference g
srvRole = "*" <> strEncodeTxt serviceRole <> "*"
srvRole = "*" <> B.unpack (strEncode serviceRole) <> "*"
suSrvRole = "(" <> serviceName <> " role is changed to " <> srvRole <> ")."
whenContactIsOwner gr action =
getGroupMember gr
@@ -426,7 +426,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
<> serviceName
<> " bot will create a public group link for the new members to join even when you are offline.\n\
\3. You will then need to add this link to the group welcome message.\n\
\4. Once the link is added, service admins will approve the group (it can take up to 48 hours), and everybody will be able to find it in directory.\n\n\
\4. Once the link is added, service admins will approve the group (it can take up to 24 hours), and everybody will be able to find it in directory.\n\n\
\Start from inviting the bot to your group as admin - it will guide you through the process"
DCSearchGroup s -> withFoundListedGroups (Just s) $ sendSearchResults s
DCSearchNext ->
@@ -448,47 +448,44 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
DCRecentGroups -> withFoundListedGroups Nothing $ sendAllGroups takeRecent "the most recent" STRecent
DCSubmitGroup _link -> pure ()
DCConfirmDuplicateGroup ugrId gName ->
withUserGroupReg ugrId gName $ \g@GroupInfo {groupProfile = GroupProfile {displayName}} gr ->
withUserGroupReg ugrId gName $ \gr g@GroupInfo {groupProfile = GroupProfile {displayName}} ->
readTVarIO (groupRegStatus gr) >>= \case
GRSPendingConfirmation ->
getDuplicateGroup g >>= \case
Nothing -> sendMessage cc ct "Error: getDuplicateGroup. Please notify the developers."
Just DGReserved -> sendMessage cc ct $ groupAlreadyListed g
_ -> processInvitation ct g
_ -> sendReply $ "Error: the group ID " <> tshow ugrId <> " (" <> displayName <> ") is not pending confirmation."
_ -> sendReply $ "Error: the group ID " <> show ugrId <> " (" <> T.unpack displayName <> ") is not pending confirmation."
DCListUserGroups ->
atomically (getUserGroupRegs st $ contactId' ct) >>= \grs -> do
sendReply $ tshow (length grs) <> " registered group(s)"
sendReply $ show (length grs) <> " registered group(s)"
void . forkIO $ forM_ (reverse grs) $ \gr@GroupReg {userGroupRegId} ->
sendGroupInfo ct gr userGroupRegId Nothing
DCDeleteGroup ugrId gName ->
withUserGroupReg ugrId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} gr -> do
withUserGroupReg ugrId gName $ \gr GroupInfo {groupProfile = GroupProfile {displayName}} -> do
delGroupReg st gr
sendReply $ "Your group " <> displayName <> " is deleted from the directory"
DCSetRole gId gName mRole ->
(if isAdmin then withGroupAndReg sendReply else withUserGroupReg) gId gName $
\GroupInfo {groupId, groupProfile = GroupProfile {displayName}} _gr -> do
gLink_ <- setGroupLinkRole cc groupId mRole
sendReply $ case gLink_ of
Nothing -> "Error: the initial member role for the group " <> displayName <> " was NOT upgated"
Just gLink ->
("The initial member role for the group " <> displayName <> " is set to *" <> strEncodeTxt mRole <> "*\n\n")
<> ("*Please note*: it applies only to members joining via this link: " <> strEncodeTxt (simplexChatContact gLink))
sendReply $ T.unpack $ "Your group " <> displayName <> " is deleted from the directory"
DCSetRole ugrId gName mRole ->
withUserGroupReg ugrId gName $ \_gr GroupInfo {groupId, groupProfile = GroupProfile {displayName}} -> do
gLink_ <- setGroupLinkRole cc groupId mRole
sendReply $ T.unpack $ case gLink_ of
Nothing -> "Error: the initial member role for the group " <> displayName <> " was NOT upgated"
Just gLink ->
("The initial member role for the group " <> displayName <> " is set to *" <> decodeLatin1 (strEncode mRole) <> "*\n\n")
<> ("*Please note*: it applies only to members joining via this link: " <> safeDecodeUtf8 (strEncode $ simplexChatContact gLink))
DCUnknownCommand -> sendReply "Unknown command"
DCCommandError tag -> sendReply $ "Command error: " <> tshow tag
DCCommandError tag -> sendReply $ "Command error: " <> show tag
where
knownCt = knownContact ct
isAdmin = knownCt `elem` adminUsers || knownCt `elem` superUsers
withUserGroupReg ugrId gName action =
atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case
Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found"
Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found"
Just gr@GroupReg {dbGroupId} -> do
getGroup cc dbGroupId >>= \case
Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found"
Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found"
Just g@GroupInfo {groupProfile = GroupProfile {displayName}}
| displayName == gName -> action g gr
| otherwise -> sendReply $ "Group ID " <> tshow ugrId <> " has the display name " <> displayName
sendReply = mkSendReply ct ciId
| displayName == gName -> action gr g
| otherwise -> sendReply $ "Group ID " <> show ugrId <> " has the display name " <> T.unpack displayName
sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent
withFoundListedGroups s_ action =
getGroups_ s_ >>= \case
Just groups -> atomically (filterListedGroups st groups) >>= action
@@ -498,8 +495,8 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
gs -> do
let gs' = takeTop searchResults gs
moreGroups = length gs - length gs'
more = if moreGroups > 0 then ", sending top " <> tshow (length gs') else ""
sendReply $ "Found " <> tshow (length gs) <> " group(s)" <> more <> "."
more = if moreGroups > 0 then ", sending top " <> show (length gs') else ""
sendReply $ "Found " <> show (length gs) <> " group(s)" <> more <> "."
updateSearchRequest (STSearch s) $ groupIds gs'
sendFoundGroups gs' moreGroups
sendAllGroups takeFirst sortName searchType = \case
@@ -507,8 +504,8 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
gs -> do
let gs' = takeFirst searchResults gs
moreGroups = length gs - length gs'
more = if moreGroups > 0 then ", sending " <> sortName <> " " <> tshow (length gs') else ""
sendReply $ tshow (length gs) <> " group(s) listed" <> more <> "."
more = if moreGroups > 0 then ", sending " <> sortName <> " " <> show (length gs') else ""
sendReply $ show (length gs) <> " group(s) listed" <> more <> "."
updateSearchRequest searchType $ groupIds gs'
sendFoundGroups gs' moreGroups
sendNextSearchResults takeFirst SearchRequest {searchType, sentGroups} = \case
@@ -519,7 +516,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
let gs' = takeFirst searchResults $ filterNotSent sentGroups gs
sentGroups' = sentGroups <> groupIds gs'
moreGroups = length gs - S.size sentGroups'
sendReply $ "Sending " <> tshow (length gs') <> " more group(s)."
sendReply $ "Sending " <> show (length gs') <> " more group(s)."
updateSearchRequest searchType sentGroups'
sendFoundGroups gs' moreGroups
updateSearchRequest :: SearchType -> Set GroupId -> IO ()
@@ -530,10 +527,9 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
sendFoundGroups gs moreGroups =
void . forkIO $ do
forM_ gs $
\(GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do
\(GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do
let membersStr = "_" <> tshow currentMembers <> " members_"
showId = if isAdmin then tshow groupId <> ". " else ""
text = showId <> groupInfoText p <> "\n" <> membersStr
text = groupInfoText p <> "\n" <> membersStr
msg = maybe (MCText text) (\image -> MCImage {text, image}) image_
sendComposedMessage cc ct Nothing msg
when (moreGroups > 0) $
@@ -541,134 +537,92 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe
MCText $
"Send */next* or just *.* for " <> tshow moreGroups <> " more result(s)."
deAdminCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRAdmin -> IO ()
deAdminCommand ct ciId cmd
| knownCt `elem` adminUsers || knownCt `elem` superUsers = case cmd of
deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO ()
deSuperUserCommand ct ciId cmd
| superUser `elem` superUsers = case cmd of
DCApproveGroup {groupId, displayName = n, groupApprovalId} ->
withGroupAndReg sendReply groupId n $ \g gr ->
readTVarIO (groupRegStatus gr) >>= \case
GRSPendingApproval gaId
| gaId == groupApprovalId -> do
getDuplicateGroup g >>= \case
Nothing -> sendReply "Error: getDuplicateGroup. Please notify the developers."
Just DGReserved -> sendReply $ "The group " <> groupRef <> " is already listed in the directory."
_ -> do
getGroupRolesStatus g gr >>= \case
Just GRSOk -> do
setGroupStatus st gr GRSActive
let approved = "The group " <> userGroupReference' gr n <> " is approved"
notifyOwner gr $ approved <> " and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved."
sendReply "Group approved!"
notifyOtherSuperUsers $ approved <> " by " <> viewName (localDisplayName' ct)
Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin
Just GRSContactNotOwner -> replyNotApproved "user is not an owner."
Just GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin
Nothing -> sendReply "Error: getGroupRolesStatus. Please notify the developers."
where
replyNotApproved reason = sendReply $ "Group is not approved: " <> reason
serviceNotAdmin = serviceName <> " is not an admin."
| otherwise -> sendReply "Incorrect approval code"
_ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval."
getGroupAndReg groupId n >>= \case
Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)."
Just (g, gr) ->
readTVarIO (groupRegStatus gr) >>= \case
GRSPendingApproval gaId
| gaId == groupApprovalId -> do
getDuplicateGroup g >>= \case
Nothing -> sendReply "Error: getDuplicateGroup. Please notify the developers."
Just DGReserved -> sendReply $ "The group " <> groupRef <> " is already listed in the directory."
_ -> do
getGroupRolesStatus g gr >>= \case
Just GRSOk -> do
setGroupStatus st gr GRSActive
sendReply "Group approved!"
notifyOwner gr $ "The group " <> userGroupReference' gr n <> " is approved and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved."
Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin
Just GRSContactNotOwner -> replyNotApproved "user is not an owner."
Just GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin
Nothing -> sendReply "Error: getGroupRolesStatus. Please notify the developers."
where
replyNotApproved reason = sendReply $ "Group is not approved: " <> reason
serviceNotAdmin = serviceName <> " is not an admin."
| otherwise -> sendReply "Incorrect approval code"
_ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval."
where
groupRef = groupReference' groupId n
DCRejectGroup _gaId _gName -> pure ()
DCSuspendGroup groupId gName -> do
let groupRef = groupReference' groupId gName
withGroupAndReg sendReply groupId gName $ \_ gr ->
readTVarIO (groupRegStatus gr) >>= \case
GRSActive -> do
setGroupStatus st gr GRSSuspended
let suspended = "The group " <> userGroupReference' gr gName <> " is suspended"
notifyOwner gr $ suspended <> " and hidden from directory. Please contact the administrators."
sendReply "Group suspended!"
notifyOtherSuperUsers $ suspended <> " by " <> viewName (localDisplayName' ct)
_ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended."
getGroupAndReg groupId gName >>= \case
Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)."
Just (_, gr) ->
readTVarIO (groupRegStatus gr) >>= \case
GRSActive -> do
setGroupStatus st gr GRSSuspended
notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is suspended and hidden from directory. Please contact the administrators."
sendReply "Group suspended!"
_ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended."
DCResumeGroup groupId gName -> do
let groupRef = groupReference' groupId gName
withGroupAndReg sendReply groupId gName $ \_ gr ->
readTVarIO (groupRegStatus gr) >>= \case
GRSSuspended -> do
setGroupStatus st gr GRSActive
let groupStr = "The group " <> userGroupReference' gr gName
notifyOwner gr $ groupStr <> " is listed in the directory again!"
sendReply "Group listing resumed!"
notifyOtherSuperUsers $ groupStr <> " listing resumed by " <> viewName (localDisplayName' ct)
_ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed."
getGroupAndReg groupId gName >>= \case
Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)."
Just (_, gr) ->
readTVarIO (groupRegStatus gr) >>= \case
GRSSuspended -> do
setGroupStatus st gr GRSActive
notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is listed in the directory again!"
sendReply "Group listing resumed!"
_ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed."
DCListLastGroups count -> listGroups count False
DCListPendingGroups count -> listGroups count True
DCShowGroupLink groupId gName -> do
let groupRef = groupReference' groupId gName
withGroupAndReg sendReply groupId gName $ \_ _ ->
sendChatCmd cc (APIGetGroupLink groupId) >>= \case
CRGroupLink {connReqContact, memberRole} ->
sendReply $ T.unlines
[ "The link to join the group " <> groupRef <> ":",
strEncodeTxt $ simplexChatContact connReqContact,
"New member role: " <> strEncodeTxt memberRole
]
CRChatCmdError _ (ChatErrorStore (SEGroupLinkNotFound _)) ->
sendReply $ "The group " <> groupRef <> " has no public link."
r -> do
ts <- getCurrentTime
tz <- getCurrentTimeZone
let resp = T.pack $ serializeChatResponse (Nothing, Just user) ts tz Nothing r
sendReply $ "Unexpected error:\n" <> resp
DCSendToGroupOwner groupId gName msg -> do
let groupRef = groupReference' groupId gName
withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {dbContactId} -> do
notifyOwner gr msg
owner_ <- getContact cc dbContactId
let ownerInfo = "the owner of the group " <> groupRef
ownerName ct' = "@" <> viewName (localDisplayName' ct') <> ", "
sendReply $ "Forwarded to " <> maybe "" ownerName owner_ <> ownerInfo
DCCommandError tag -> sendReply $ "Command error: " <> tshow tag
DCExecuteCommand cmdStr ->
sendChatCmdStr cc cmdStr >>= \r -> do
ts <- getCurrentTime
tz <- getCurrentTimeZone
sendReply $ serializeChatResponse (Nothing, Just user) ts tz Nothing r
DCCommandError tag -> sendReply $ "Command error: " <> show tag
| otherwise = sendReply "You are not allowed to use this command"
where
knownCt = knownContact ct
sendReply = mkSendReply ct ciId
notifyOtherSuperUsers s = withSuperUsers $ \ctId -> unless (ctId == contactId' ct) $ sendMessage' cc ctId s
superUser = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent
listGroups count pending =
readTVarIO (groupRegs st) >>= \groups -> do
grs <-
if pending
if pending
then filterM (fmap pendingApproval . readTVarIO . groupRegStatus) groups
else pure groups
sendReply $ tshow (length grs) <> " registered group(s)" <> (if length grs > count then ", showing the last " <> tshow count else "")
sendReply $ show (length grs) <> " registered group(s)" <> (if length grs > count then ", showing the last " <> show count else "")
void . forkIO $ forM_ (reverse $ take count grs) $ \gr@GroupReg {dbGroupId, dbContactId} -> do
ct_ <- getContact cc dbContactId
let ownerStr = "Owner: " <> maybe "getContact error" localDisplayName' ct_
sendGroupInfo ct gr dbGroupId $ Just ownerStr
deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO ()
deSuperUserCommand ct ciId cmd
| knownContact ct `elem` superUsers = case cmd of
DCExecuteCommand cmdStr ->
sendChatCmdStr cc cmdStr >>= \r -> do
ts <- getCurrentTime
tz <- getCurrentTimeZone
sendReply $ T.pack $ serializeChatResponse (Nothing, Just user) ts tz Nothing r
DCCommandError tag -> sendReply $ "Command error: " <> tshow tag
| otherwise = sendReply "You are not allowed to use this command"
where
sendReply = mkSendReply ct ciId
knownContact :: Contact -> KnownContact
knownContact ct = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
mkSendReply :: Contact -> ChatItemId -> Text -> IO ()
mkSendReply ct ciId = sendComposedMessage cc ct (Just ciId) . MCText
withGroupAndReg :: (Text -> IO ()) -> GroupId -> GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO ()
withGroupAndReg sendReply gId gName action =
getGroup cc gId >>= \case
Nothing -> sendReply $ "Group ID " <> tshow gId <> " not found (getGroup)"
Just g@GroupInfo {groupProfile = GroupProfile {displayName}}
| displayName == gName ->
atomically (getGroupReg st gId) >>= \case
Nothing -> sendReply $ "Registration for group ID " <> tshow gId <> " not found (getGroupReg)"
Just gr -> action g gr
| otherwise ->
sendReply $ "Group ID " <> tshow gId <> " has the display name " <> displayName
getGroupAndReg :: GroupId -> GroupName -> IO (Maybe (GroupInfo, GroupReg))
getGroupAndReg gId gName =
getGroup cc gId
$>>= \g@GroupInfo {groupProfile = GroupProfile {displayName}} ->
if displayName == gName
then
atomically (getGroupReg st gId)
$>>= \gr -> pure $ Just (g, gr)
else pure Nothing
sendGroupInfo :: Contact -> GroupReg -> GroupId -> Maybe Text -> IO ()
sendGroupInfo ct gr@GroupReg {dbGroupId} useGroupId ownerStr_ = do
@@ -689,7 +643,7 @@ getContact cc ctId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTDirect ctId)
where
resp :: ChatResponse -> Maybe Contact
resp = \case
CRApiChat _ (AChat SCTDirect Chat {chatInfo = DirectChat ct}) -> Just ct
CRApiChat _ (AChat SCTDirect Chat {chatInfo = DirectChat ct}) _ -> Just ct
_ -> Nothing
getGroup :: ChatController -> GroupId -> IO (Maybe GroupInfo)
@@ -714,8 +668,5 @@ setGroupLinkRole cc gId mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole
CRGroupLink _ _ gLink _ -> Just gLink
_ -> Nothing
unexpectedError :: Text -> Text
unexpectedError :: String -> String
unexpectedError err = "Unexpected error: " <> err <> ", please notify the developers."
strEncodeTxt :: StrEncoding a => a -> Text
strEncodeTxt = safeDecodeUtf8 . strEncode
+1 -1
View File
@@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: 93f30c8edf9243ad2291dd6427d87328e282560a
tag: a8471eed5be93e7c3741aa4742b24193c9a2d6f5
source-repository-package
type: git
+17 -15
View File
@@ -8,23 +8,25 @@ layout: layouts/jobs.html
SimpleX Chat Ltd is a seed stage startup with a lot of user growth in 2022-2023, and a lot of exciting technical and product problems to solve to grow faster.
We currently have 6 full-time people in the team.
We currently have 4 full-time people in the team - all engineers, including the founder.
We want to add up to 3 people to the team.
We want to add 2 people to the team.
## Who we are looking for
### Web designer & developer for a website contract
### Product/UI designer
You will work with the founder and a product marketing expert to convert the stories we want to tell our current and prospective users into interactive experiences.
You will be designing the user experience and the interface of both the app and the website in collaboration with the team.
You are an expert in creating interactive web experiences:
- 15+ years of web development and design experience.
- Passionate about communications, privacy and data ownership.
- Competent using PhotoShop, 3D modelling, etc.
- Competent in Web tech, including JavaScript, animations, etc.
The current focus of the app is privacy and security, but we hope to have the design that would support the feeling of psychological safety, enabling people to achieve the results in the smallest amount of time.
We will NOT consider agencies or groups it must be one person working on the project.
You are an experienced and innovative product designer with:
- 8+ years of user experience and visual design.
- Expertise in typography and high sensitivity to colors.
- Exceptional precision and attention to details.
- Strong opinions (weakly held).
- A strong empathy.
### Application Haskell engineer
@@ -32,12 +34,13 @@ You will work with the Haskell core of the client applications and with the netw
You are an expert in language models, databases and Haskell:
- expert knowledge of SQL.
- Haskell strictness, exceptions, [concurrency](https://simonmar.github.io/pages/pcph.html), STM, [type systems](https://thinkingwithtypes.com).
- 15y+ of software engineering experience in complex projects.
- Haskell exception handling, concurrency, STM, type systems.
- 8y+ of software engineering experience in complex projects,
- deep understanding of the common programming principles:
- data structures, bits and bytes, text encoding.
- [functional software design](https://mitp-content-server.mit.edu/books/content/sectbyfn/books_pres_0/6515/sicp.zip/index.html) and algorithms.
- protocols and networking.
- software design and algorithms.
- concurrency.
- networking.
## About you
@@ -45,7 +48,6 @@ You are an expert in language models, databases and Haskell:
- already use SimpleX Chat to communicate with friends/family or participate in public SimpleX Chat groups.
- passionate about privacy, security and communications.
- interested to make contributions to SimpleX Chat open-source project in your free time before we hire you, as an extended test.
- you founded (and probably failed) at least one startup, or spent more time working for yourself than being employed.
- **Exceptionally pragmatic, very fast and customer-focussed**:
- care about the customers (aka users) and about the product we build much more than about the code quality, technology stack, etc.
-24
View File
@@ -1,24 +0,0 @@
# Server operators
## Problem
All preconfigured servers operated by a single company create a risk that user connections can be analysed by aggregating transport information from these servers.
The solution is to have more than one operator servers pre-configured in the app.
For operators to be protected from any violations of rights of other users or third parties by the users who use servers of these operators, the users have to explicitely accept conditions of use with the operator, in the same way they accept conditions of use with SimpleX Chat Ltd by downloading the app.
## Solution
Allow to assign operators to servers, both with preconfigured operators and servers, and with user-defined operators. Agent added support for server roles, chat app could:
- allow assigning server roles only on the operator level.
- only on server level.
- on both, with server roles overriding operator roles (that would require a different type for server for chat app).
For simplicity of both UX and logic it is probably better to allow assigning roles only on operators' level, and servers without set operators can be used for both roles.
For agreements, it is sufficient to record the signatures of these agreements on users' devices, together with the copy of signed agreement (or its hash and version) in a separate table. The terms themselves could be:
- included in the app - either in code or in migration.
- referenced with a stable link to a particular commit.
The first solution seems better, as it avoids any third party dependency, and the agreement size is relatively small (~31kb), to reduce size we can store it compressed.
Generated
+29 -82
View File
@@ -156,11 +156,11 @@
"ghc98X": {
"flake": false,
"locked": {
"lastModified": 1715066704,
"narHash": "sha256-F0EVR8x/fcpj1st+hz96Wdsz5uwVIOziGKAwRxLOYJw=",
"lastModified": 1696643148,
"narHash": "sha256-E02DfgISH7EvvNAu0BHiPvl1E5FGMDi0pWdNZtIBC9I=",
"ref": "ghc-9.8",
"rev": "78a253543d466ac511a1664a3e6aff032ca684d5",
"revCount": 61757,
"rev": "443e870d977b1ab6fc05f47a9a17bc49296adbd6",
"revCount": 61642,
"submodules": true,
"type": "git",
"url": "https://gitlab.haskell.org/ghc/ghc"
@@ -175,11 +175,11 @@
"ghc99": {
"flake": false,
"locked": {
"lastModified": 1726585445,
"narHash": "sha256-IdwQBex4boY6s0Plj5+ixf36rfYSUyMdTWrztKvZH30=",
"lastModified": 1697054644,
"narHash": "sha256-kKarOuXUaAH3QWv7ASx+gGFMHaHKe0pK5Zu37ky2AL4=",
"ref": "refs/heads/master",
"rev": "7fd9e5e29ab54eb406880077463e8552e2ddd39a",
"revCount": 67238,
"rev": "f383a242c76f90bcca8a4d7ee001dcb49c172a9a",
"revCount": 62040,
"submodules": true,
"type": "git",
"url": "https://gitlab.haskell.org/ghc/ghc"
@@ -225,8 +225,6 @@
"hls-2.2": "hls-2.2",
"hls-2.3": "hls-2.3",
"hls-2.4": "hls-2.4",
"hls-2.5": "hls-2.5",
"hls-2.6": "hls-2.6",
"hpc-coveralls": "hpc-coveralls",
"hydra": "hydra",
"iserv-proxy": "iserv-proxy",
@@ -240,17 +238,16 @@
"nixpkgs-2205": "nixpkgs-2205",
"nixpkgs-2211": "nixpkgs-2211",
"nixpkgs-2305": "nixpkgs-2305",
"nixpkgs-2311": "nixpkgs-2311",
"nixpkgs-unstable": "nixpkgs-unstable",
"old-ghc-nix": "old-ghc-nix",
"stackage": "stackage"
},
"locked": {
"lastModified": 1705833500,
"narHash": "sha256-rUIr6JNbCedt1g4gVYVvE9t0oFU6FUspCA0DS5cA8Bg=",
"lastModified": 1701163700,
"narHash": "sha256-sOrewUS3LnzV09nGr7+3R6Q6zsgU4smJc61QsHq+4DE=",
"owner": "input-output-hk",
"repo": "haskell.nix",
"rev": "d0c35e75cbbc6858770af42ac32b0b85495fbd71",
"rev": "2808bfe3e62e9eb4ee8974cd623a00e1611f302b",
"type": "github"
},
"original": {
@@ -331,50 +328,16 @@
"hls-2.4": {
"flake": false,
"locked": {
"lastModified": 1699862708,
"narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=",
"lastModified": 1696939266,
"narHash": "sha256-VOMf5+kyOeOmfXTHlv4LNFJuDGa7G3pDnOxtzYR40IU=",
"owner": "haskell",
"repo": "haskell-language-server",
"rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57",
"rev": "362fdd1293efb4b82410b676ab1273479f6d17ee",
"type": "github"
},
"original": {
"owner": "haskell",
"ref": "2.4.0.1",
"repo": "haskell-language-server",
"type": "github"
}
},
"hls-2.5": {
"flake": false,
"locked": {
"lastModified": 1701080174,
"narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=",
"owner": "haskell",
"repo": "haskell-language-server",
"rev": "27f8c3d3892e38edaef5bea3870161815c4d014c",
"type": "github"
},
"original": {
"owner": "haskell",
"ref": "2.5.0.0",
"repo": "haskell-language-server",
"type": "github"
}
},
"hls-2.6": {
"flake": false,
"locked": {
"lastModified": 1705325287,
"narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=",
"owner": "haskell",
"repo": "haskell-language-server",
"rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e",
"type": "github"
},
"original": {
"owner": "haskell",
"ref": "2.6.0.0",
"ref": "2.4.0.0",
"repo": "haskell-language-server",
"type": "github"
}
@@ -421,11 +384,11 @@
"iserv-proxy": {
"flake": false,
"locked": {
"lastModified": 1707968597,
"narHash": "sha256-C53NqToxl+n9s1pQ0iLtiH6P5vX3rM+NW/mFt4Ykpsk=",
"lastModified": 1691634696,
"narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=",
"ref": "hkm/remote-iserv",
"rev": "1b7f8aeb37bbc7c00f04e44d9379aa15a4409e8b",
"revCount": 18,
"rev": "43a979272d9addc29fbffc2e8542c5d96e993d73",
"revCount": 14,
"type": "git",
"url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git"
},
@@ -589,11 +552,11 @@
},
"nixpkgs-2305": {
"locked": {
"lastModified": 1705033721,
"narHash": "sha256-K5eJHmL1/kev6WuqyqqbS1cdNnSidIZ3jeqJ7GbrYnQ=",
"lastModified": 1695416179,
"narHash": "sha256-610o1+pwbSu+QuF3GE0NU5xQdTHM3t9wyYhB9l94Cd8=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "a1982c92d8980a0114372973cbdfe0a307f1bdea",
"rev": "715d72e967ec1dd5ecc71290ee072bcaf5181ed6",
"type": "github"
},
"original": {
@@ -603,22 +566,6 @@
"type": "github"
}
},
"nixpkgs-2311": {
"locked": {
"lastModified": 1719957072,
"narHash": "sha256-gvFhEf5nszouwLAkT9nWsDzocUTqLWHuL++dvNjMp9I=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "7144d6241f02d171d25fba3edeaf15e0f2592105",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixpkgs-23.11-darwin",
"repo": "nixpkgs",
"type": "github"
}
},
"nixpkgs-lib": {
"locked": {
"dir": "lib",
@@ -655,17 +602,17 @@
},
"nixpkgs-unstable": {
"locked": {
"lastModified": 1694822471,
"narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=",
"lastModified": 1695318763,
"narHash": "sha256-FHVPDRP2AfvsxAdc+AsgFJevMz5VBmnZglFUMlxBkcY=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "47585496bcb13fb72e4a90daeea2f434e2501998",
"rev": "e12483116b3b51a185a33a272bf351e357ba9a99",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixpkgs-unstable",
"repo": "nixpkgs",
"rev": "47585496bcb13fb72e4a90daeea2f434e2501998",
"type": "github"
}
},
@@ -717,11 +664,11 @@
"stackage": {
"flake": false,
"locked": {
"lastModified": 1726532152,
"narHash": "sha256-LRXbVY3M2S8uQWdwd2zZrsnVPEvt2GxaHGoy8EFFdJA=",
"lastModified": 1699834215,
"narHash": "sha256-g/JKy0BCvJaxPuYDl3QVc4OY8cFEomgG+hW/eEV470M=",
"owner": "input-output-hk",
"repo": "stackage.nix",
"rev": "c77b3530cebad603812cb111c6f64968c2d2337d",
"rev": "47aacd04abcce6bad57f43cbbbd133538380248e",
"type": "github"
},
"original": {
-7
View File
@@ -198,7 +198,6 @@
packages.direct-sqlcipher.components.library.libs = pkgs.lib.mkForce [
pkgs.pkgsCross.mingwW64.openssl
];
packages.simplexmq.flags.client_library = true;
packages.simplexmq.components.library.libs = pkgs.lib.mkForce [
pkgs.pkgsCross.mingwW64.openssl
];
@@ -336,7 +335,6 @@
packages.direct-sqlcipher.patches = [
./scripts/nix/direct-sqlcipher-android-log.patch
];
packages.simplexmq.flags.client_library = true;
packages.simplexmq.components.library.libs = pkgs.lib.mkForce [
(android32Pkgs.openssl.override { static = true; enableKTLS = false; })
];
@@ -445,7 +443,6 @@
packages.direct-sqlcipher.patches = [
./scripts/nix/direct-sqlcipher-android-log.patch
];
packages.simplexmq.flags.client_library = true;
packages.simplexmq.components.library.libs = pkgs.lib.mkForce [
(androidPkgs.openssl.override { static = true; })
];
@@ -550,7 +547,6 @@
packages.simplexmq.flags.swift = true;
packages.direct-sqlcipher.flags.commoncrypto = true;
packages.entropy.flags.DoNotGetEntropy = true;
packages.simplexmq.flags.client_library = true;
packages.simplexmq.components.library.libs = pkgs.lib.mkForce [
# TODO: have a cross override for iOS, that sets this.
((pkgs.openssl.override { static = true; }).overrideDerivation (old: { CFLAGS = "-mcpu=apple-a7 -march=armv8-a+norcpc" ;}))
@@ -565,7 +561,6 @@
extra-modules = [{
packages.direct-sqlcipher.flags.commoncrypto = true;
packages.entropy.flags.DoNotGetEntropy = true;
packages.simplexmq.flags.client_library = true;
packages.simplexmq.components.library.libs = pkgs.lib.mkForce [
((pkgs.openssl.override { static = true; }).overrideDerivation (old: { CFLAGS = "-mcpu=apple-a7 -march=armv8-a+norcpc" ;}))
];
@@ -583,7 +578,6 @@
packages.simplexmq.flags.swift = true;
packages.direct-sqlcipher.flags.commoncrypto = true;
packages.entropy.flags.DoNotGetEntropy = true;
packages.simplexmq.flags.client_library = true;
packages.simplexmq.components.library.libs = pkgs.lib.mkForce [
(pkgs.openssl.override { static = true; })
];
@@ -597,7 +591,6 @@
extra-modules = [{
packages.direct-sqlcipher.flags.commoncrypto = true;
packages.entropy.flags.DoNotGetEntropy = true;
packages.simplexmq.flags.client_library = true;
packages.simplexmq.components.library.libs = pkgs.lib.mkForce [
(pkgs.openssl.override { static = true; })
];
-2
View File
@@ -29,7 +29,6 @@ dependencies:
- email-validate == 2.3.*
- exceptions == 0.10.*
- filepath == 1.4.*
- file-embed == 0.0.15.*
- http-types == 0.12.*
- http2 >= 4.2.2 && < 4.3
- memory == 0.18.*
@@ -39,7 +38,6 @@ dependencies:
- optparse-applicative >= 0.15 && < 0.17
- random >= 1.1 && < 1.3
- record-hasfield == 1.0.*
- scientific ==0.3.7.*
- simple-logger == 0.1.*
- simplexmq >= 5.0
- socks == 0.6.*
+1 -1
View File
@@ -25,7 +25,7 @@ for elem in "${exports[@]}"; do count=$(grep -R "$elem$" libsimplex.dll.def | wc
for elem in "${exports[@]}"; do count=$(grep -R "\"$elem\"" flake.nix | wc -l); if [ $count -ne 2 ]; then echo Wrong exports in flake.nix. Add \"$elem\" in two places of the file; exit 1; fi ; done
rm -rf $BUILD_DIR
cabal build lib:simplex-chat --ghc-options='-optl-Wl,-rpath,$ORIGIN -flink-rts -threaded' --constraint 'simplexmq +client_library'
cabal build lib:simplex-chat --ghc-options='-optl-Wl,-rpath,$ORIGIN -flink-rts -threaded'
cd $BUILD_DIR/build
#patchelf --add-needed libHSrts_thr-ghc${GHC_VERSION}.so libHSsimplex-chat-*-inplace-ghc${GHC_VERSION}.so
#patchelf --add-rpath '$ORIGIN' libHSsimplex-chat-*-inplace-ghc${GHC_VERSION}.so
+1 -1
View File
@@ -24,7 +24,7 @@ for elem in "${exports[@]}"; do count=$(grep -R "$elem$" libsimplex.dll.def | wc
for elem in "${exports[@]}"; do count=$(grep -R "\"$elem\"" flake.nix | wc -l); if [ $count -ne 2 ]; then echo Wrong exports in flake.nix. Add \"$elem\" in two places of the file; exit 1; fi ; done
rm -rf $BUILD_DIR
cabal build lib:simplex-chat lib:simplex-chat --ghc-options="-optl-Wl,-rpath,@loader_path -optl-Wl,-L$GHC_LIBS_DIR/$ARCH-osx-ghc-$GHC_VERSION -optl-lHSrts_thr-ghc$GHC_VERSION -optl-lffi" --constraint 'simplexmq +client_library'
cabal build lib:simplex-chat lib:simplex-chat --ghc-options="-optl-Wl,-rpath,@loader_path -optl-Wl,-L$GHC_LIBS_DIR/$ARCH-osx-ghc-$GHC_VERSION -optl-lHSrts_thr-ghc$GHC_VERSION -optl-lffi"
cd $BUILD_DIR/build
mkdir deps 2> /dev/null || true
+1 -1
View File
@@ -51,7 +51,7 @@ echo " ghc-options: -shared -threaded -optl-L$openssl_windows_style_path -opt
# Very important! Without it the build fails on linking step since the linker can't find exported symbols.
# It looks like GHC bug because with such random path the build ends successfully
sed -i "s/ld.lld.exe/abracadabra.exe/" `ghc --print-libdir`/settings
cabal build lib:simplex-chat --constraint 'simplexmq +client_library'
cabal build lib:simplex-chat
rm -rf apps/multiplatform/common/src/commonMain/cpp/desktop/libs/$OS-$ARCH/
rm -rf apps/multiplatform/desktop/build/cmake
+1 -1
View File
@@ -1,5 +1,5 @@
{
"https://github.com/simplex-chat/simplexmq.git"."93f30c8edf9243ad2291dd6427d87328e282560a" = "1zf0sp9dy6kz4zvyz6mdgmhydps7khcq84n30irp983w1xh7gzs7";
"https://github.com/simplex-chat/simplexmq.git"."a8471eed5be93e7c3741aa4742b24193c9a2d6f5" = "093i40api0dp7rvw6f1f3pww3q5iv6mvbj577nlxp3qqcbvyh6fs";
"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";
+1 -17
View File
@@ -150,13 +150,11 @@ library
Simplex.Chat.Migrations.M20240920_user_order
Simplex.Chat.Migrations.M20241008_indexes
Simplex.Chat.Migrations.M20241010_contact_requests_contact_id
Simplex.Chat.Migrations.M20241027_server_operators
Simplex.Chat.Migrations.M20241023_chat_item_autoincrement_id
Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared
Simplex.Chat.Mobile.WebRTC
Simplex.Chat.Operators
Simplex.Chat.Operators.Conditions
Simplex.Chat.Options
Simplex.Chat.ProfileGenerator
Simplex.Chat.Protocol
@@ -216,7 +214,6 @@ library
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -227,7 +224,6 @@ library
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplexmq >=5.0
, socks ==0.6.*
@@ -281,7 +277,6 @@ executable simplex-bot
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -292,7 +287,6 @@ executable simplex-bot
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
@@ -347,7 +341,6 @@ executable simplex-bot-advanced
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -358,7 +351,6 @@ executable simplex-bot-advanced
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
@@ -416,7 +408,6 @@ executable simplex-broadcast-bot
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -427,7 +418,6 @@ executable simplex-broadcast-bot
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
@@ -483,7 +473,6 @@ executable simplex-chat
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -494,7 +483,6 @@ executable simplex-chat
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
@@ -556,7 +544,6 @@ executable simplex-directory-service
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
@@ -567,7 +554,6 @@ executable simplex-directory-service
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, simple-logger ==0.1.*
, simplex-chat
, simplexmq >=5.0
@@ -657,7 +643,6 @@ test-suite simplex-chat-test
, directory ==1.3.*
, email-validate ==2.3.*
, exceptions ==0.10.*
, file-embed ==0.0.15.*
, filepath ==1.4.*
, generic-random ==1.5.*
, http-types ==0.12.*
@@ -669,7 +654,6 @@ test-suite simplex-chat-test
, optparse-applicative >=0.15 && <0.17
, random >=1.1 && <1.3
, record-hasfield ==1.0.*
, scientific ==0.3.7.*
, silently ==1.2.*
, simple-logger ==0.1.*
, simplex-chat
+149 -307
View File
@@ -6,7 +6,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
@@ -44,7 +43,7 @@ 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.NonEmpty (NonEmpty (..), nonEmpty, toList, (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
@@ -68,7 +67,6 @@ 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.Options
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
import Simplex.Chat.Protocol
@@ -99,7 +97,7 @@ 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)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), ServerCfg (..), createAgentStore, defaultAgentConfig, enabledServerCfg, presetServerCfg)
import Simplex.Messaging.Agent.Lock (withLock)
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
@@ -139,32 +137,6 @@ import qualified UnliftIO.Exception as E
import UnliftIO.IO (hClose, hSeek, hTell, openFile)
import UnliftIO.STM
operatorSimpleXChat :: NewServerOperator
operatorSimpleXChat =
ServerOperator
{ operatorId = DBNewEntity,
operatorTag = Just OTSimplex,
tradeName = "SimpleX Chat",
legalName = Just "SimpleX Chat Ltd",
serverDomains = ["simplex.im"],
conditionsAcceptance = CARequired Nothing,
enabled = True,
roles = allRoles
}
operatorXYZ :: NewServerOperator
operatorXYZ =
ServerOperator
{ operatorId = DBNewEntity,
operatorTag = Just OTXyz,
tradeName = "XYZ",
legalName = Just "XYZ Ltd",
serverDomains = ["xyz.com"],
conditionsAcceptance = CARequired Nothing,
enabled = False,
roles = ServerRoles {storage = False, proxy = True}
}
defaultChatConfig :: ChatConfig
defaultChatConfig =
ChatConfig
@@ -175,25 +147,13 @@ defaultChatConfig =
},
chatVRange = supportedChatVRange,
confirmMigrations = MCConsole,
presetServers =
PresetServers
{ operators =
[ PresetOperator
{ operator = Just operatorSimpleXChat,
smp = simplexChatSMPServers,
useSMP = 4,
xftp = map (presetServer True) $ L.toList defaultXFTPServers,
useXFTP = 3
},
PresetOperator
{ operator = Just operatorXYZ,
smp = xyzSMPServers,
useSMP = 3,
xftp = xyzXFTPServers,
useXFTP = 3
}
],
defaultServers =
DefaultAgentServers
{ smp = _defaultSMPServers,
useSMP = 4,
ntf = _defaultNtfServers,
xftp = L.map (presetServerCfg True) defaultXFTPServers,
useXFTP = L.length defaultXFTPServers,
netCfg = defaultNetworkConfig
},
tbqSize = 1024,
@@ -217,52 +177,29 @@ defaultChatConfig =
chatHooks = defaultChatHooks
}
simplexChatSMPServers :: [NewUserServer 'PSMP]
simplexChatSMPServers =
map
(presetServer True)
[ "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion",
"smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion",
"smp://6iIcWT_dF2zN_w5xzZEY7HI2Prbh3ldP07YTyDexPjE=@smp10.simplex.im,rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion",
"smp://1OwYGt-yqOfe2IyVHhxz3ohqo3aCCMjtB-8wn4X_aoY=@smp11.simplex.im,6ioorbm6i3yxmuoezrhjk6f6qgkc4syabh7m3so74xunb5nzr4pwgfqd.onion",
"smp://UkMFNAXLXeAAe0beCa4w6X_zp18PwxSaSjY17BKUGXQ=@smp12.simplex.im,ie42b5weq7zdkghocs3mgxdjeuycheeqqmksntj57rmejagmg4eor5yd.onion",
"smp://enEkec4hlR3UtKx2NMpOUK_K4ZuDxjWBO1d9Y4YXVaA=@smp14.simplex.im,aspkyu2sopsnizbyfabtsicikr2s4r3ti35jogbcekhm3fsoeyjvgrid.onion",
"smp://h--vW7ZSkXPeOUpfxlFGgauQmXNFOzGoizak7Ult7cw=@smp15.simplex.im,oauu4bgijybyhczbnxtlggo6hiubahmeutaqineuyy23aojpih3dajad.onion",
"smp://hejn2gVIqNU6xjtGM3OwQeuk8ZEbDXVJXAlnSBJBWUA=@smp16.simplex.im,p3ktngodzi6qrf7w64mmde3syuzrv57y55hxabqcq3l5p6oi7yzze6qd.onion",
"smp://ZKe4uxF4Z_aLJJOEsC-Y6hSkXgQS5-oc442JQGkyP8M=@smp17.simplex.im,ogtwfxyi3h2h5weftjjpjmxclhb5ugufa5rcyrmg7j4xlch7qsr5nuqd.onion",
"smp://PtsqghzQKU83kYTlQ1VKg996dW4Cw4x_bvpKmiv8uns=@smp18.simplex.im,lyqpnwbs2zqfr45jqkncwpywpbtq7jrhxnib5qddtr6npjyezuwd3nqd.onion",
"smp://N_McQS3F9TGoh4ER0QstUf55kGnNSd-wXfNPZ7HukcM=@smp19.simplex.im,i53bbtoqhlc365k6kxzwdp5w3cdt433s7bwh3y32rcbml2vztiyyz5id.onion"
]
<> map
(presetServer False)
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
_defaultSMPServers :: NonEmpty (ServerCfg 'PSMP)
_defaultSMPServers =
L.fromList $
map
(presetServerCfg True)
[ "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion",
"smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion",
"smp://6iIcWT_dF2zN_w5xzZEY7HI2Prbh3ldP07YTyDexPjE=@smp10.simplex.im,rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion",
"smp://1OwYGt-yqOfe2IyVHhxz3ohqo3aCCMjtB-8wn4X_aoY=@smp11.simplex.im,6ioorbm6i3yxmuoezrhjk6f6qgkc4syabh7m3so74xunb5nzr4pwgfqd.onion",
"smp://UkMFNAXLXeAAe0beCa4w6X_zp18PwxSaSjY17BKUGXQ=@smp12.simplex.im,ie42b5weq7zdkghocs3mgxdjeuycheeqqmksntj57rmejagmg4eor5yd.onion",
"smp://enEkec4hlR3UtKx2NMpOUK_K4ZuDxjWBO1d9Y4YXVaA=@smp14.simplex.im,aspkyu2sopsnizbyfabtsicikr2s4r3ti35jogbcekhm3fsoeyjvgrid.onion",
"smp://h--vW7ZSkXPeOUpfxlFGgauQmXNFOzGoizak7Ult7cw=@smp15.simplex.im,oauu4bgijybyhczbnxtlggo6hiubahmeutaqineuyy23aojpih3dajad.onion",
"smp://hejn2gVIqNU6xjtGM3OwQeuk8ZEbDXVJXAlnSBJBWUA=@smp16.simplex.im,p3ktngodzi6qrf7w64mmde3syuzrv57y55hxabqcq3l5p6oi7yzze6qd.onion",
"smp://ZKe4uxF4Z_aLJJOEsC-Y6hSkXgQS5-oc442JQGkyP8M=@smp17.simplex.im,ogtwfxyi3h2h5weftjjpjmxclhb5ugufa5rcyrmg7j4xlch7qsr5nuqd.onion",
"smp://PtsqghzQKU83kYTlQ1VKg996dW4Cw4x_bvpKmiv8uns=@smp18.simplex.im,lyqpnwbs2zqfr45jqkncwpywpbtq7jrhxnib5qddtr6npjyezuwd3nqd.onion",
"smp://N_McQS3F9TGoh4ER0QstUf55kGnNSd-wXfNPZ7HukcM=@smp19.simplex.im,i53bbtoqhlc365k6kxzwdp5w3cdt433s7bwh3y32rcbml2vztiyyz5id.onion"
]
xyzSMPServers :: [NewUserServer 'PSMP]
xyzSMPServers =
map
(presetServer True)
[ "smp://abcd@smp1.xyz.com",
"smp://abcd@smp2.xyz.com",
"smp://abcd@smp3.xyz.com",
"smp://abcd@smp4.xyz.com",
"smp://abcd@smp5.xyz.com",
"smp://abcd@smp6.xyz.com"
]
xyzXFTPServers :: [NewUserServer 'PXFTP]
xyzXFTPServers =
map
(presetServer True)
[ "xftp://abcd@xftp1.xyz.com",
"xftp://abcd@xftp2.xyz.com",
"xftp://abcd@xftp3.xyz.com",
"xftp://abcd@xftp4.xyz.com",
"xftp://abcd@xftp5.xyz.com",
"xftp://abcd@xftp6.xyz.com"
]
<> map
(presetServerCfg False)
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
]
_defaultNtfServers :: [NtfServer]
_defaultNtfServers =
@@ -299,19 +236,16 @@ newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Boo
newChatController
ChatDatabase {chatStore, agentStore}
user
cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations}
cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, deviceNameForRemote, confirmMigrations}
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable, yesToUpMigrations}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
backgroundMode = do
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
confirmMigrations' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
firstTime = dbNew chatStore
currentUser <- newTVarIO user
randomSMP <- randomPresetServers SPSMP presetServers'
randomXFTP <- randomPresetServers SPXFTP presetServers'
let randomServers = RandomServers {smpServers = randomSMP, xftpServers = randomXFTP}
currentRemoteHost <- newTVarIO Nothing
servers <- withTransaction chatStore $ \db -> agentServers db config randomServers
servers <- agentServers config
smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode
agentAsync <- newTVarIO Nothing
random <- liftIO C.newRandom
@@ -347,7 +281,6 @@ newChatController
ChatController
{ firstTime,
currentUser,
randomServers,
currentRemoteHost,
smpAgent,
agentAsync,
@@ -385,39 +318,28 @@ newChatController
contactMergeEnabled
}
where
presetServers' :: PresetServers
presetServers' = presetServers {operators = operators', netCfg = netCfg'}
where
PresetServers {operators, netCfg} = presetServers
netCfg' = updateNetworkConfig netCfg simpleNetCfg
operators' = case (smpServers, xftpServers) of
([], []) -> operators
(smpSrvs, []) -> L.map removeSMP operators <> [custom smpSrvs []]
([], xftpSrvs) -> L.map removeXFTP operators <> [custom [] xftpSrvs]
(smpSrvs, xftpSrvs) -> [custom smpSrvs xftpSrvs]
removeSMP op = (op :: PresetOperator) {smp = []}
removeXFTP op = (op :: PresetOperator) {xftp = []}
custom smpSrvs xftpSrvs =
PresetOperator
{ operator = Nothing,
smp = map (presetServer True) smpSrvs,
useSMP = 0,
xftp = map (presetServer True) xftpSrvs,
useXFTP = 0
}
agentServers :: DB.Connection -> ChatConfig -> RandomServers -> IO InitialAgentServers
agentServers db ChatConfig {presetServers = PresetServers {operators = presetOps, ntf, netCfg}} randomServers = do
users <- getUsers db
opDomains <- operatorDomains <$> getUpdateServerOperators db presetOps (null users)
smp' <- getUserServers SPSMP users opDomains
xftp' <- getUserServers SPXFTP users opDomains
configServers :: DefaultAgentServers
configServers =
let DefaultAgentServers {smp = defSmp, xftp = defXftp, netCfg} = defaultServers
smp' = maybe defSmp (L.map enabledServerCfg) (nonEmpty smpServers)
xftp' = maybe defXftp (L.map enabledServerCfg) (nonEmpty xftpServers)
in defaultServers {smp = smp', xftp = xftp', netCfg = updateNetworkConfig netCfg simpleNetCfg}
agentServers :: ChatConfig -> IO InitialAgentServers
agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do
users <- withTransaction chatStore getUsers
smp' <- getUserServers users SPSMP
xftp' <- getUserServers users SPXFTP
pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg}
where
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [User] -> [(Text, ServerOperator)] -> IO (Map UserId (NonEmpty (ServerCfg p)))
getUserServers p users opDomains = do
let randomSrvs = rndServers p randomServers
fmap M.fromList $ forM users $ \u ->
(aUserId u,) . agentServerCfgs opDomains <$> getUpdateUserServers db p presetOps randomSrvs u
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ServerCfg p)))
getUserServers users protocol = case users of
[] -> pure $ M.fromList [(1, cfgServers protocol defServers)]
_ -> M.fromList <$> initialServers
where
initialServers :: IO [(UserId, NonEmpty (ServerCfg p))]
initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users
userServers :: User -> IO (NonEmpty (ServerCfg p))
userServers user' = useServers config protocol <$> withTransaction chatStore (`getProtocolServers` user')
updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig
updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} =
@@ -460,37 +382,33 @@ withFileLock :: String -> Int64 -> CM a -> CM a
withFileLock name = withEntityLock name . CLFile
{-# INLINE withFileLock #-}
serverCfg :: ProtoServerWithAuth p -> ServerCfg p
serverCfg server = ServerCfg {server, operator = Nothing, enabled = True, roles = allRoles}
useServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ServerCfg p)
useServers ChatConfig {defaultServers} p = fromMaybe (cfgServers p defaultServers) . nonEmpty
useServers :: forall p. UserProtocol p => SProtocolType p -> RandomServers -> [UserServer p] -> NonEmpty (NewUserServer p)
useServers p rs servers = case L.nonEmpty servers of
Nothing -> rndServers p rs
Just srvs -> L.map (\srv -> (srv :: UserServer p) {serverId = DBNewEntity}) srvs
rndServers :: UserProtocol p => SProtocolType p -> RandomServers -> NonEmpty (NewUserServer p)
rndServers p RandomServers {smpServers, xftpServers} = case p of
SPSMP -> smpServers
SPXFTP -> xftpServers
randomPresetServers :: forall p. UserProtocol p => SProtocolType p -> PresetServers -> IO (NonEmpty (NewUserServer p))
randomPresetServers p PresetServers {operators} = toJust . L.nonEmpty . concat =<< mapM opSrvs operators
randomServers :: forall p. UserProtocol p => SProtocolType p -> ChatConfig -> IO (NonEmpty (ServerCfg p), [ServerCfg p])
randomServers p ChatConfig {defaultServers} = do
let srvs = cfgServers p defaultServers
(enbldSrvs, dsbldSrvs) = L.partition (\ServerCfg {enabled} -> enabled) srvs
toUse = cfgServersToUse p defaultServers
if length enbldSrvs <= toUse
then pure (srvs, [])
else do
(enbldSrvs', srvsToDisable) <- splitAt toUse <$> shuffle enbldSrvs
let dsbldSrvs' = map (\srv -> (srv :: ServerCfg p) {enabled = False}) srvsToDisable
srvs' = sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs
pure (fromMaybe srvs $ L.nonEmpty srvs', srvs')
where
toJust = \case
Just a -> pure a
Nothing -> E.throwIO $ userError "no preset servers"
opSrvs :: PresetOperator -> IO [NewUserServer p]
opSrvs op = do
let srvs = operatorServers p op
toUse = operatorServersToUse p op
(enbldSrvs, dsbldSrvs) = partition (\UserServer {enabled} -> enabled) srvs
if toUse <= 0 || toUse >= length enbldSrvs
then pure srvs
else do
(enbldSrvs', srvsToDisable) <- splitAt toUse <$> shuffle enbldSrvs
let dsbldSrvs' = map (\srv -> (srv :: NewUserServer p) {enabled = False}) srvsToDisable
pure $ sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs
server' UserServer {server = ProtoServerWithAuth srv _} = srv
server' ServerCfg {server = ProtoServerWithAuth srv _} = srv
cfgServers :: UserProtocol p => SProtocolType p -> DefaultAgentServers -> NonEmpty (ServerCfg p)
cfgServers p DefaultAgentServers {smp, xftp} = case p of
SPSMP -> smp
SPXFTP -> xftp
cfgServersToUse :: UserProtocol p => SProtocolType p -> DefaultAgentServers -> Int
cfgServersToUse p DefaultAgentServers {useSMP, useXFTP} = case p of
SPSMP -> useSMP
SPXFTP -> useXFTP
-- enableSndFiles has no effect when mainApp is True
startChatController :: Bool -> Bool -> CM' (Async ())
@@ -634,23 +552,19 @@ processChatCommand' vr = \case
forM_ profile $ \Profile {displayName} -> checkValidName displayName
p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile
u <- asks currentUser
smpServers <- chooseServers SPSMP
xftpServers <- chooseServers SPXFTP
(smp, smpServers) <- chooseServers SPSMP
(xftp, xftpServers) <- chooseServers SPXFTP
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 = ""}
opDomains <- operatorDomains . fst <$> withFastStore getServerOperators
let smp = agentServerCfgs opDomains smpServers
xftp = agentServerCfgs opDomains xftpServers
auId <- withAgent (\a -> createUser a smp xftp)
ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure
user <- withFastStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts
createPresetContactCards user `catchChatError` \_ -> pure ()
withFastStore $ \db -> do
createNoteFolder db user
liftIO $ mapM_ (insertProtocolServer db SPSMP user ts) smpServers
liftIO $ mapM_ (insertProtocolServer db SPXFTP user ts) xftpServers
withFastStore $ \db -> createNoteFolder db user
storeServers user smpServers
storeServers user xftpServers
atomically . writeTVar u $ Just user
pure $ CRActiveUser user
where
@@ -659,11 +573,18 @@ processChatCommand' vr = \case
withFastStore $ \db -> do
createContact db user simplexStatusContactProfile
createContact db user simplexTeamContactProfile
chooseServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> CM (NonEmpty (NewUserServer p))
chooseServers p = do
rs <- asks randomServers
srvs <- chatReadVar currentUser >>= mapM (\user -> withFastStore' $ \db -> getProtocolServers db p user)
pure $ useServers p rs $ fromMaybe [] srvs
chooseServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> CM (NonEmpty (ServerCfg p), [ServerCfg p])
chooseServers protocol =
asks currentUser >>= readTVarIO >>= \case
Nothing -> asks config >>= liftIO . randomServers protocol
Just user -> chosenServers =<< withFastStore' (`getProtocolServers` user)
where
chosenServers servers = do
cfg <- asks config
pure (useServers cfg protocol servers, servers)
storeServers user servers =
unless (null servers) . withFastStore $
\db -> overwriteProtocolServers db user servers
coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day)
day = 86400
ListUsers -> CRUsersList <$> withFastStore' getUsersInfo
@@ -814,14 +735,14 @@ processChatCommand' vr = \case
APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of
-- TODO optimize queries calculating ChatStats, currently they're disabled
CTDirect -> do
directChat <- withFastStore (\db -> getDirectChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTDirect directChat)
(directChat, section) <- withFastStore (\db -> getDirectChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTDirect directChat) section
CTGroup -> do
groupChat <- withFastStore (\db -> getGroupChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTGroup groupChat)
(groupChat, section) <- withFastStore (\db -> getGroupChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTGroup groupChat) section
CTLocal -> do
localChat <- withFastStore (\db -> getLocalChat db user cId pagination search)
pure $ CRApiChat user (AChat SCTLocal localChat)
(localChat, section) <- withFastStore (\db -> getLocalChat db user cId pagination search)
pure $ CRApiChat user (AChat SCTLocal localChat) section
CTContactRequest -> pure $ chatCmdError (Just user) "not implemented"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIGetChatItems pagination search -> withUser $ \user -> do
@@ -1561,95 +1482,25 @@ processChatCommand' vr = \case
msgs <- lift $ withAgent' $ \a -> getConnectionMessages a acIds
let ntfMsgs = L.map (\msg -> receivedMsgInfo <$> msg) msgs
pure $ CRConnNtfMessages ntfMsgs
GetUserProtoServers (AProtocolType p) -> withUser $ \user@User {userId} -> withServerProtocol p $ do
(operators, smpServers, xftpServers) <- withFastStore (`getUserServers` user)
userServers <- liftIO $ groupByOperator $ case p of
SPSMP -> (operators, smpServers, [])
SPXFTP -> (operators, [], xftpServers)
pure $ CRUserServers user userServers
SetUserProtoServers (AProtocolType p) servers -> withUser $ \user@User {userId} -> withServerProtocol p $ do
userServers <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user)
-- disable operators servers and repace (or add) custom servers, or restore random defaults if empty list
case L.nonEmpty userServers of
Just srvs -> processChatCommand $ APISetUserServers userId $ L.map updated srvs
where
updated UserOperatorServers {operator, smpServers, xftpServers} =
UpdatedUserOperatorServers
{ operator,
smpServers = map (AUS SDBStored) smpServers,
xftpServers = map (AUS SDBStored) xftpServers
}
Nothing -> throwChatError $ CECommandError "no servers"
APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
cfg@ChatConfig {defaultServers} <- asks config
servers <- withFastStore' (`getProtocolServers` user)
pure $ CRUserProtoServers user $ AUPS $ UserProtoServers p (useServers cfg p servers) (cfgServers p defaultServers)
GetUserProtoServers aProtocol -> withUser $ \User {userId} ->
processChatCommand $ APIGetUserProtoServers userId aProtocol
APISetUserProtoServers userId (APSC p (ProtoServersConfig servers))
| null servers || any (\ServerCfg {enabled} -> enabled) servers -> withUserId userId $ \user -> withServerProtocol p $ do
withFastStore $ \db -> overwriteProtocolServers db user servers
cfg <- asks config
lift $ withAgent' $ \a -> setProtocolServers a (aUserId user) $ useServers cfg p servers
ok user
| otherwise -> withUserId userId $ \user -> pure $ chatCmdError (Just user) "all servers are disabled"
SetUserProtoServers serversConfig -> withUser $ \User {userId} ->
processChatCommand $ APISetUserProtoServers userId serversConfig
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
APITestServerOperator -> do
let serverOperator = ServerOperator {
operatorId = DBEntityId 1,
operatorTag = Just OTSimplex,
tradeName = "Simplex",
legalName = Just "Simplex",
serverDomains = ["simplex.im"],
conditionsAcceptance = CAAccepted Nothing,
enabled = True,
roles = ServerRoles {storage = True, proxy = True}
}
pure $ CRTestOperator serverOperator
APITestUsageConditionsAction -> do
ts <- liftIO getCurrentTime
let conditionsAction = Just $ UCAReview {
operators = [],
deadline = Just ts,
showNotice = True
}
pure $ CRTestUsageConditionsAction conditionsAction
APITestConditionsAcceptance -> do
let acceptance = CAAccepted Nothing
pure $ CRTestConditionsAcceptance acceptance
APITestServerRoles -> do
let serverRoles = ServerRoles {storage = True, proxy = True}
pure $ CRTestServerRoles serverRoles
APIGetServerOperators -> uncurry CRServerOperators <$> withFastStore getServerOperators
APISetServerOperators operatorsEnabled -> withFastStore $ \db -> do
liftIO $ setServerOperators db operatorsEnabled
uncurry CRServerOperators <$> getServerOperators db
APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db ->
CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user)
APISetUserServers userId userServers -> withUserId userId $ \user -> do
let errors = validateUserServers userServers
unless (null errors) $ throwChatError (CECommandError $ "user servers validation error(s): " <> show errors)
(operators, smpServers, xftpServers) <- withFastStore $ \db -> do
setUserServers db user userServers
getUserServers db user
let opDomains = operatorDomains operators
rs <- asks randomServers
lift $ withAgent' $ \a -> do
let auId = aUserId user
setProtocolServers a auId $ agentServerCfgs opDomains $ useServers SPSMP rs smpServers
setProtocolServers a auId $ agentServerCfgs opDomains $ useServers SPXFTP rs xftpServers
ok_
APIValidateServers userServers -> pure $ CRUserServersValidation $ validateUserServers 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
uncurry CRServerOperators <$> getServerOperators db
APISetChatItemTTL userId newTTL_ -> withUserId userId $ \user ->
checkStoreNotChanged $
withChatLock "setChatItemTTL" $ do
@@ -1902,7 +1753,8 @@ processChatCommand' vr = \case
canKeepLink (CRInvitationUri crData _) newUser = do
let ConnReqUriData {crSmpQueues = q :| _} = crData
SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q
newUserServers <- map (\UserServer {server} -> protoServer server) <$> withFastStore' (\db -> getProtocolServers db SPSMP newUser)
cfg <- asks config
newUserServers <- L.map (\ServerCfg {server} -> protoServer server) . useServers cfg SPSMP <$> withFastStore' (`getProtocolServers` newUser)
pure $ smpServer `elem` newUserServers
updateConnRecord user@User {userId} conn@PendingContactConnection {customUserProfileId} newUser = do
withAgent $ \a -> changeConnectionUser a (aUserId user) (aConnId' conn) (aUserId newUser)
@@ -2236,7 +2088,7 @@ processChatCommand' vr = \case
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])
assertUserGroupRole gInfo $ maximum [GRAdmin, mRole, memRole]
withGroupLock "memberRole" groupId . procCmd $ do
unless (mRole == memRole) $ do
withFastStore' $ \db -> updateGroupMemberRole db user m memRole
@@ -2634,15 +2486,14 @@ processChatCommand' vr = \case
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
cfg <- asks config
(users, smpServers, xftpServers) <-
withStore' $ \db -> (,,) <$> getUsers db <*> getServers db cfg user SPSMP <*> getServers db cfg user SPXFTP
let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers _defaultNtfServers
pure $ CRAgentServersSummary user presentedServersSummary
where
getServers :: (ProtocolTypeI p, UserProtocol p) => DB.Connection -> User -> SProtocolType p -> IO [ProtocolServer p]
getServers db user p = map (\UserServer {server} -> protoServer server) <$> getProtocolServers db p user
getServers :: (ProtocolTypeI p, UserProtocol p) => DB.Connection -> ChatConfig -> User -> SProtocolType p -> IO (NonEmpty (ProtocolServer p))
getServers db cfg user p = L.map (\ServerCfg {server} -> protoServer server) . useServers cfg p <$> getProtocolServers db user
ResetAgentServersStats -> withAgent resetAgentServersStats >> ok_
GetAgentWorkers -> lift $ CRAgentWorkersSummary <$> withAgent' getAgentWorkersSummary
GetAgentWorkersDetails -> lift $ CRAgentWorkersDetails <$> withAgent' getAgentWorkersDetails
@@ -3760,7 +3611,8 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
S.toList $ S.fromList $ concatMap (\FD.FileChunk {replicas} -> map (\FD.FileChunkReplica {server} -> server) replicas) chunks
getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer]
getUnknownSrvs srvs = do
knownSrvs <- map (\UserServer {server} -> protoServer server) <$> withStore' (\db -> getProtocolServers db SPXFTP user)
cfg <- asks config
knownSrvs <- L.map (\ServerCfg {server} -> protoServer server) . useServers cfg SPXFTP <$> withStore' (`getProtocolServers` user)
pure $ filter (`notElem` knownSrvs) srvs
ipProtectedForSrvs :: [XFTPServer] -> CM Bool
ipProtectedForSrvs srvs = do
@@ -3972,7 +3824,7 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do
(sftConns, sfts) <- getSndFileTransferConns
(rftConns, rfts) <- getRcvFileTransferConns
(pcConns, pcs) <- getPendingContactConns
let conns = concat ([ctConns, ucConns, mConns, sftConns, rftConns, pcConns] :: [[ConnId]])
let conns = concat [ctConns, ucConns, mConns, sftConns, rftConns, pcConns]
pure (conns, cts, ucs, gs, ms, sfts, rfts, pcs)
-- subscribe using batched commands
rs <- withAgent $ \a -> agentBatchSubscribe a conns
@@ -4780,7 +4632,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
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
when (phase `elem` [SPStarted, 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 ->
@@ -5065,7 +4917,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(Just fileDescrText, Just msgId) -> do
partSize <- asks $ xftpDescrPartSize . config
let parts = splitFileDescr partSize fileDescrText
pure . L.toList $ L.map (XMsgFileDescr msgId) parts
pure . toList $ L.map (XMsgFileDescr msgId) parts
_ -> pure []
let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents
GroupMember {memberId} = sender
@@ -5191,7 +5043,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
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
when (phase `elem` [SPStarted, 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 ->
@@ -6755,17 +6607,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
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
inviteeXGrpMemCon GroupMemberIntro {introId, introStatus}
| introStatus == GMIntroReConnected = updateStatus introId GMIntroConnected
| introStatus `elem` [GMIntroToConnected, GMIntroConnected] = pure ()
| otherwise = updateStatus introId GMIntroToConnected
forwardMemberXGrpMemCon :: GroupMemberIntro -> CM ()
forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of
GMIntroToConnected -> updateStatus introId GMIntroConnected
GMIntroReConnected -> pure ()
GMIntroConnected -> pure ()
_ -> updateStatus introId GMIntroReConnected
forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus}
| introStatus == GMIntroToConnected = updateStatus introId GMIntroConnected
| introStatus `elem` [GMIntroReConnected, GMIntroConnected] = pure ()
| otherwise = updateStatus introId GMIntroReConnected
updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> CM ()
@@ -8230,24 +8080,14 @@ chatCommandP =
"/smp test " *> (TestProtoServer . AProtoServerWithAuth SPSMP <$> strP),
"/xftp test " *> (TestProtoServer . AProtoServerWithAuth SPXFTP <$> strP),
"/ntf test " *> (TestProtoServer . AProtoServerWithAuth SPNTF <$> strP),
"/_dec_operator" $> APITestServerOperator,
"/_dec_conditions_action" $> APITestUsageConditionsAction,
"/_dec_acceptance" $> APITestConditionsAcceptance,
"/_dec_roles" $> APITestServerRoles,
"/smp " *> (SetUserProtoServers (AProtocolType SPSMP) . map (AProtoServerWithAuth SPSMP) <$> protocolServersP),
"/smp default" $> SetUserProtoServers (AProtocolType SPSMP) [],
"/xftp " *> (SetUserProtoServers (AProtocolType SPXFTP) . map (AProtoServerWithAuth SPXFTP) <$> protocolServersP),
"/xftp default" $> SetUserProtoServers (AProtocolType SPXFTP) [],
"/_servers " *> (APISetUserProtoServers <$> A.decimal <* A.space <*> srvCfgP),
"/smp " *> (SetUserProtoServers . APSC SPSMP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP),
"/smp default" $> SetUserProtoServers (APSC SPSMP $ ProtoServersConfig []),
"/xftp " *> (SetUserProtoServers . APSC SPXFTP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP),
"/xftp default" $> SetUserProtoServers (APSC SPXFTP $ ProtoServersConfig []),
"/_servers " *> (APIGetUserProtoServers <$> A.decimal <* A.space <*> strP),
"/smp" $> GetUserProtoServers (AProtocolType SPSMP),
"/xftp" $> GetUserProtoServers (AProtocolType SPXFTP),
"/_operators" $> APIGetServerOperators,
"/_operators " *> (APISetServerOperators <$> jsonP),
"/_servers " *> (APIGetUserServers <$> A.decimal),
"/_servers " *> (APISetUserServers <$> A.decimal <* A.space <*> jsonP),
"/_validate_servers " *> (APIValidateServers <$> 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),
@@ -8461,6 +8301,8 @@ chatCommandP =
(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)
@@ -8589,7 +8431,7 @@ chatCommandP =
onOffP
(Just <$> (AutoAccept <$> (" incognito=" *> onOffP <|> pure False) <*> optional (A.space *> msgContentP)))
(pure Nothing)
-- srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP)
srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP)
rcCtrlAddressP = RCCtrlAddress <$> ("addr=" *> strP) <*> (" iface=" *> (jsonP <|> text1P))
text1P = safeDecodeUtf8 <$> A.takeTill (== ' ')
char_ = optional . A.char
+9 -7
View File
@@ -12,7 +12,6 @@ import Control.Concurrent.STM
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Chat.Controller
import Simplex.Chat.Core
@@ -32,10 +31,10 @@ chatBotRepl welcome answer _user cc = do
case resp of
CRContactConnected _ contact _ -> do
contactConnected contact
void $ sendMessage cc contact $ T.pack welcome
void $ sendMessage cc contact welcome
CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) : _} -> do
let msg = T.unpack $ ciContentToText mc
void $ sendMessage cc contact . T.pack =<< answer contact msg
void $ sendMessage cc contact =<< answer contact msg
_ -> pure ()
where
contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"
@@ -58,11 +57,11 @@ initializeBotAddress' logAddress cc = do
when logAddress $ putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri)
void $ sendChatCmd cc $ AddressAutoAccept $ Just AutoAccept {acceptIncognito = False, autoReply = Nothing}
sendMessage :: ChatController -> Contact -> Text -> IO ()
sendMessage cc ct = sendComposedMessage cc ct Nothing . MCText
sendMessage :: ChatController -> Contact -> String -> IO ()
sendMessage cc ct = sendComposedMessage cc ct Nothing . textMsgContent
sendMessage' :: ChatController -> ContactId -> Text -> IO ()
sendMessage' cc ctId = sendComposedMessage' cc ctId Nothing . MCText
sendMessage' :: ChatController -> ContactId -> String -> IO ()
sendMessage' cc ctId = sendComposedMessage' cc ctId Nothing . textMsgContent
sendComposedMessage :: ChatController -> Contact -> Maybe ChatItemId -> MsgContent -> IO ()
sendComposedMessage cc = sendComposedMessage' cc . contactId'
@@ -84,6 +83,9 @@ deleteMessage cc ct chatItemId = do
contactRef :: Contact -> ChatRef
contactRef = ChatRef CTDirect . contactId'
textMsgContent :: String -> MsgContent
textMsgContent = MCText . T.pack
printLog :: ChatController -> ChatLogLevel -> String -> IO ()
printLog cc level s
| logLevel (config cc) <= level = putStrLn s
+2 -2
View File
@@ -18,8 +18,8 @@ data KnownContact = KnownContact
}
deriving (Eq)
knownContactNames :: [KnownContact] -> Text
knownContactNames = T.intercalate ", " . map (("@" <>) . localDisplayName)
knownContactNames :: [KnownContact] -> String
knownContactNames = T.unpack . T.intercalate ", " . map (("@" <>) . localDisplayName)
parseKnownContacts :: ReadM [KnownContact]
parseKnownContacts = eitherReader $ parseAll knownContactsP . encodeUtf8 . T.pack
+53 -64
View File
@@ -35,6 +35,7 @@ import qualified Data.ByteArray as BA
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (ord)
import Data.Constraint (Dict (..))
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
@@ -56,7 +57,6 @@ import Simplex.Chat.Call
import Simplex.Chat.Markdown (MarkdownList)
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Operators
import Simplex.Chat.Protocol
import Simplex.Chat.Remote.AppVersion
import Simplex.Chat.Remote.Types
@@ -70,7 +70,7 @@ import Simplex.Chat.Util (liftIOEither)
import Simplex.FileTransfer.Description (FileDescriptionURI)
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerRoles)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction, withTransactionPriority)
@@ -84,7 +84,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), QueueId, SMPMsgMeta (..), SubscriptionMode (..), XFTPServer)
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), ProtocolTypeI, QueueId, SMPMsgMeta (..), SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol)
import Simplex.Messaging.TMap (TMap)
import Simplex.Messaging.Transport (TLS, simplexMQVersion)
import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost)
@@ -132,7 +132,7 @@ data ChatConfig = ChatConfig
{ agentConfig :: AgentConfig,
chatVRange :: VersionRangeChat,
confirmMigrations :: MigrationConfirmation,
presetServers :: PresetServers,
defaultServers :: DefaultAgentServers,
tbqSize :: Natural,
fileChunkSize :: Integer,
xftpDescrPartSize :: Int,
@@ -154,11 +154,6 @@ data ChatConfig = ChatConfig
chatHooks :: ChatHooks
}
data RandomServers = RandomServers
{ smpServers :: NonEmpty (NewUserServer 'PSMP),
xftpServers :: NonEmpty (NewUserServer 'PXFTP)
}
-- The hooks can be used to extend or customize chat core in mobile or CLI clients.
data ChatHooks = ChatHooks
{ -- preCmdHook can be used to process or modify the commands before they are processed.
@@ -177,9 +172,12 @@ defaultChatHooks =
eventHook = \_ -> pure
}
data PresetServers = PresetServers
{ operators :: NonEmpty PresetOperator,
data DefaultAgentServers = DefaultAgentServers
{ smp :: NonEmpty (ServerCfg 'PSMP),
useSMP :: Int,
ntf :: [NtfServer],
xftp :: NonEmpty (ServerCfg 'PXFTP),
useXFTP :: Int,
netCfg :: NetworkConfig
}
@@ -205,7 +203,6 @@ data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLite
data ChatController = ChatController
{ currentUser :: TVar (Maybe User),
randomServers :: RandomServers,
currentRemoteHost :: TVar (Maybe RemoteHostId),
firstTime :: Bool,
smpAgent :: AgentClient,
@@ -349,22 +346,12 @@ data ChatCommand
| APIGetGroupLink GroupId
| APICreateMemberContact GroupId GroupMemberId
| APISendMemberContactInvitation {contactId :: ContactId, msgContent_ :: Maybe MsgContent}
| APIGetUserProtoServers UserId AProtocolType
| GetUserProtoServers AProtocolType
| SetUserProtoServers AProtocolType [AProtoServerWithAuth]
| APISetUserProtoServers UserId AProtoServersConfig
| SetUserProtoServers AProtoServersConfig
| APITestProtoServer UserId AProtoServerWithAuth
| TestProtoServer AProtoServerWithAuth
| APITestServerOperator
| APITestUsageConditionsAction
| APITestConditionsAcceptance
| APITestServerRoles
| APIGetServerOperators
| APISetServerOperators (NonEmpty ServerOperator)
| APIGetUserServers UserId
| APISetUserServers UserId (NonEmpty UpdatedUserOperatorServers)
| APIValidateServers (NonEmpty UpdatedUserOperatorServers) -- response is CRUserServersValidation
| APIGetUsageConditions
| APISetConditionsNotified Int64
| APIAcceptConditions Int64 (NonEmpty Int64)
| APISetChatItemTTL UserId (Maybe Int64)
| SetChatItemTTL (Maybe Int64)
| APIGetChatItemTTL UserId
@@ -585,20 +572,13 @@ data ChatResponse
| CRChatSuspended
| CRApiChats {user :: User, chats :: [AChat]}
| CRChats {chats :: [AChat]}
| CRApiChat {user :: User, chat :: AChat}
| CRApiChat {user :: User, chat :: AChat, section :: ChatLandingSection}
| CRChatItems {user :: User, chatName_ :: Maybe ChatName, chatItems :: [AChatItem]}
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
| CRChatItemId User (Maybe ChatItemId)
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
| CRUserProtoServers {user :: User, servers :: AUserProtoServers}
| CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
| CRTestOperator {operator :: ServerOperator}
| CRTestUsageConditionsAction {conditionsAction :: Maybe UsageConditionsAction}
| CRTestConditionsAcceptance {acceptance :: ConditionsAcceptance}
| CRTestServerRoles {roles :: ServerRoles}
| CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction}
| CRUserServers {user :: User, userServers :: [UserOperatorServers]}
| CRUserServersValidation {serverErrors :: [UserServersError]}
| CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions}
| CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}
| CRNetworkConfig {networkConfig :: NetworkConfig}
| CRContactInfo {user :: User, contact :: Contact, connectionStats_ :: Maybe ConnectionStats, customUserProfile :: Maybe Profile}
@@ -859,8 +839,15 @@ data ChatPagination
= CPLast Int
| CPAfter ChatItemId Int
| CPBefore ChatItemId Int
| CPAround ChatItemId Int
| CPInitial Int
deriving (Show)
data ChatLandingSection
= CLSLatest
| CLSUnread
deriving (Show, Eq)
data PaginationByTime
= PTLast Int
| PTAfter UTCTime Int
@@ -961,23 +948,23 @@ instance ToJSON AgentQueueId where
toJSON = strToJSON
toEncoding = strToJEncoding
-- data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
-- deriving (Show)
data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
deriving (Show)
-- data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
-- deriving instance Show AProtoServersConfig
deriving instance Show AProtoServersConfig
-- data UserProtoServers p = UserProtoServers
-- { serverProtocol :: SProtocolType p,
-- protoServers :: NonEmpty (ServerCfg p),
-- presetServers :: NonEmpty (ServerCfg p)
-- }
-- deriving (Show)
data UserProtoServers p = UserProtoServers
{ serverProtocol :: SProtocolType p,
protoServers :: NonEmpty (ServerCfg p),
presetServers :: NonEmpty (ServerCfg p)
}
deriving (Show)
-- data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
-- deriving instance Show AUserProtoServers
deriving instance Show AUserProtoServers
data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool, parentTempDirectory :: Maybe FilePath}
deriving (Show)
@@ -1580,28 +1567,28 @@ $(JQ.deriveJSON defaultJSON ''CoreVersionInfo)
$(JQ.deriveJSON defaultJSON ''SlowSQLQuery)
-- instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
-- parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
-- instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
-- parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
-- instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
-- toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
-- toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
-- instance FromJSON AUserProtoServers where
-- parseJSON v = J.withObject "AUserProtoServers" parse v
-- where
-- parse o = do
-- AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
-- case userProtocol p of
-- Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
-- Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
instance FromJSON AUserProtoServers where
parseJSON v = J.withObject "AUserProtoServers" parse v
where
parse o = do
AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
case userProtocol p of
Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
-- instance ToJSON AUserProtoServers where
-- toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
-- toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
instance ToJSON AUserProtoServers where
toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCS") ''RemoteCtrlSessionState)
@@ -1611,6 +1598,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCSR") ''RemoteCtrlStopReason)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RHSR") ''RemoteHostStopReason)
$(JQ.deriveJSON (enumJSON $ dropPrefix "CLS") ''ChatLandingSection)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CR") ''ChatResponse)
$(JQ.deriveFromJSON defaultJSON ''ArchiveConfig)
+6
View File
@@ -239,6 +239,12 @@ chatItemTs (CChatItem _ ci) = chatItemTs' ci
chatItemTs' :: ChatItem c d -> UTCTime
chatItemTs' ChatItem {meta = CIMeta {itemTs}} = itemTs
chatItemCreatedAt :: CChatItem c -> UTCTime
chatItemCreatedAt (CChatItem _ ci) = chatItemCreatedAt' ci
chatItemCreatedAt' :: ChatItem c d -> UTCTime
chatItemCreatedAt' ChatItem {meta = CIMeta {createdAt}} = createdAt
chatItemTimed :: ChatItem c d -> Maybe CITimed
chatItemTimed ChatItem {meta = CIMeta {itemTimed}} = itemTimed
@@ -0,0 +1,34 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20241023_chat_item_autoincrement_id where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20241023_chat_item_autoincrement_id :: Query
m20241023_chat_item_autoincrement_id =
[sql|
INSERT INTO sqlite_sequence (name, seq)
SELECT 'chat_items', MAX(ROWID) FROM chat_items;
PRAGMA writable_schema=1;
UPDATE sqlite_master SET sql = replace(sql, 'INTEGER PRIMARY KEY', 'INTEGER PRIMARY KEY AUTOINCREMENT')
WHERE name = 'chat_items' AND type = 'table';
PRAGMA writable_schema=0;
|]
down_m20241023_chat_item_autoincrement_id :: Query
down_m20241023_chat_item_autoincrement_id =
[sql|
DELETE FROM sqlite_sequence WHERE name = 'chat_items';
PRAGMA writable_schema=1;
UPDATE sqlite_master
SET sql = replace(sql, 'INTEGER PRIMARY KEY AUTOINCREMENT', 'INTEGER PRIMARY KEY')
WHERE name = 'chat_items' AND type = 'table';
PRAGMA writable_schema=0;
|]
@@ -1,54 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20241027_server_operators where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20241027_server_operators :: Query
m20241027_server_operators =
[sql|
CREATE TABLE server_operators (
server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
server_operator_tag TEXT,
trade_name TEXT NOT NULL,
legal_name TEXT,
server_domains TEXT,
enabled INTEGER NOT NULL DEFAULT 1,
role_storage INTEGER NOT NULL DEFAULT 1,
role_proxy INTEGER NOT NULL DEFAULT 1,
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
);
CREATE TABLE usage_conditions (
usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
conditions_commit TEXT NOT NULL UNIQUE,
notified_at TEXT,
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
);
CREATE TABLE operator_usage_conditions (
operator_usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
server_operator_id INTEGER REFERENCES server_operators (server_operator_id) ON DELETE SET NULL ON UPDATE CASCADE,
server_operator_tag TEXT,
conditions_commit TEXT NOT NULL,
accepted_at TEXT,
created_at TEXT NOT NULL DEFAULT (datetime('now'))
);
CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(server_operator_id);
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(conditions_commit, server_operator_id);
|]
down_m20241027_server_operators :: Query
down_m20241027_server_operators =
[sql|
DROP INDEX idx_operator_usage_conditions_conditions_commit;
DROP INDEX idx_operator_usage_conditions_server_operator_id;
DROP TABLE operator_usage_conditions;
DROP TABLE usage_conditions;
DROP TABLE server_operators;
|]
+2 -36
View File
@@ -360,7 +360,7 @@ CREATE TABLE pending_group_messages(
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE chat_items(
chat_item_id INTEGER PRIMARY KEY,
chat_item_id INTEGER PRIMARY KEY AUTOINCREMENT,
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
contact_id INTEGER REFERENCES contacts ON DELETE CASCADE,
group_id INTEGER REFERENCES groups ON DELETE CASCADE,
@@ -399,6 +399,7 @@ CREATE TABLE chat_items(
fwd_from_chat_item_id INTEGER REFERENCES chat_items ON DELETE SET NULL,
via_proxy INTEGER
);
CREATE TABLE sqlite_sequence(name,seq);
CREATE TABLE chat_item_messages(
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
message_id INTEGER NOT NULL UNIQUE REFERENCES messages ON DELETE CASCADE,
@@ -429,7 +430,6 @@ CREATE TABLE commands(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE sqlite_sequence(name,seq);
CREATE TABLE settings(
settings_id INTEGER PRIMARY KEY,
chat_item_ttl INTEGER,
@@ -589,33 +589,6 @@ CREATE TABLE note_folders(
unread_chat INTEGER NOT NULL DEFAULT 0
);
CREATE TABLE app_settings(app_settings TEXT NOT NULL);
CREATE TABLE server_operators(
server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
server_operator_tag TEXT,
trade_name TEXT NOT NULL,
legal_name TEXT,
server_domains TEXT,
enabled INTEGER NOT NULL DEFAULT 1,
role_storage INTEGER NOT NULL DEFAULT 1,
role_proxy INTEGER NOT NULL DEFAULT 1,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE usage_conditions(
usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
conditions_commit TEXT NOT NULL UNIQUE,
notified_at TEXT,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE operator_usage_conditions(
operator_usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
server_operator_id INTEGER REFERENCES server_operators(server_operator_id) ON DELETE SET NULL ON UPDATE CASCADE,
server_operator_tag TEXT,
conditions_commit TEXT NOT NULL,
accepted_at TEXT,
created_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE INDEX contact_profiles_index ON contact_profiles(
display_name,
full_name
@@ -917,10 +890,3 @@ CREATE INDEX idx_received_probes_group_member_id on received_probes(
group_member_id
);
CREATE INDEX idx_contact_requests_contact_id ON contact_requests(contact_id);
CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(
server_operator_id
);
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(
conditions_commit,
server_operator_id
);
-447
View File
@@ -1,447 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Operators where
import Control.Applicative ((<|>))
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.TH as JQ
import Data.FileEmbed
import Data.Foldable (foldMap')
import Data.IORef
import Data.Int (Int64)
import Data.List (find, foldl')
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 (fromMaybe, isNothing, mapMaybe)
import Data.Scientific (floatingOrInteger)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (addUTCTime)
import Data.Time.Clock (UTCTime, nominalDay)
import Data.Type.Equality
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import Language.Haskell.TH.Syntax (lift)
import Simplex.Chat.Operators.Conditions
import Simplex.Chat.Types.Util (textParseJSON)
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON)
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..), UserProtocol)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Util (atomicModifyIORef'_, safeDecodeUtf8, (<$?>))
usageConditionsCommit :: Text
usageConditionsCommit = "165143a1112308c035ac00ed669b96b60599aa1c"
previousConditionsCommit :: Text
previousConditionsCommit = "edf99fcd1d7d38d2501d19608b94c084cf00f2ac"
usageConditionsText :: Text
usageConditionsText =
$( let s = $(embedFile =<< makeRelativeToProject "PRIVACY.md")
in [|stripFrontMatter (safeDecodeUtf8 $(lift s))|]
)
data DBStored = DBStored | DBNew
data SDBStored (s :: DBStored) where
SDBStored :: SDBStored 'DBStored
SDBNew :: SDBStored 'DBNew
deriving instance Show (SDBStored s)
class DBStoredI s where sdbStored :: SDBStored s
instance DBStoredI 'DBStored where sdbStored = SDBStored
instance DBStoredI 'DBNew where sdbStored = SDBNew
instance TestEquality SDBStored where
testEquality SDBStored SDBStored = Just Refl
testEquality SDBNew SDBNew = Just Refl
testEquality _ _ = Nothing
data DBEntityId' (s :: DBStored) where
DBEntityId :: Int64 -> DBEntityId' 'DBStored
DBNewEntity :: DBEntityId' 'DBNew
deriving instance Show (DBEntityId' s)
type DBEntityId = DBEntityId' 'DBStored
type DBNewEntity = DBEntityId' 'DBNew
data ADBEntityId = forall s. DBStoredI s => AEI (SDBStored s) (DBEntityId' s)
pattern ADBEntityId :: Int64 -> ADBEntityId
pattern ADBEntityId i = AEI SDBStored (DBEntityId i)
pattern ADBNewEntity :: ADBEntityId
pattern ADBNewEntity = AEI SDBNew DBNewEntity
data OperatorTag = OTSimplex | OTXyz
deriving (Eq, Ord, Show)
instance FromField OperatorTag where fromField = fromTextField_ textDecode
instance ToField OperatorTag where toField = toField . textEncode
instance FromJSON OperatorTag where
parseJSON = textParseJSON "OperatorTag"
instance ToJSON OperatorTag where
toJSON = J.String . textEncode
toEncoding = JE.text . textEncode
instance TextEncoding OperatorTag where
textDecode = \case
"simplex" -> Just OTSimplex
"xyz" -> Just OTXyz
_ -> Nothing
textEncode = \case
OTSimplex -> "simplex"
OTXyz -> "xyz"
-- this and other types only define instances of serialization for known DB IDs only,
-- entities without IDs cannot be serialized to JSON
instance FromField DBEntityId where fromField f = DBEntityId <$> fromField f
instance ToField DBEntityId where toField (DBEntityId i) = toField i
data UsageConditions = UsageConditions
{ conditionsId :: Int64,
conditionsCommit :: Text,
notifiedAt :: Maybe UTCTime,
createdAt :: UTCTime
}
deriving (Show)
data UsageConditionsAction
= UCAReview {operators :: [ServerOperator], deadline :: Maybe UTCTime, showNotice :: Bool}
| UCAAccepted {operators :: [ServerOperator]}
deriving (Show)
usageConditionsAction :: [ServerOperator] -> UsageConditions -> UTCTime -> Maybe UsageConditionsAction
usageConditionsAction operators UsageConditions {createdAt, notifiedAt} now = do
let enabledOperators = filter (\ServerOperator {enabled} -> enabled) operators
if
| null enabledOperators -> Nothing
| all conditionsAccepted enabledOperators ->
let acceptedForOperators = filter conditionsAccepted operators
in Just $ UCAAccepted acceptedForOperators
| otherwise ->
let acceptForOperators = filter (not . conditionsAccepted) enabledOperators
deadline = conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
showNotice = isNothing notifiedAt
in Just $ UCAReview acceptForOperators deadline showNotice
conditionsRequiredOrDeadline :: UTCTime -> UTCTime -> Maybe UTCTime
conditionsRequiredOrDeadline createdAt notifiedAtOrNow =
if notifiedAtOrNow < addUTCTime (14 * nominalDay) createdAt
then Just $ conditionsDeadline notifiedAtOrNow
else Nothing -- required
where
conditionsDeadline :: UTCTime -> UTCTime
conditionsDeadline = addUTCTime (31 * nominalDay)
data ConditionsAcceptance
= CAAccepted {acceptedAt :: Maybe UTCTime}
| CARequired {deadline :: Maybe UTCTime}
deriving (Show)
type ServerOperator = ServerOperator' 'DBStored
type NewServerOperator = ServerOperator' 'DBNew
data AServerOperator = forall s. ASO (SDBStored s) (ServerOperator' s)
deriving instance Show AServerOperator
data ServerOperator' s = ServerOperator
{ operatorId :: DBEntityId' s,
operatorTag :: Maybe OperatorTag,
tradeName :: Text,
legalName :: Maybe Text,
serverDomains :: [Text],
conditionsAcceptance :: ConditionsAcceptance,
enabled :: Bool,
roles :: ServerRoles
}
deriving (Show)
conditionsAccepted :: ServerOperator -> Bool
conditionsAccepted ServerOperator {conditionsAcceptance} = case conditionsAcceptance of
CAAccepted {} -> True
_ -> False
data UserOperatorServers = UserOperatorServers
{ operator :: Maybe ServerOperator,
smpServers :: [UserServer 'PSMP],
xftpServers :: [UserServer 'PXFTP]
}
deriving (Show)
data UpdatedUserOperatorServers = UpdatedUserOperatorServers
{ operator :: Maybe ServerOperator,
smpServers :: [AUserServer 'PSMP],
xftpServers :: [AUserServer 'PXFTP]
}
deriving (Show)
updatedServers :: UserProtocol p => UpdatedUserOperatorServers -> SProtocolType p -> [AUserServer p]
updatedServers UpdatedUserOperatorServers {smpServers, xftpServers} = \case
SPSMP -> smpServers
SPXFTP -> xftpServers
type UserServer p = UserServer' 'DBStored p
type NewUserServer p = UserServer' 'DBNew p
data AUserServer p = forall s. AUS (SDBStored s) (UserServer' s p)
deriving instance Show (AUserServer p)
data UserServer' s p = UserServer
{ serverId :: DBEntityId' s,
server :: ProtoServerWithAuth p,
preset :: Bool,
tested :: Maybe Bool,
enabled :: Bool,
deleted :: Bool
}
deriving (Show)
data PresetOperator = PresetOperator
{ operator :: Maybe NewServerOperator,
smp :: [NewUserServer 'PSMP],
useSMP :: Int,
xftp :: [NewUserServer 'PXFTP],
useXFTP :: Int
}
operatorServers :: UserProtocol p => SProtocolType p -> PresetOperator -> [NewUserServer p]
operatorServers p PresetOperator {smp, xftp} = case p of
SPSMP -> smp
SPXFTP -> xftp
operatorServersToUse :: UserProtocol p => SProtocolType p -> PresetOperator -> Int
operatorServersToUse p PresetOperator {useSMP, useXFTP} = case p of
SPSMP -> useSMP
SPXFTP -> useXFTP
presetServer :: Bool -> ProtoServerWithAuth p -> NewUserServer p
presetServer enabled server =
UserServer {serverId = DBNewEntity, server, preset = True, tested = Nothing, enabled, deleted = False}
-- This function should be used inside DB transaction to update conditions in the database
-- it evaluates to (conditions to mark as accepted to SimpleX operator, current conditions, and conditions to add)
usageConditionsToAdd :: Bool -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, UsageConditions, [UsageConditions])
usageConditionsToAdd = usageConditionsToAdd' previousConditionsCommit usageConditionsCommit
-- This function is used in unit tests
usageConditionsToAdd' :: Text -> Text -> Bool -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, UsageConditions, [UsageConditions])
usageConditionsToAdd' prevCommit sourceCommit newUser createdAt = \case
[]
| newUser -> (Just sourceCond, sourceCond, [sourceCond])
| otherwise -> (Just prevCond, sourceCond, [prevCond, sourceCond])
where
prevCond = conditions 1 prevCommit
sourceCond = conditions 2 sourceCommit
conds
| hasSourceCond -> (Nothing, last conds, [])
| otherwise -> (Nothing, sourceCond, [sourceCond])
where
hasSourceCond = any ((sourceCommit ==) . conditionsCommit) conds
sourceCond = conditions cId sourceCommit
cId = maximum (map conditionsId conds) + 1
where
conditions cId commit = UsageConditions {conditionsId = cId, conditionsCommit = commit, notifiedAt = Nothing, createdAt}
-- This function should be used inside DB transaction to update operators.
-- It allows to add/remove/update preset operators in the database preserving enabled and roles settings,
-- and preserves custom operators without tags for forward compatibility.
updatedServerOperators :: NonEmpty PresetOperator -> [ServerOperator] -> [AServerOperator]
updatedServerOperators presetOps storedOps =
foldr addPreset [] presetOps
<> map (ASO SDBStored) (filter (isNothing . operatorTag) storedOps)
where
-- TODO remove domains of preset operators from custom
addPreset PresetOperator {operator} = case operator of
Nothing -> id
Just presetOp -> (storedOp' :)
where
storedOp' = case find ((operatorTag presetOp ==) . operatorTag) storedOps of
Just ServerOperator {operatorId, conditionsAcceptance, enabled, roles} ->
ASO SDBStored presetOp {operatorId, conditionsAcceptance, enabled, roles}
Nothing -> ASO SDBNew presetOp
-- This function should be used inside DB transaction to update servers.
updatedUserServers :: forall p. UserProtocol p => SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> [UserServer p] -> NonEmpty (AUserServer p)
updatedUserServers _ _ randomSrvs [] = L.map (AUS SDBNew) randomSrvs
updatedUserServers p presetOps randomSrvs srvs =
fromMaybe (L.map (AUS SDBNew) randomSrvs) (L.nonEmpty updatedSrvs)
where
updatedSrvs = map userServer presetSrvs <> map (AUS SDBStored) (filter customServer srvs)
storedSrvs :: Map (ProtoServerWithAuth p) (UserServer p)
storedSrvs = foldl' (\ss srv@UserServer {server} -> M.insert server srv ss) M.empty srvs
customServer :: UserServer p -> Bool
customServer srv = not (preset srv) && all (`S.notMember` presetHosts) (srvHost srv)
presetSrvs :: [NewUserServer p]
presetSrvs = concatMap (operatorServers p) presetOps
presetHosts :: Set TransportHost
presetHosts = foldMap' (S.fromList . L.toList . srvHost) presetSrvs
userServer :: NewUserServer p -> AUserServer p
userServer srv@UserServer {server} = maybe (AUS SDBNew srv) (AUS SDBStored) (M.lookup server storedSrvs)
srvHost :: UserServer' s p -> NonEmpty TransportHost
srvHost UserServer {server = ProtoServerWithAuth srv _} = host srv
agentServerCfgs :: [(Text, ServerOperator)] -> NonEmpty (UserServer' s p) -> NonEmpty (ServerCfg p)
agentServerCfgs opDomains = L.map agentServer
where
agentServer :: UserServer' s p -> ServerCfg p
agentServer srv@UserServer {server, enabled} =
case find (\(d, _) -> any (matchingHost d) (srvHost srv)) opDomains of
Just (_, ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled, roles}) ->
ServerCfg {server, operator = Just opId, enabled = opEnabled && enabled, roles}
Nothing ->
ServerCfg {server, operator = Nothing, enabled, roles = allRoles}
matchingHost :: Text -> TransportHost -> Bool
matchingHost d = \case
THDomainName h -> d `T.isSuffixOf` T.pack h
_ -> False
operatorDomains :: [ServerOperator] -> [(Text, ServerOperator)]
operatorDomains = foldr (\op ds -> foldr (\d -> ((d, op) :)) ds (serverDomains op)) []
groupByOperator :: ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> IO [UserOperatorServers]
groupByOperator (ops, smpSrvs, xftpSrvs) = do
ss <- mapM (\op -> (serverDomains op,) <$> newIORef (UserOperatorServers (Just op) [] [])) ops
custom <- newIORef $ UserOperatorServers Nothing [] []
mapM_ (addServer ss custom addSMP) (reverse smpSrvs)
mapM_ (addServer ss custom addXFTP) (reverse xftpSrvs)
mapM (readIORef . snd) ss
where
addServer :: [([Text], IORef UserOperatorServers)] -> IORef UserOperatorServers -> (UserServer p -> UserOperatorServers -> UserOperatorServers) -> UserServer p -> IO ()
addServer ss custom add srv =
let v = maybe custom snd $ find (\(ds, _) -> any (\d -> any (matchingHost d) (srvHost srv)) ds) ss
in atomicModifyIORef'_ v $ add srv
addSMP srv s@UserOperatorServers {smpServers} = (s :: UserOperatorServers) {smpServers = srv : smpServers}
addXFTP srv s@UserOperatorServers {xftpServers} = (s :: UserOperatorServers) {xftpServers = srv : xftpServers}
data UserServersError
= USEStorageMissing {protocol :: AProtocolType}
| USEProxyMissing {protocol :: AProtocolType}
| USEDuplicateServer {protocol :: AProtocolType, duplicateServer :: AProtoServerWithAuth, duplicateHost :: TransportHost}
deriving (Show)
validateUserServers :: NonEmpty UpdatedUserOperatorServers -> [UserServersError]
validateUserServers uss =
missingRolesErr SPSMP storage USEStorageMissing
<> missingRolesErr SPSMP proxy USEProxyMissing
<> missingRolesErr SPXFTP storage USEStorageMissing
<> duplicatServerErrs SPSMP
<> duplicatServerErrs SPXFTP
where
missingRolesErr :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> (ServerRoles -> Bool) -> (AProtocolType -> UserServersError) -> [UserServersError]
missingRolesErr p roleSel err = [err (AProtocolType p) | hasRole]
where
hasRole =
any (\(AUS _ UserServer {deleted, enabled}) -> enabled && not deleted) $
concatMap (`updatedServers` p) $ filter roleEnabled (L.toList uss)
roleEnabled UpdatedUserOperatorServers {operator} =
maybe True (\ServerOperator {enabled, roles} -> enabled && roleSel roles) operator
duplicatServerErrs :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [UserServersError]
duplicatServerErrs p = mapMaybe duplicateErr_ srvs
where
srvs =
filter (\(AUS _ UserServer {deleted}) -> not deleted) $
concatMap (`updatedServers` p) (L.toList uss)
duplicateErr_ (AUS _ srv@UserServer {server}) =
USEDuplicateServer (AProtocolType p) (AProtoServerWithAuth p server)
<$> find (`S.member` duplicateHosts) (srvHost srv)
duplicateHosts = snd $ foldl' (\acc (AUS _ srv) -> foldl' addHost acc $ srvHost srv) (S.empty, S.empty) srvs
addHost (hs, dups) h
| h `S.member` hs = (hs, S.insert h dups)
| otherwise = (S.insert h hs, dups)
instance ToJSON ADBEntityId where
toEncoding (AEI _ dbId) = toEncoding dbId
toJSON (AEI _ dbId) = toJSON dbId
instance ToJSON (DBEntityId' s) where
toEncoding = \case
DBEntityId i -> toEncoding i
DBNewEntity -> JE.null_
toJSON = \case
DBEntityId i -> toJSON i
DBNewEntity -> J.Null
instance FromJSON ADBEntityId where
parseJSON (J.Null) = pure $ AEI SDBNew DBNewEntity
parseJSON (J.Number n) = case floatingOrInteger n of
Left (_ :: Double) -> fail "bad ADBEntityId"
Right i -> pure $ AEI SDBStored (DBEntityId $ fromInteger i)
parseJSON _ = fail "bad ADBEntityId"
instance DBStoredI s => FromJSON (DBEntityId' s) where
parseJSON v = (\(AEI _ dbId) -> checkDBStored dbId) <$?> parseJSON v
checkDBStored :: forall t s s'. (DBStoredI s, DBStoredI s') => t s' -> Either String (t s)
checkDBStored x = case testEquality (sdbStored @s) (sdbStored @s') of
Just Refl -> Right x
Nothing -> Left "bad DBStored"
$(JQ.deriveJSON defaultJSON ''UsageConditions)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance)
instance ToJSON (ServerOperator' s) where
toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerOperator')
toJSON = $(JQ.mkToJSON defaultJSON ''ServerOperator')
instance DBStoredI s => FromJSON (ServerOperator' s) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerOperator')
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)
instance ProtocolTypeI p => ToJSON (UserServer' s p) where
toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer')
toJSON = $(JQ.mkToJSON defaultJSON ''UserServer')
instance (DBStoredI s, ProtocolTypeI p) => FromJSON (UserServer' s p) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer')
instance ProtocolTypeI p => FromJSON (AUserServer p) where
parseJSON v = (AUS SDBStored <$> parseJSON v) <|> (AUS SDBNew <$> parseJSON v)
$(JQ.deriveJSON defaultJSON ''UserOperatorServers)
instance FromJSON UpdatedUserOperatorServers where
parseJSON = $(JQ.mkParseJSON defaultJSON ''UpdatedUserOperatorServers)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USE") ''UserServersError)
-19
View File
@@ -1,19 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Operators.Conditions where
import Data.Char (isSpace)
import Data.Text (Text)
import qualified Data.Text as T
stripFrontMatter :: Text -> Text
stripFrontMatter =
T.unlines
. dropWhile ("# " `T.isPrefixOf`) -- strip title
. dropWhile (T.all isSpace)
. dropWhile fm
. (\ls -> let ls' = dropWhile (not . fm) ls in if null ls' then ls else ls')
. dropWhile fm
. T.lines
where
fm = ("---" `T.isPrefixOf`)
+2 -1
View File
@@ -7,6 +7,7 @@ module Simplex.Chat.Stats where
import qualified Data.Aeson.TH as J
import Data.List (partition)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust)
@@ -130,7 +131,7 @@ data NtfServerSummary = NtfServerSummary
-- - users are passed to exclude hidden users from totalServersSummary;
-- - if currentUser is hidden, it should be accounted in totalServersSummary;
-- - known is set only in user level summaries based on passed userSMPSrvs and userXFTPSrvs
toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> [SMPServer] -> [XFTPServer] -> [NtfServer] -> PresentedServersSummary
toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> NonEmpty SMPServer -> NonEmpty XFTPServer -> [NtfServer] -> PresentedServersSummary
toPresentedServersSummary agentSummary users currentUser userSMPSrvs userXFTPSrvs userNtfSrvs = do
let (userSMPSrvsSumms, allSMPSrvsSumms) = accSMPSrvsSummaries
(userSMPCurr, userSMPPrev, userSMPProx) = smpSummsIntoCategories userSMPSrvsSumms
+328 -162
View File
@@ -138,7 +138,7 @@ import Data.Time (addUTCTime)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), Query, (:.) (..))
import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Controller (ChatListQuery (..), ChatPagination (..), PaginationByTime (..))
import Simplex.Chat.Controller (ChatLandingSection (CLSLatest, CLSUnread), ChatListQuery (..), ChatPagination (..), PaginationByTime (..))
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
@@ -947,37 +947,41 @@ getContactConnectionChatPreviews_ db User {userId} pagination clq = case clq of
aChat = AChat SCTContactConnection $ Chat (ContactConnection conn) [] stats
in ACPD SCTContactConnection $ ContactConnectionPD updatedAt aChat
getDirectChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect)
getDirectChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect, ChatLandingSection)
getDirectChat db vr user contactId pagination search_ = do
let search = fromMaybe "" search_
ct <- getContact db vr user contactId
liftIO $ case pagination of
CPLast count -> getDirectChatLast_ db user ct count search
CPAfter afterId count -> getDirectChatAfter_ db user ct afterId count search
CPBefore beforeId count -> getDirectChatBefore_ db user ct beforeId count search
case pagination of
CPLast count -> liftIO $ (,CLSLatest) <$> getDirectChatLast_ db user ct count search
CPAfter afterId count -> (,CLSLatest) <$> getDirectChatAfter_ db user ct afterId count search
CPBefore beforeId count -> (,CLSLatest) <$> getDirectChatBefore_ db user ct beforeId count search
CPAround aroundId count -> (,CLSLatest) <$> getDirectChatAround_ db user ct aroundId count search
CPInitial count -> do
unless (null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
getDirectChatInitial_ db user ct count
-- the last items in reverse order (the last item in the conversation is the first in the returned list)
getDirectChatLast_ :: DB.Connection -> User -> Contact -> Int -> String -> IO (Chat 'CTDirect)
getDirectChatLast_ db user@User {userId} ct@Contact {contactId} count search = do
getDirectChatLast_ db user ct count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getDirectChatItemIdsLast_
chatItemIds <- getDirectChatItemIdsLast_ db user ct count search
currentTs <- getCurrentTime
chatItems <- mapM (safeGetDirectItem db user ct currentTs) chatItemIds
pure $ Chat (DirectChat ct) (reverse chatItems) stats
where
getDirectChatItemIdsLast_ :: IO [ChatItemId]
getDirectChatItemIdsLast_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, contactId, search, count)
getDirectChatItemIdsLast_ :: DB.Connection -> User -> Contact -> Int -> String -> IO [ChatItemId]
getDirectChatItemIdsLast_ db User {userId} Contact {contactId} count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, contactId, search, count)
safeGetDirectItem :: DB.Connection -> User -> Contact -> UTCTime -> ChatItemId -> IO (CChatItem 'CTDirect)
safeGetDirectItem db user ct currentTs itemId =
@@ -1021,82 +1025,129 @@ getDirectChatItemLast db user@User {userId} contactId = do
(userId, contactId)
getDirectChatItem db user contactId chatItemId
getDirectChatAfter_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> IO (Chat 'CTDirect)
getDirectChatAfter_ db user@User {userId} ct@Contact {contactId} afterChatItemId count search = do
getDirectChatAfter_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect)
getDirectChatAfter_ db user ct@Contact {contactId} afterChatItemId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getDirectChatItemIdsAfter_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetDirectItem db user ct currentTs) chatItemIds
afterChatItem <- getDirectChatItem db user contactId afterChatItemId
chatItemIds <- liftIO $ getDirectChatItemIdsAfter_ db user ct afterChatItemId count search (chatItemCreatedAt afterChatItem)
currentTs <- liftIO getCurrentTime
chatItems <- liftIO $ mapM (safeGetDirectItem db user ct currentTs) chatItemIds
pure $ Chat (DirectChat ct) chatItems stats
where
getDirectChatItemIdsAfter_ :: IO [ChatItemId]
getDirectChatItemIdsAfter_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
AND chat_item_id > ?
ORDER BY created_at ASC, chat_item_id ASC
LIMIT ?
|]
(userId, contactId, search, afterChatItemId, count)
getDirectChatBefore_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> IO (Chat 'CTDirect)
getDirectChatBefore_ db user@User {userId} ct@Contact {contactId} beforeChatItemId count search = do
getDirectChatItemIdsAfter_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> UTCTime -> IO [ChatItemId]
getDirectChatItemIdsAfter_ db User {userId} Contact {contactId} afterChatItemId count search afterChatItemCreatedAt =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
AND (created_at > ? OR (created_at = ? AND chat_item_id > ?))
ORDER BY created_at ASC, chat_item_id ASC
LIMIT ?
|]
(userId, contactId, search, afterChatItemCreatedAt, afterChatItemCreatedAt, afterChatItemId, count)
getDirectChatBefore_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect)
getDirectChatBefore_ db user ct@Contact {contactId} beforeChatItemId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getDirectChatItemsIdsBefore_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetDirectItem db user ct currentTs) chatItemIds
beforeChatItem <- getDirectChatItem db user contactId beforeChatItemId
chatItemIds <- liftIO $ getDirectChatItemsIdsBefore_ db user ct beforeChatItemId count search (chatItemCreatedAt beforeChatItem)
currentTs <- liftIO getCurrentTime
chatItems <- liftIO $ mapM (safeGetDirectItem db user ct currentTs) chatItemIds
pure $ Chat (DirectChat ct) (reverse chatItems) stats
getDirectChatItemsIdsBefore_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> UTCTime -> IO [ChatItemId]
getDirectChatItemsIdsBefore_ db User {userId} Contact {contactId} beforeChatItemId count search beforeChatItemCreatedAt =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
AND (created_at < ? OR (created_at = ? AND chat_item_id < ?))
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, contactId, search, beforeChatItemCreatedAt, beforeChatItemCreatedAt, beforeChatItemId, count)
getDirectChatAround_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect)
getDirectChatAround_ db user ct@Contact {contactId} aroundItemId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
let (fetchCountBefore, fetchCountAfter) = divideFetchCountAround_ (count - 1)
middleChatItem <- getDirectChatItem db user contactId aroundItemId
beforeIds <- liftIO $ getDirectChatItemsIdsBefore_ db user ct aroundItemId fetchCountBefore search (chatItemCreatedAt middleChatItem)
afterIds <- liftIO $ getDirectChatItemIdsAfter_ db user ct aroundItemId fetchCountAfter search (chatItemCreatedAt middleChatItem)
currentTs <- liftIO getCurrentTime
beforeChatItems <- liftIO $ reverse <$> mapM (safeGetDirectItem db user ct currentTs) beforeIds
afterChatItems <- liftIO $ mapM (safeGetDirectItem db user ct currentTs) afterIds
let chatItems = beforeChatItems <> [middleChatItem] <> afterChatItems
pure $ Chat (DirectChat ct) chatItems stats
getDirectChatInitial_ :: DB.Connection -> User -> Contact -> Int -> ExceptT StoreError IO (Chat 'CTDirect, ChatLandingSection)
getDirectChatInitial_ db user@User {userId} ct@Contact {contactId} count = do
firstUnreadItemId_ <- liftIO getDirectChatMinUnreadItemId_
case firstUnreadItemId_ of
Just firstUnreadItemId -> do
chat <- getDirectChatAround_ db user ct firstUnreadItemId count ""
lastItemId <- liftIO $ getDirectChatItemIdsLast_ db user ct 1 ""
pure (chat, landingSection chat lastItemId)
Nothing -> liftIO $ (,CLSLatest) <$> getDirectChatLast_ db user ct count ""
where
getDirectChatItemsIdsBefore_ :: IO [ChatItemId]
getDirectChatItemsIdsBefore_ =
map fromOnly
<$> DB.query
getDirectChatMinUnreadItemId_ :: IO (Maybe ChatItemId)
getDirectChatMinUnreadItemId_ =
fmap join . maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT chat_item_id
SELECT MIN(chat_item_id)
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE '%' || ? || '%'
AND chat_item_id < ?
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
WHERE user_id = ? AND contact_id = ? AND item_status = ?
|]
(userId, contactId, search, beforeChatItemId, count)
(userId, contactId, CISRcvNew)
getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
landingSection :: Chat c -> [ChatItemId] -> ChatLandingSection
landingSection Chat {chatItems} [lastItemId] = do
let lastItemIdInChat = foldr (\ci acc -> acc || cchatItemId ci == lastItemId) False chatItems
if lastItemIdInChat then CLSLatest else CLSUnread
landingSection _ _ = CLSUnread
getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup, ChatLandingSection)
getGroupChat db vr user groupId pagination search_ = do
let search = fromMaybe "" search_
g <- getGroupInfo db vr user groupId
case pagination of
CPLast count -> liftIO $ getGroupChatLast_ db user g count search
CPAfter afterId count -> getGroupChatAfter_ db user g afterId count search
CPBefore beforeId count -> getGroupChatBefore_ db user g beforeId count search
CPLast count -> liftIO $ (,CLSLatest) <$> getGroupChatLast_ db user g count search
CPAfter afterId count -> (,CLSLatest) <$> getGroupChatAfter_ db user g afterId count search
CPBefore beforeId count -> (,CLSLatest) <$> getGroupChatBefore_ db user g beforeId count search
CPAround aroundId count -> (,CLSLatest) <$> getGroupChatAround_ db user g aroundId count search
CPInitial count -> do
unless (null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
getGroupChatInitial_ db user g count
getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Int -> String -> IO (Chat 'CTGroup)
getGroupChatLast_ db user@User {userId} g@GroupInfo {groupId} count search = do
getGroupChatLast_ db user g count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getGroupChatItemIdsLast_
chatItemIds <- getGroupChatItemIdsLast_ db user g count search
currentTs <- getCurrentTime
chatItems <- mapM (safeGetGroupItem db user g currentTs) chatItemIds
pure $ Chat (GroupChat g) (reverse chatItems) stats
where
getGroupChatItemIdsLast_ :: IO [ChatItemId]
getGroupChatItemIdsLast_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
|]
(userId, groupId, search, count)
getGroupChatItemIdsLast_ :: DB.Connection -> User -> GroupInfo -> Int -> String -> IO [ChatItemId]
getGroupChatItemIdsLast_ db User {userId} GroupInfo {groupId} count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
|]
(userId, groupId, search, count)
safeGetGroupItem :: DB.Connection -> User -> GroupInfo -> UTCTime -> ChatItemId -> IO (CChatItem 'CTGroup)
safeGetGroupItem db user g currentTs itemId =
@@ -1141,83 +1192,122 @@ getGroupMemberChatItemLast db user@User {userId} groupId groupMemberId = do
getGroupChatItem db user groupId chatItemId
getGroupChatAfter_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChatAfter_ db user@User {userId} g@GroupInfo {groupId} afterChatItemId count search = do
getGroupChatAfter_ db user g@GroupInfo {groupId} afterChatItemId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
afterChatItem <- getGroupChatItem db user groupId afterChatItemId
chatItemIds <- liftIO $ getGroupChatItemIdsAfter_ (chatItemTs afterChatItem)
chatItemIds <- liftIO $ getGroupChatItemIdsAfter_ db user g afterChatItemId count search (chatItemTs afterChatItem)
currentTs <- liftIO getCurrentTime
chatItems <- liftIO $ mapM (safeGetGroupItem db user g currentTs) chatItemIds
pure $ Chat (GroupChat g) chatItems stats
where
getGroupChatItemIdsAfter_ :: UTCTime -> IO [ChatItemId]
getGroupChatItemIdsAfter_ afterChatItemTs =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?))
ORDER BY item_ts ASC, chat_item_id ASC
LIMIT ?
|]
(userId, groupId, search, afterChatItemTs, afterChatItemTs, afterChatItemId, count)
getGroupChatItemIdsAfter_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> UTCTime -> IO [ChatItemId]
getGroupChatItemIdsAfter_ db User {userId} GroupInfo {groupId} afterChatItemId count search afterChatItemTs =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?))
ORDER BY item_ts ASC, chat_item_id ASC
LIMIT ?
|]
(userId, groupId, search, afterChatItemTs, afterChatItemTs, afterChatItemId, count)
getGroupChatBefore_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChatBefore_ db user@User {userId} g@GroupInfo {groupId} beforeChatItemId count search = do
getGroupChatBefore_ db user g@GroupInfo {groupId} beforeChatItemId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
beforeChatItem <- getGroupChatItem db user groupId beforeChatItemId
chatItemIds <- liftIO $ getGroupChatItemIdsBefore_ (chatItemTs beforeChatItem)
chatItemIds <- liftIO $ getGroupChatItemIdsBefore_ db user g beforeChatItemId count search (chatItemTs beforeChatItem)
currentTs <- liftIO getCurrentTime
chatItems <- liftIO $ mapM (safeGetGroupItem db user g currentTs) chatItemIds
pure $ Chat (GroupChat g) (reverse chatItems) stats
getGroupChatItemIdsBefore_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> UTCTime -> IO [ChatItemId]
getGroupChatItemIdsBefore_ db User {userId} GroupInfo {groupId} beforeChatItemId count search beforeChatItemTs =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?))
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
|]
(userId, groupId, search, beforeChatItemTs, beforeChatItemTs, beforeChatItemId, count)
getGroupChatAround_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChatAround_ db user g@GroupInfo {groupId} aroundItemId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
let (fetchCountBefore, fetchCountAfter) = divideFetchCountAround_ (count - 1)
middleChatItem <- getGroupChatItem db user groupId aroundItemId
beforeIds <- liftIO $ getGroupChatItemIdsBefore_ db user g aroundItemId fetchCountBefore search (chatItemTs middleChatItem)
afterIds <- liftIO $ getGroupChatItemIdsAfter_ db user g aroundItemId fetchCountAfter search (chatItemTs middleChatItem)
currentTs <- liftIO getCurrentTime
beforeChatItems <- liftIO $ reverse <$> mapM (safeGetGroupItem db user g currentTs) beforeIds
afterChatItems <- liftIO $ mapM (safeGetGroupItem db user g currentTs) afterIds
let chatItems = beforeChatItems <> [middleChatItem] <> afterChatItems
pure $ Chat (GroupChat g) chatItems stats
getGroupChatInitial_ :: DB.Connection -> User -> GroupInfo -> Int -> ExceptT StoreError IO (Chat 'CTGroup, ChatLandingSection)
getGroupChatInitial_ db user@User {userId} g@GroupInfo {groupId} count = do
firstUnreadItemId_ <- liftIO getGroupChatMinUnreadItemId_
case firstUnreadItemId_ of
Just firstUnreadItemId -> do
chat <- getGroupChatAround_ db user g firstUnreadItemId count ""
lastItemId <- liftIO $ getGroupChatItemIdsLast_ db user g 1 ""
pure (chat, landingSection chat lastItemId)
Nothing -> liftIO $ (,CLSLatest) <$> getGroupChatLast_ db user g count ""
where
getGroupChatItemIdsBefore_ :: UTCTime -> IO [ChatItemId]
getGroupChatItemIdsBefore_ beforeChatItemTs =
map fromOnly
<$> DB.query
getGroupChatMinUnreadItemId_ :: IO (Maybe ChatItemId)
getGroupChatMinUnreadItemId_ =
fmap join . maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT chat_item_id
SELECT MIN(chat_item_id)
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%'
AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?))
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
WHERE user_id = ? AND group_id = ? AND item_status = ?
|]
(userId, groupId, search, beforeChatItemTs, beforeChatItemTs, beforeChatItemId, count)
(userId, groupId, CISRcvNew)
getLocalChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTLocal)
getLocalChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTLocal, ChatLandingSection)
getLocalChat db user folderId pagination search_ = do
let search = fromMaybe "" search_
nf <- getNoteFolder db user folderId
liftIO $ case pagination of
CPLast count -> getLocalChatLast_ db user nf count search
CPAfter afterId count -> getLocalChatAfter_ db user nf afterId count search
CPBefore beforeId count -> getLocalChatBefore_ db user nf beforeId count search
case pagination of
CPLast count -> liftIO $ (,CLSLatest) <$> getLocalChatLast_ db user nf count search
CPAfter afterId count -> (,CLSLatest) <$> getLocalChatAfter_ db user nf afterId count search
CPBefore beforeId count -> (,CLSLatest) <$> getLocalChatBefore_ db user nf beforeId count search
CPAround aroundId count -> (,CLSLatest) <$> getLocalChatAround_ db user nf aroundId count search
CPInitial count -> do
unless (null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
getLocalChatInitial_ db user nf count
getLocalChatLast_ :: DB.Connection -> User -> NoteFolder -> Int -> String -> IO (Chat 'CTLocal)
getLocalChatLast_ db user@User {userId} nf@NoteFolder {noteFolderId} count search = do
getLocalChatLast_ db user nf count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getLocalChatItemIdsLast_
chatItemIds <- getLocalChatItemIdsLast_ db user nf count search
currentTs <- getCurrentTime
chatItems <- mapM (safeGetLocalItem db user nf currentTs) chatItemIds
pure $ Chat (LocalChat nf) (reverse chatItems) stats
where
getLocalChatItemIdsLast_ :: IO [ChatItemId]
getLocalChatItemIdsLast_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, noteFolderId, search, count)
getLocalChatItemIdsLast_ :: DB.Connection -> User -> NoteFolder -> Int -> String -> IO [ChatItemId]
getLocalChatItemIdsLast_ db User {userId} NoteFolder {noteFolderId} count search =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, noteFolderId, search, count)
safeGetLocalItem :: DB.Connection -> User -> NoteFolder -> UTCTime -> ChatItemId -> IO (CChatItem 'CTLocal)
safeGetLocalItem db user NoteFolder {noteFolderId} currentTs itemId =
@@ -1245,51 +1335,88 @@ safeToLocalItem currentTs itemId = \case
file = Nothing
}
getLocalChatAfter_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> IO (Chat 'CTLocal)
getLocalChatAfter_ db user@User {userId} nf@NoteFolder {noteFolderId} afterChatItemId count search = do
getLocalChatAfter_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTLocal)
getLocalChatAfter_ db user nf@NoteFolder {noteFolderId} afterChatItemId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getLocalChatItemIdsAfter_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetLocalItem db user nf currentTs) chatItemIds
afterChatItem <- getLocalChatItem db user noteFolderId afterChatItemId
chatItemIds <- liftIO $ getLocalChatItemIdsAfter_ db user nf afterChatItemId count search (chatItemCreatedAt afterChatItem)
currentTs <- liftIO getCurrentTime
chatItems <- liftIO $ mapM (safeGetLocalItem db user nf currentTs) chatItemIds
pure $ Chat (LocalChat nf) chatItems stats
where
getLocalChatItemIdsAfter_ :: IO [ChatItemId]
getLocalChatItemIdsAfter_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
AND chat_item_id > ?
ORDER BY created_at ASC, chat_item_id ASC
LIMIT ?
|]
(userId, noteFolderId, search, afterChatItemId, count)
getLocalChatBefore_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> IO (Chat 'CTLocal)
getLocalChatBefore_ db user@User {userId} nf@NoteFolder {noteFolderId} beforeChatItemId count search = do
getLocalChatItemIdsAfter_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> UTCTime -> IO [ChatItemId]
getLocalChatItemIdsAfter_ db User {userId} NoteFolder {noteFolderId} afterChatItemId count search afterChatItemCreatedAt =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
AND (created_at > ? OR (created_at = ? AND chat_item_id > ?))
ORDER BY created_at ASC, chat_item_id ASC
LIMIT ?
|]
(userId, noteFolderId, search, afterChatItemCreatedAt, afterChatItemCreatedAt, afterChatItemId, count)
getLocalChatBefore_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTLocal)
getLocalChatBefore_ db user nf@NoteFolder {noteFolderId} beforeChatItemId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- getLocalChatItemIdsBefore_
currentTs <- getCurrentTime
chatItems <- mapM (safeGetLocalItem db user nf currentTs) chatItemIds
beforeChatItem <- getLocalChatItem db user noteFolderId beforeChatItemId
chatItemIds <- liftIO $ getLocalChatItemIdsBefore_ db user nf beforeChatItemId count search (chatItemCreatedAt beforeChatItem)
currentTs <- liftIO getCurrentTime
chatItems <- liftIO $ mapM (safeGetLocalItem db user nf currentTs) chatItemIds
pure $ Chat (LocalChat nf) (reverse chatItems) stats
getLocalChatItemIdsBefore_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> UTCTime -> IO [ChatItemId]
getLocalChatItemIdsBefore_ db User {userId} NoteFolder {noteFolderId} beforeChatItemId count search beforeChatItemCreatedAt =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
AND (created_at < ? OR (created_at = ? AND chat_item_id < ?))
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
|]
(userId, noteFolderId, search, beforeChatItemCreatedAt, beforeChatItemCreatedAt, beforeChatItemId, count)
getLocalChatAround_ :: DB.Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTLocal)
getLocalChatAround_ db user nf@NoteFolder {noteFolderId} aroundItemId count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
let (fetchCountBefore, fetchCountAfter) = divideFetchCountAround_ (count - 1)
middleChatItem <- getLocalChatItem db user noteFolderId aroundItemId
beforeIds <- liftIO $ getLocalChatItemIdsBefore_ db user nf aroundItemId fetchCountBefore search (chatItemCreatedAt middleChatItem)
afterIds <- liftIO $ getLocalChatItemIdsAfter_ db user nf aroundItemId fetchCountAfter search (chatItemCreatedAt middleChatItem)
currentTs <- liftIO getCurrentTime
beforeChatItems <- liftIO $ reverse <$> mapM (safeGetLocalItem db user nf currentTs) beforeIds
afterChatItems <- liftIO $ mapM (safeGetLocalItem db user nf currentTs) afterIds
let chatItems = beforeChatItems <> [middleChatItem] <> afterChatItems
pure $ Chat (LocalChat nf) chatItems stats
getLocalChatInitial_ :: DB.Connection -> User -> NoteFolder -> Int -> ExceptT StoreError IO (Chat 'CTLocal, ChatLandingSection)
getLocalChatInitial_ db user@User {userId} nf@NoteFolder {noteFolderId} count = do
firstUnreadItemId_ <- liftIO getLocalChatMinUnreadItemId_
case firstUnreadItemId_ of
Just firstUnreadItemId -> do
chat <- getLocalChatAround_ db user nf firstUnreadItemId count ""
lastItemId <- liftIO $ getLocalChatItemIdsLast_ db user nf 1 ""
pure (chat, landingSection chat lastItemId)
Nothing -> liftIO $ (,CLSLatest) <$> getLocalChatLast_ db user nf count ""
where
getLocalChatItemIdsBefore_ :: IO [ChatItemId]
getLocalChatItemIdsBefore_ =
map fromOnly
<$> DB.query
getLocalChatMinUnreadItemId_ :: IO (Maybe ChatItemId)
getLocalChatMinUnreadItemId_ =
fmap join . maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT chat_item_id
SELECT MIN(chat_item_id)
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE '%' || ? || '%'
AND chat_item_id < ?
ORDER BY created_at DESC, chat_item_id DESC
LIMIT ?
WHERE user_id = ? AND note_folder_id = ? AND item_status = ?
|]
(userId, noteFolderId, search, beforeChatItemId, count)
(userId, noteFolderId, CISRcvNew)
toChatItemRef :: (ChatItemId, Maybe Int64, Maybe Int64, Maybe Int64) -> Either StoreError (ChatRef, ChatItemId)
toChatItemRef = \case
@@ -1581,6 +1708,13 @@ getAllChatItems db vr user@User {userId} pagination search_ = do
CPLast count -> liftIO $ getAllChatItemsLast_ count
CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId
CPBefore beforeId count -> liftIO . getAllChatItemsBefore_ beforeId count . aChatItemTs =<< getAChatItem_ beforeId
CPAround aroundId count -> liftIO . getAllChatItemsAround_ aroundId count . aChatItemTs =<< getAChatItem_ aroundId
CPInitial count -> do
unless (null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
firstUnreadItemId <- liftIO getFirstUnreadItemId_
case firstUnreadItemId of
Just itemId -> liftIO . getAllChatItemsAround_ itemId count . aChatItemTs =<< getAChatItem_ itemId
Nothing -> liftIO $ getAllChatItemsLast_ count
mapM (uncurry (getAChatItem db vr user)) itemRefs
where
search = fromMaybe "" search_
@@ -1624,6 +1758,31 @@ getAllChatItems db vr user@User {userId} pagination search_ = do
LIMIT ?
|]
(userId, search, beforeTs, beforeTs, beforeId, count)
getChatItem chatId =
DB.query
db
[sql|
SELECT chat_item_id, contact_id, group_id, note_folder_id
FROM chat_items
WHERE chat_item_id = ?
|]
(Only chatId)
getAllChatItemsAround_ aroundId count aroundTs = do
let (fetchCountBefore, fetchCountAfter) = divideFetchCountAround_ (count - 1)
itemsBefore <- getAllChatItemsBefore_ aroundId fetchCountBefore aroundTs
item <- getChatItem aroundId
itemsAfter <- getAllChatItemsAfter_ aroundId fetchCountAfter aroundTs
pure $ itemsBefore <> item <> itemsAfter
getFirstUnreadItemId_ =
fmap join . maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT MIN(chat_item_id)
FROM chat_items
WHERE user_id = ? AND item_status = ?
|]
(userId, CISRcvNew)
getChatItemIdsByAgentMsgId :: DB.Connection -> Int64 -> AgentMsgId -> IO [ChatItemId]
getChatItemIdsByAgentMsgId db connId msgId =
@@ -2650,3 +2809,10 @@ getGroupHistoryItems db user@User {userId} GroupInfo {groupId} count = do
LIMIT ?
|]
(userId, groupId, rcvMsgContentTag, sndMsgContentTag, count)
divideFetchCountAround_ :: Int -> (Int, Int)
divideFetchCountAround_ count =
let fetchCountEachSide = count `div` 2
fetchCountBefore = fetchCountEachSide + if count `mod` 2 /= 0 then 1 else 0
fetchCountAfter = fetchCountEachSide
in (fetchCountBefore, fetchCountAfter)
+2 -2
View File
@@ -114,7 +114,7 @@ import Simplex.Chat.Migrations.M20240827_calls_uuid
import Simplex.Chat.Migrations.M20240920_user_order
import Simplex.Chat.Migrations.M20241008_indexes
import Simplex.Chat.Migrations.M20241010_contact_requests_contact_id
import Simplex.Chat.Migrations.M20241027_server_operators
import Simplex.Chat.Migrations.M20241023_chat_item_autoincrement_id
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -229,7 +229,7 @@ schemaMigrations =
("20240920_user_order", m20240920_user_order, Just down_m20240920_user_order),
("20241008_indexes", m20241008_indexes, Just down_m20241008_indexes),
("20241010_contact_requests_contact_id", m20241010_contact_requests_contact_id, Just down_m20241010_contact_requests_contact_id),
("20241027_server_operators", m20241027_server_operators, Just down_m20241027_server_operators)
("20241023_chat_item_autoincrement_id", m20241023_chat_item_autoincrement_id, Just down_m20241023_chat_item_autoincrement_id)
]
-- | The list of migrations in ascending order by date
+23 -307
View File
@@ -1,8 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
@@ -50,19 +47,7 @@ module Simplex.Chat.Store.Profiles
getContactWithoutConnViaAddress,
updateUserAddressAutoAccept,
getProtocolServers,
getUpdateUserServers,
-- overwriteOperatorsAndServers,
overwriteProtocolServers,
insertProtocolServer,
getUpdateServerOperators,
getServerOperators,
getUserServers,
setServerOperators,
getCurrentUsageConditions,
getLatestAcceptedConditions,
setConditionsNotified,
acceptConditions,
setUserServers,
createCall,
deleteCalls,
getCalls,
@@ -85,14 +70,12 @@ import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), Query, (:.) (..))
import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Call
import Simplex.Chat.Messages
import Simplex.Chat.Operators
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared
@@ -100,7 +83,7 @@ import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..))
import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
@@ -108,7 +91,7 @@ import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode, UserProtocol)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
@@ -532,309 +515,42 @@ updateUserAddressAutoAccept db user@User {userId} autoAccept = do
Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply)
_ -> (False, False, Nothing)
getUpdateUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => DB.Connection -> SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> User -> IO (NonEmpty (UserServer p))
getUpdateUserServers db p presetOps randomSrvs user = do
ts <- getCurrentTime
srvs <- getProtocolServers db p user
let srvs' = updatedUserServers p presetOps randomSrvs srvs
mapM (upsertServer ts) srvs'
where
upsertServer :: UTCTime -> AUserServer p -> IO (UserServer p)
upsertServer ts (AUS _ s@UserServer {serverId}) = case serverId of
DBNewEntity -> insertProtocolServer db p user ts s
DBEntityId _ -> updateProtocolServer db p ts s $> s
getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> IO [UserServer p]
getProtocolServers db p User {userId} =
map toUserServer
getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p]
getProtocolServers db User {userId} =
map toServerCfg
<$> DB.query
db
[sql|
SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled
SELECT host, port, key_hash, basic_auth, preset, tested, enabled
FROM protocol_servers
WHERE user_id = ? AND protocol = ?
WHERE user_id = ? AND protocol = ?;
|]
(userId, decodeLatin1 $ strEncode p)
(userId, decodeLatin1 $ strEncode protocol)
where
toUserServer :: (DBEntityId, NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> UserServer p
toUserServer (serverId, host, port, keyHash, auth_, preset, tested, enabled) =
let server = ProtoServerWithAuth (ProtocolServer p host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
in UserServer {serverId, server, preset, tested, enabled, deleted = False}
protocol = protocolTypeI @p
toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg p
toServerCfg (host, port, keyHash, auth_, preset, tested, enabled) =
let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
in ServerCfg {server, preset, tested, enabled}
-- TODO remove
-- overwriteOperatorsAndServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> Maybe [ServerOperator] -> [ServerCfg p] -> ExceptT StoreError IO [ServerCfg p]
-- overwriteOperatorsAndServers db user@User {userId} operators_ servers = do
overwriteProtocolServers :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> [UserServer p] -> ExceptT StoreError IO ()
overwriteProtocolServers db p User {userId} servers =
-- liftIO $ mapM_ (updateServerOperators_ db) operators_
overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
overwriteProtocolServers db User {userId} servers =
checkConstraint SEUniqueID . ExceptT $ do
currentTs <- getCurrentTime
DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, decodeLatin1 $ strEncode p)
forM_ servers $ \UserServer {serverId, server, preset, tested, enabled} -> do
DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, protocol)
forM_ servers $ \ServerCfg {server, preset, tested, enabled} -> do
let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server
DB.execute
db
[sql|
INSERT INTO protocol_servers
(server_id, protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
(protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?)
|]
(Only serverId :. serverColumns p server :. (preset, tested, enabled, userId, currentTs, currentTs))
((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs))
pure $ Right ()
insertProtocolServer :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> UTCTime -> NewUserServer p -> IO (UserServer p)
insertProtocolServer db p User {userId} ts srv@UserServer {server, preset, tested, enabled} = do
DB.execute
db
[sql|
INSERT INTO protocol_servers
(protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?)
|]
(serverColumns p server :. (preset, tested, enabled, userId, ts, ts))
sId <- insertedRowId db
pure (srv :: NewUserServer p) {serverId = DBEntityId sId}
updateProtocolServer :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO ()
updateProtocolServer db p ts UserServer {serverId, server, preset, tested, enabled} =
DB.execute
db
[sql|
UPDATE protocol_servers
SET protocol = ?, host = ?, port = ?, key_hash = ?, basic_auth = ?,
preset = ?, tested = ?, enabled = ?, updated_at = ?
WHERE smp_server_id = ?
|]
(serverColumns p server :. (preset, tested, enabled, ts, serverId))
serverColumns :: ProtocolTypeI p => SProtocolType p -> ProtoServerWithAuth p -> (Text, NonEmpty TransportHost, String, C.KeyHash, Maybe Text)
serverColumns p (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_) =
let protocol = decodeLatin1 $ strEncode p
auth = safeDecodeUtf8 . unBasicAuth <$> auth_
in (protocol, host, port, keyHash, auth)
getServerOperators :: DB.Connection -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
getServerOperators db = do
currentConds <- getCurrentUsageConditions db
liftIO $ do
now <- getCurrentTime
latestAcceptedConds_ <- getLatestAcceptedConditions db
let getConds op = (\ca -> op {conditionsAcceptance = ca}) <$> getOperatorConditions_ db op currentConds latestAcceptedConds_ now
operators <- mapM getConds =<< getServerOperators_ db
pure (operators, usageConditionsAction operators currentConds now)
getUserServers :: DB.Connection -> User -> ExceptT StoreError IO ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
getUserServers db user =
(,,)
<$> (fst <$> getServerOperators db)
<*> liftIO (getProtocolServers db SPSMP user)
<*> liftIO (getProtocolServers db SPXFTP user)
setServerOperators :: DB.Connection -> NonEmpty ServerOperator -> IO ()
setServerOperators db ops = do
currentTs <- getCurrentTime
mapM_ (updateServerOperator db currentTs) ops
updateServerOperator :: DB.Connection -> UTCTime -> ServerOperator -> IO ()
updateServerOperator db currentTs ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} =
DB.execute
db
[sql|
UPDATE server_operators
SET enabled = ?, role_storage = ?, role_proxy = ?, updated_at = ?
WHERE server_operator_id = ?
|]
(enabled, storage, proxy, operatorId, currentTs)
getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [ServerOperator]
getUpdateServerOperators db presetOps newUser = do
conds <- map toUsageConditions <$> DB.query_ db usageCondsQuery
now <- getCurrentTime
let (acceptForSimplex_, currentConds, condsToAdd) = usageConditionsToAdd newUser now conds
mapM_ insertConditions condsToAdd
latestAcceptedConds_ <- getLatestAcceptedConditions db
ops <- updatedServerOperators presetOps <$> getServerOperators_ db
forM ops $ \(ASO _ op) ->
case operatorId op of
DBNewEntity -> do
op' <- insertOperator op
case (operatorTag op', acceptForSimplex_) of
(Just OTSimplex, Just cond) -> autoAcceptConditions op' cond
_ -> pure op'
DBEntityId _ -> do
updateOperator op
getOperatorConditions_ db op currentConds latestAcceptedConds_ now >>= \case
CARequired Nothing | operatorTag op == Just OTSimplex -> autoAcceptConditions op currentConds
CARequired (Just ts) | ts < now -> autoAcceptConditions op currentConds
ca -> pure op {conditionsAcceptance = ca}
where
insertConditions UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt} =
DB.execute
db
[sql|
INSERT INTO usage_conditions
(usage_conditions_id, conditions_commit, notified_at, created_at)
VALUES (?,?,?,?)
|]
(conditionsId, conditionsCommit, notifiedAt, createdAt)
updateOperator :: ServerOperator -> IO ()
updateOperator ServerOperator {operatorId, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} =
DB.execute
db
[sql|
UPDATE server_operators
SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, role_storage = ?, role_proxy = ?
WHERE server_operator_id = ?
|]
(tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy, operatorId)
insertOperator :: NewServerOperator -> IO ServerOperator
insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} = do
DB.execute
db
[sql|
INSERT INTO server_operators
(server_operator_tag, trade_name, legal_name, server_domains, enabled, role_storage, role_proxy)
VALUES (?,?,?,?,?,?,?)
|]
(operatorTag, tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy)
opId <- insertedRowId db
pure op {operatorId = DBEntityId opId}
autoAcceptConditions op UsageConditions {conditionsCommit} =
acceptConditions_ db op conditionsCommit Nothing
$> op {conditionsAcceptance = CAAccepted Nothing}
serverOperatorQuery :: Query
serverOperatorQuery =
[sql|
SELECT server_operator_id, server_operator_tag, trade_name, legal_name,
server_domains, enabled, role_storage, role_proxy
FROM server_operators
|]
getServerOperators_ :: DB.Connection -> IO [ServerOperator]
getServerOperators_ db = map toServerOperator <$> DB.query_ db serverOperatorQuery
toServerOperator :: (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool) -> ServerOperator
toServerOperator (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) =
ServerOperator
{ operatorId,
operatorTag,
tradeName,
legalName,
serverDomains = T.splitOn "," domains,
conditionsAcceptance = CARequired Nothing,
enabled,
roles = ServerRoles {storage, proxy}
}
getOperatorConditions_ :: DB.Connection -> ServerOperator -> UsageConditions -> Maybe UsageConditions -> UTCTime -> IO ConditionsAcceptance
getOperatorConditions_ db ServerOperator {operatorId} UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt} latestAcceptedConds_ now = do
case latestAcceptedConds_ of
Nothing -> pure $ CARequired Nothing -- no conditions accepted by any operator
Just UsageConditions {conditionsCommit = latestAcceptedCommit} -> do
operatorAcceptedConds_ <-
maybeFirstRow id $
DB.query
db
[sql|
SELECT conditions_commit, accepted_at
FROM operator_usage_conditions
WHERE server_operator_id = ?
ORDER BY operator_usage_conditions_id DESC
LIMIT 1
|]
(Only operatorId)
pure $ case operatorAcceptedConds_ of
Just (operatorCommit, acceptedAt_)
| operatorCommit /= latestAcceptedCommit -> CARequired Nothing -- TODO should we consider this operator disabled?
| currentCommit /= latestAcceptedCommit -> CARequired $ conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
| otherwise -> CAAccepted acceptedAt_
_ -> CARequired Nothing -- no conditions were accepted for this operator
getCurrentUsageConditions :: DB.Connection -> ExceptT StoreError IO UsageConditions
getCurrentUsageConditions db =
ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
DB.query_ db (usageCondsQuery <> " DESC LIMIT 1")
usageCondsQuery :: Query
usageCondsQuery =
[sql|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
FROM usage_conditions
ORDER BY usage_conditions_id
|]
toUsageConditions :: (Int64, Text, Maybe UTCTime, UTCTime) -> UsageConditions
toUsageConditions (conditionsId, conditionsCommit, notifiedAt, createdAt) =
UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt}
getLatestAcceptedConditions :: DB.Connection -> IO (Maybe UsageConditions)
getLatestAcceptedConditions db =
maybeFirstRow toUsageConditions $
DB.query_
db
[sql|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
FROM usage_conditions
WHERE conditions_commit = (
SELECT conditions_commit
FROM operator_usage_conditions
ORDER BY accepted_at DESC
LIMIT 1
)
|]
setConditionsNotified :: DB.Connection -> Int64 -> UTCTime -> IO ()
setConditionsNotified db condId notifiedAt =
DB.execute db "UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?" (notifiedAt, condId)
acceptConditions :: DB.Connection -> Int64 -> NonEmpty Int64 -> UTCTime -> ExceptT StoreError IO ()
acceptConditions db condId opIds acceptedAt = do
UsageConditions {conditionsCommit} <- getUsageConditionsById_ db condId
operators <- mapM getServerOperator_ opIds
let ts = Just acceptedAt
liftIO $ forM_ operators $ \op -> acceptConditions_ db op conditionsCommit ts
where
getServerOperator_ opId =
ExceptT $ firstRow toServerOperator (SEOperatorNotFound opId) $
DB.query db (serverOperatorQuery <> " WHERE operator_id = ?") (Only opId)
acceptConditions_ :: DB.Connection -> ServerOperator -> Text -> Maybe UTCTime -> IO ()
acceptConditions_ db ServerOperator {operatorId, operatorTag} conditionsCommit acceptedAt =
DB.execute
db
[sql|
INSERT INTO operator_usage_conditions
(server_operator_id, server_operator_tag, conditions_commit, accepted_at)
VALUES (?,?,?,?)
|]
(operatorId, operatorTag, conditionsCommit, acceptedAt)
getUsageConditionsById_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UsageConditions
getUsageConditionsById_ db conditionsId =
ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
DB.query
db
[sql|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
FROM usage_conditions
WHERE usage_conditions_id = ?
|]
(Only conditionsId)
setUserServers :: DB.Connection -> User -> NonEmpty UpdatedUserOperatorServers -> ExceptT StoreError IO ()
setUserServers db user@User {userId} userServers = checkConstraint SEUniqueID $ liftIO $ do
ts <- getCurrentTime
forM_ userServers $ \UpdatedUserOperatorServers {operator, smpServers, xftpServers} -> do
mapM_ (updateServerOperator db ts) operator
mapM_ (upsertOrDelete SPSMP ts) smpServers
mapM_ (upsertOrDelete SPXFTP ts) xftpServers
where
upsertOrDelete :: ProtocolTypeI p => SProtocolType p -> UTCTime -> AUserServer p -> IO ()
upsertOrDelete p ts (AUS _ s@UserServer {serverId, deleted}) = case serverId of
DBNewEntity -> void $ insertProtocolServer db p user ts s
DBEntityId srvId
| deleted -> DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND smp_server_id = ? AND preset = ?" (userId, srvId, False)
| otherwise -> updateProtocolServer db p ts s
protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
createCall :: DB.Connection -> User -> Call -> UTCTime -> IO ()
createCall db user@User {userId} Call {contactId, callId, callUUID, chatItemId, callState} callTs = do
-2
View File
@@ -127,8 +127,6 @@ data StoreError
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
| SERemoteCtrlDuplicateCA
| SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
| SEOperatorNotFound {serverOperatorId :: Int64}
| SEUsageConditionsNotFound
deriving (Show, Exception)
$(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError)
+16 -21
View File
@@ -1,7 +1,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Terminal where
@@ -14,15 +13,15 @@ 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)
import Simplex.Chat.Controller
import Simplex.Chat.Core
import Simplex.Chat.Help (chatWelcome)
import Simplex.Chat.Operators
import Simplex.Chat.Options
import Simplex.Chat.Terminal.Input
import Simplex.Chat.Terminal.Output
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
import Simplex.Messaging.Agent.Env.SQLite (presetServerCfg)
import Simplex.Messaging.Client (NetworkConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig)
import Simplex.Messaging.Util (raceAny_)
import System.IO (hFlush, hSetEcho, stdin, stdout)
@@ -30,24 +29,20 @@ import System.IO (hFlush, hSetEcho, stdin, stdout)
terminalChatConfig :: ChatConfig
terminalChatConfig =
defaultChatConfig
{ presetServers =
PresetServers
{ operators =
[ PresetOperator
{ operator = Just operatorSimpleXChat,
smp =
map
(presetServer True)
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
],
useSMP = 3,
xftp = map (presetServer True) $ L.toList defaultXFTPServers,
useXFTP = 3
}
],
ntf = _defaultNtfServers,
{ defaultServers =
DefaultAgentServers
{ smp =
L.fromList $
map
(presetServerCfg True)
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
],
useSMP = 3,
ntf = ["ntf://FB-Uop7RTaZZEG0ZLD2CIaTjsPh-Fw0zFAnb7QyA8Ks=@ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion"],
xftp = L.map (presetServerCfg True) defaultXFTPServers,
useXFTP = L.length defaultXFTPServers,
netCfg =
defaultNetworkConfig
{ smpProxyMode = SPMUnknown,
+2 -2
View File
@@ -10,7 +10,7 @@ import Data.Maybe (fromMaybe)
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Network.Socket
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), PresetServers (..), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), DefaultAgentServers (DefaultAgentServers, netCfg), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
import Simplex.Chat.Core
import Simplex.Chat.Options
import Simplex.Chat.Terminal
@@ -56,7 +56,7 @@ simplexChatCLI' cfg opts@ChatOpts {chatCmd, chatCmdLog, chatCmdDelay, chatServer
putStrLn $ serializeChatResponse (rh, Just user) ts tz rh r
welcome :: ChatConfig -> ChatOpts -> IO ()
welcome ChatConfig {presetServers = PresetServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
welcome ChatConfig {defaultServers = DefaultAgentServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
mapM_
putStrLn
[ versionString versionNumber,
+26 -37
View File
@@ -53,7 +53,7 @@ import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..))
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerCfg (..))
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
import Simplex.Messaging.Client (SMPProxyFallback, SMPProxyMode (..), SocksMode (..))
@@ -93,18 +93,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRChatSuspended -> ["chat suspended"]
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]
CRApiChat u chat lsec -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat] <> (["newer messages available" | lsec == CLSUnread])
CRApiParsedMarkdown ft -> [viewJSON ft]
-- CRUserProtoServers u userServers operators -> ttyUser u $ viewUserServers userServers operators testView
CRUserProtoServers u userServers -> ttyUser u $ viewUserServers userServers testView
CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
CRTestOperator _ -> []
CRTestUsageConditionsAction _ -> []
CRTestConditionsAcceptance _ -> []
CRTestServerRoles _ -> []
CRServerOperators {} -> []
CRUserServers {} -> []
CRUserServersValidation _ -> []
CRUsageConditions {} -> []
CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl
CRNetworkConfig cfg -> viewNetworkConfig cfg
CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile
@@ -1217,27 +1209,27 @@ viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', sho
"profile is " <> if isJust viewPwdHash then "hidden" else "visible"
]
-- viewUserServers :: AUserProtoServers -> [ServerOperator] -> Bool -> [StyledString]
-- viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) operators testView =
-- customServers
-- <> if testView
-- then []
-- else
-- [ "",
-- "use " <> highlight (srvCmd <> " test <srv>") <> " to test " <> pName <> " server connection",
-- "use " <> highlight (srvCmd <> " <srv1[,srv2,...]>") <> " to configure " <> pName <> " servers",
-- "use " <> highlight (srvCmd <> " default") <> " to remove configured " <> pName <> " servers and use presets"
-- ]
-- <> case p of
-- SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"]
-- SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"]
-- where
-- srvCmd = "/" <> strEncode p
-- pName = protocolName p
-- customServers =
-- if null protoServers
-- then ("no " <> pName <> " servers saved, using presets: ") : viewServers operators presetServers
-- else viewServers operators protoServers
viewUserServers :: AUserProtoServers -> Bool -> [StyledString]
viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) testView =
customServers
<> if testView
then []
else
[ "",
"use " <> highlight (srvCmd <> " test <srv>") <> " to test " <> pName <> " server connection",
"use " <> highlight (srvCmd <> " <srv1[,srv2,...]>") <> " to configure " <> pName <> " servers",
"use " <> highlight (srvCmd <> " default") <> " to remove configured " <> pName <> " servers and use presets"
]
<> case p of
SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"]
SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"]
where
srvCmd = "/" <> strEncode p
pName = protocolName p
customServers =
if null protoServers
then ("no " <> pName <> " servers saved, using presets: ") : viewServers presetServers
else viewServers protoServers
protocolName :: ProtocolTypeI p => SProtocolType p -> StyledString
protocolName = plain . map toUpper . T.unpack . decodeLatin1 . strEncode
@@ -1334,11 +1326,8 @@ viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
["receiving messages via: " <> viewRcvQueuesInfo rcvQueuesInfo | not $ null rcvQueuesInfo]
<> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo]
-- viewServers :: ProtocolTypeI p => [ServerOperator] -> NonEmpty (ServerCfg p) -> [StyledString]
-- viewServers operators = map (plain . (\ServerCfg {server, operator} -> B.unpack (strEncode server) <> viewOperator operator)) . L.toList
-- where
-- ops :: Map (Maybe DBEntityId) Text = foldl' (\m ServerOperator {operatorId, tradeName} -> M.insert (Just operatorId) tradeName m) M.empty operators
-- viewOperator = maybe "" $ \op -> " (operator " <> maybe (show op) T.unpack (M.lookup (Just op) ops) <> ")"
viewServers :: ProtocolTypeI p => NonEmpty (ServerCfg p) -> [StyledString]
viewServers = map (plain . B.unpack . strEncode . (\ServerCfg {server} -> server)) . L.toList
viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString
viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo
+10 -29
View File
@@ -10,8 +10,7 @@ import ChatTests.Utils
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Exception (finally)
import Control.Monad (forM_)
import qualified Data.Text as T
import qualified Directory.Events as DE
import Directory.Events (viewName)
import Directory.Options
import Directory.Service
import Directory.Store
@@ -28,7 +27,7 @@ import Test.Hspec hiding (it)
directoryServiceTests :: SpecWith FilePath
directoryServiceTests = do
it "should register group" testDirectoryService
it "should suspend and resume group, send message to owner" testSuspendResume
it "should suspend and resume group" testSuspendResume
it "should delete group registration" testDeleteGroup
it "should change initial member role" testSetRole
it "should join found group via link" testJoinGroup
@@ -68,7 +67,6 @@ mkDirectoryOpts :: FilePath -> [KnownContact] -> DirectoryOpts
mkDirectoryOpts tmp superUsers =
DirectoryOpts
{ coreOptions = testCoreOpts {dbFilePrefix = tmp </> serviceDbPrefix},
adminUsers = [],
superUsers,
directoryLog = Just $ tmp </> "directory_service.log",
serviceName = "SimpleX-Directory",
@@ -79,9 +77,6 @@ mkDirectoryOpts tmp superUsers =
serviceDbPrefix :: FilePath
serviceDbPrefix = "directory_service"
viewName :: String -> String
viewName = T.unpack . DE.viewName . T.pack
testDirectoryService :: HasCallStack => FilePath -> IO ()
testDirectoryService tmp =
withDirectoryService tmp $ \superUser dsLink ->
@@ -116,7 +111,7 @@ testDirectoryService tmp =
-- putStrLn "*** update profile so that it has link"
updateGroupProfile bob welcomeWithLink
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (PSA) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
approvalRequested superUser welcomeWithLink (1 :: Int)
-- putStrLn "*** update profile so that it still has link"
let welcomeWithLink' = "Welcome! " <> welcomeWithLink
@@ -144,7 +139,7 @@ testDirectoryService tmp =
-- putStrLn "*** update profile so that it has link again"
updateGroupProfile bob welcomeWithLink'
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (PSA) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
approvalRequested superUser welcomeWithLink' (1 :: Int)
superUser #> "@SimpleX-Directory /pending"
superUser <# "SimpleX-Directory> > /pending"
@@ -212,17 +207,6 @@ testSuspendResume tmp =
superUser <## " Group listing resumed!"
bob <# "SimpleX-Directory> The group ID 1 (privacy) is listed in the directory again!"
groupFound bob "privacy"
superUser #> "@SimpleX-Directory privacy"
groupFoundN_ (Just 1) 2 superUser "privacy"
superUser #> "@SimpleX-Directory /link 1:privacy"
superUser <# "SimpleX-Directory> > /link 1:privacy"
superUser <## " The link to join the group ID 1 (privacy):"
superUser <##. "https://simplex.chat/contact"
superUser <## "New member role: member"
superUser #> "@SimpleX-Directory /owner 1:privacy hello there"
superUser <# "SimpleX-Directory> > /owner 1:privacy hello there"
superUser <## " Forwarded to @bob, the owner of the group ID 1 (privacy)"
bob <# "SimpleX-Directory> hello there"
testDeleteGroup :: HasCallStack => FilePath -> IO ()
testDeleteGroup tmp =
@@ -666,7 +650,7 @@ testRegOwnerRemovedLink tmp =
bob <## "description changed to:"
bob <## welcomeWithLink
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
cath <## "bob updated group #privacy:"
cath <## "description changed to:"
cath <## welcomeWithLink
@@ -708,7 +692,7 @@ testAnotherOwnerRemovedLink tmp =
bob <## "description changed to:"
bob <## (welcomeWithLink <> " - welcome!")
bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message."
bob <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
cath <## "bob updated group #privacy:"
cath <## "description changed to:"
cath <## (welcomeWithLink <> " - welcome!")
@@ -790,7 +774,7 @@ testDuplicateProhibitWhenUpdated tmp =
cath ##> "/gp privacy security Security"
cath <## "changed to #security (Security)"
cath <# "SimpleX-Directory> Thank you! The group link for ID 2 (security) is added to the welcome message."
cath <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
cath <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
notifySuperUser superUser cath "security" "Security" welcomeWithLink' 2
approveRegistration superUser cath "security" 2
groupFound bob "security"
@@ -1051,7 +1035,7 @@ updateProfileWithLink u n welcomeWithLink ugId = do
u <## "description changed to:"
u <## welcomeWithLink
u <# ("SimpleX-Directory> Thank you! The group link for ID " <> show ugId <> " (" <> n <> ") is added to the welcome message.")
u <## "You will be notified once the group is added to the directory - it may take up to 48 hours."
u <## "You will be notified once the group is added to the directory - it may take up to 24 hours."
notifySuperUser :: TestCC -> TestCC -> String -> String -> String -> Int -> IO ()
notifySuperUser su u n fn welcomeWithLink gId = do
@@ -1128,13 +1112,10 @@ groupFoundN count u name = do
groupFoundN' count u name
groupFoundN' :: Int -> TestCC -> String -> IO ()
groupFoundN' = groupFoundN_ Nothing
groupFoundN_ :: Maybe Int -> Int -> TestCC -> String -> IO ()
groupFoundN_ shownId_ count u name = do
groupFoundN' count u name = do
u <# ("SimpleX-Directory> > " <> name)
u <## " Found 1 group(s)."
u <#. ("SimpleX-Directory> " <> maybe "" (\gId -> show gId <> ". ") shownId_ <> name)
u <#. ("SimpleX-Directory> " <> name)
u <## "Welcome message:"
u <##. "Link to join the group "
u <## (show count <> " members")
+4 -20
View File
@@ -25,10 +25,9 @@ import Data.Maybe (isNothing)
import qualified Data.Text as T
import Network.Socket
import Simplex.Chat
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), PresetServers (..), defaultSimpleNetCfg)
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg)
import Simplex.Chat.Core
import Simplex.Chat.Options
import Simplex.Chat.Operators (PresetOperator (..), presetServer)
import Simplex.Chat.Protocol (currentChatVersion, pqEncryptionCompressionVersion)
import Simplex.Chat.Store
import Simplex.Chat.Store.Profiles
@@ -52,7 +51,6 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Protocol (srvHostnamesSMPClientVersion)
import Simplex.Messaging.Server (runSMPServerBlocking)
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..))
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Server (ServerCredentials (..), defaultTransportServerConfig)
import Simplex.Messaging.Version
@@ -95,8 +93,8 @@ testCoreOpts =
{ dbFilePrefix = "./simplex_v1",
dbKey = "",
-- dbKey = "this is a pass-phrase to encrypt the database",
smpServers = [],
xftpServers = [],
smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
simpleNetCfg = defaultSimpleNetCfg,
logLevel = CLLImportant,
logConnections = False,
@@ -150,18 +148,6 @@ testCfg :: ChatConfig
testCfg =
defaultChatConfig
{ agentConfig = testAgentCfg,
presetServers =
(presetServers defaultChatConfig)
{ operators =
[ PresetOperator
{ operator = Just operatorSimpleXChat,
smp = map (presetServer True) ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
useSMP = 1,
xftp = map (presetServer True) ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
useXFTP = 1
}
]
},
showReceipts = False,
testView = True,
tbqSize = 16
@@ -436,10 +422,8 @@ smpServerCfg =
ServerConfig
{ transports = [(serverPort, transport @TLS, False)],
tbqSize = 1,
msgStoreType = AMSType SMSMemory,
-- serverTbqSize = 1,
msgQueueQuota = 16,
maxJournalMsgCount = 24,
maxJournalStateLines = 4,
queueIdBytes = 12,
msgIdBytes = 6,
storeLogFile = Nothing,
+18 -11
View File
@@ -25,7 +25,7 @@ import Database.SQLite.Simple (Only (..))
import Simplex.Chat.AppSettings (defaultAppSettings)
import qualified Simplex.Chat.AppSettings as AS
import Simplex.Chat.Call
import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..))
import Simplex.Chat.Controller (ChatConfig (..), DefaultAgentServers (..))
import Simplex.Chat.Messages (ChatItemId)
import Simplex.Chat.Options
import Simplex.Chat.Protocol (supportedChatVRange)
@@ -210,6 +210,7 @@ testAddContact = versionTestMatrix2 runTestAddContact
-- pagination
alice #$> ("/_get chat @2 after=" <> itemId 1 <> " count=100", chat, [(0, "hello there"), (0, "how are you?")])
alice #$> ("/_get chat @2 before=" <> itemId 2 <> " count=100", chat, features <> [(1, "hello there 🙂")])
alice #$> ("/_get chat @2 around=" <> itemId 2 <> " count=3", chat, [(1, "hello there 🙂"), (0, "hello there"), (0, "how are you?")])
-- search
alice #$> ("/_get chat @2 count=100 search=ello ther", chat, [(1, "hello there 🙂"), (0, "hello there")])
-- read messages
@@ -332,8 +333,8 @@ testRetryConnectingClientTimeout tmp = do
{ quotaExceededTimeout = 1,
messageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval}
},
presetServers =
let def@PresetServers {netCfg} = presetServers testCfg
defaultServers =
let def@DefaultAgentServers {netCfg} = defaultServers testCfg
in def {netCfg = (netCfg :: NetworkConfig) {tcpTimeout = 10}}
}
opts' =
@@ -791,7 +792,7 @@ testDirectMessageDelete =
alice @@@ [("@bob", lastChatFeature)]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures)
-- alice: msg id 1
-- alice: msg id 3
bob ##> ("/_update item @2 " <> itemId 2 <> " text hey alice")
bob <# "@alice [edited] > hello 🙂"
bob <## " hey alice"
@@ -806,12 +807,12 @@ testDirectMessageDelete =
alice @@@ [("@bob", "hey alice [marked deleted]")]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "hey alice [marked deleted]")])
-- alice: deletes msg id 1 that was broadcast deleted by bob
alice #$> ("/_delete item @2 " <> itemId 1 <> " internal", id, "message deleted")
-- alice: deletes msg id 3 that was broadcast deleted by bob
alice #$> ("/_delete item @2 " <> itemId 3 <> " internal", id, "message deleted")
alice @@@ [("@bob", lastChatFeature)]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures)
-- alice: msg id 1, bob: msg id 3 (quoting message alice deleted locally)
-- alice: msg id 4, bob: msg id 3 (quoting message alice deleted locally)
bob `send` "> @alice (hello 🙂) do you receive my messages?"
bob <# "@alice > hello 🙂"
bob <## " do you receive my messages?"
@@ -819,14 +820,14 @@ testDirectMessageDelete =
alice <## " do you receive my messages?"
alice @@@ [("@bob", "do you receive my messages?")]
alice #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "do you receive my messages?"), Just (1, "hello 🙂"))])
alice #$> ("/_delete item @2 " <> itemId 1 <> " broadcast", id, "cannot delete this item")
alice #$> ("/_delete item @2 " <> itemId 4 <> " broadcast", id, "cannot delete this item")
-- alice: msg id 2, bob: msg id 4
-- alice: msg id 5, bob: msg id 4
bob #> "@alice how are you?"
alice <# "bob> how are you?"
-- alice: deletes msg id 2
alice #$> ("/_delete item @2 " <> itemId 2 <> " internal", id, "message deleted")
-- alice: deletes msg id 5
alice #$> ("/_delete item @2 " <> itemId 5 <> " internal", id, "message deleted")
-- bob: marks deleted msg id 4 (that alice deleted locally)
bob #$> ("/_delete item @2 " <> itemId 4 <> " broadcast", id, "message marked deleted")
@@ -2340,6 +2341,12 @@ testUserPrivacy =
"bob> Voice messages: enabled",
"bob> Audio/video calls: enabled"
]
alice ##> "/_get items around=11 count=3"
alice
<##? [ "bob> Message reactions: enabled",
"bob> Voice messages: enabled",
"bob> Audio/video calls: enabled"
]
alice ##> "/_get items after=12 count=10"
alice
<##? [ "@bob hello",
+1 -2
View File
@@ -1,10 +1,8 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatTests.Groups where
@@ -346,6 +344,7 @@ testGroupShared alice bob cath checkMessages directConnections = do
-- so we take into account group event items as well as sent group invitations in direct chats
alice #$> ("/_get chat #1 after=" <> msgItem1 <> " count=100", chat, [(0, "hi there"), (0, "hey team")])
alice #$> ("/_get chat #1 before=" <> msgItem2 <> " count=100", chat, [(1, e2eeInfoNoPQStr), (0, "connected"), (0, "connected"), (1, "hello"), (0, "hi there")])
alice #$> ("/_get chat #1 around=" <> msgItem2 <> " count=6", chat, [(0, "connected"), (1, "hello"), (0, "hi there"), (0, "hey team")]) -- expecting only 4 items since there is only 1 item after
alice #$> ("/_get chat #1 count=100 search=team", chat, [(0, "hey team")])
bob @@@ [("@cath", "hey"), ("#team", "hey team"), ("@alice", "received invitation to join group team as admin")]
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "added cath (Catherine)"), (0, "connected"), (0, "hello"), (1, "hi there"), (0, "hey team")])
+5 -1
View File
@@ -51,7 +51,7 @@ testNotes tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do
alice ##> "/chats"
alice /* "ahoy!"
alice ##> "/_update item *1 1 text Greetings."
alice ##> "/_update item *1 2 text Greetings."
alice ##> "/tail *"
alice <# "* Greetings."
@@ -102,6 +102,10 @@ testChatPagination tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do
alice #$> ("/_get chat *1 count=100", chat, [(1, "hello world"), (1, "memento mori"), (1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 count=1", chat, [(1, "who's there?")])
alice #$> ("/_get chat *1 around=2 count=1", chat, [(1, "memento mori")])
alice #$> ("/_get chat *1 around=2 count=3", chat, [(1, "hello world"), (1, "memento mori"), (1, "knock-knock")])
alice #$> ("/_get chat *1 around=3 count=10", chat, [(1, "hello world"), (1, "memento mori"), (1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 around=4 count=3", chat, [(1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 after=2 count=10", chat, [(1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 after=2 count=2", chat, [(1, "knock-knock"), (1, "who's there?")])
alice #$> ("/_get chat *1 after=1 count=2", chat, [(1, "memento mori"), (1, "knock-knock")])
-1
View File
@@ -2,7 +2,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatTests.Profiles where
+20 -33
View File
@@ -1,64 +1,51 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module RandomServers where
import Control.Monad (replicateM)
import Data.Foldable (foldMap')
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Monoid (Sum (..))
import Simplex.Chat (defaultChatConfig, randomPresetServers)
import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..))
import Simplex.Chat.Operators (DBEntityId' (..), NewUserServer, UserServer' (..), operatorServers, operatorServersToUse)
import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
import Simplex.Chat (cfgServers, cfgServersToUse, defaultChatConfig, randomServers)
import Simplex.Chat.Controller (ChatConfig (..))
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..))
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SProtocolType (..), UserProtocol)
import Test.Hspec
randomServersTests :: Spec
randomServersTests = describe "choosig random servers" $ do
it "should choose 4 + 3 random SMP servers and keep the rest disabled" testRandomSMPServers
it "should choose 3 + 3 random XFTP servers and keep the rest disabled" testRandomXFTPServers
it "should choose 4 random SMP servers and keep the rest disabled" testRandomSMPServers
it "should keep all 6 XFTP servers" testRandomXFTPServers
deriving instance Eq ServerRoles
deriving instance Eq (DBEntityId' s)
deriving instance Eq (UserServer' s p)
deriving instance Eq (ServerCfg p)
testRandomSMPServers :: IO ()
testRandomSMPServers = do
[srvs1, srvs2, srvs3] <-
replicateM 3 $
checkEnabled SPSMP 7 False =<< randomPresetServers SPSMP (presetServers defaultChatConfig)
checkEnabled SPSMP 4 False =<< randomServers SPSMP defaultChatConfig
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures
testRandomXFTPServers :: IO ()
testRandomXFTPServers = do
[srvs1, srvs2, srvs3] <-
replicateM 3 $
checkEnabled SPXFTP 6 False =<< randomPresetServers SPXFTP (presetServers defaultChatConfig)
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures
checkEnabled SPXFTP 6 True =<< randomServers SPXFTP defaultChatConfig
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` True
checkEnabled :: UserProtocol p => SProtocolType p -> Int -> Bool -> NonEmpty (NewUserServer p) -> IO [NewUserServer p]
checkEnabled p n allUsed srvs = do
let srvs' = sortOn server' $ L.toList srvs
PresetServers {operators = presetOps} = presetServers defaultChatConfig
presetSrvs = sortOn server' $ concatMap (operatorServers p) presetOps
Sum toUse = foldMap' (Sum . operatorServersToUse p) presetOps
srvs' == presetSrvs `shouldBe` allUsed
map enable srvs' `shouldBe` map enable presetSrvs
let enbldSrvs = filter (\UserServer {enabled} -> enabled) srvs'
checkEnabled :: UserProtocol p => SProtocolType p -> Int -> Bool -> (L.NonEmpty (ServerCfg p), [ServerCfg p]) -> IO [ServerCfg p]
checkEnabled p n allUsed (srvs, _) = do
let def = defaultServers defaultChatConfig
cfgSrvs = L.sortWith server' $ cfgServers p def
toUse = cfgServersToUse p def
srvs == cfgSrvs `shouldBe` allUsed
L.map enable srvs `shouldBe` L.map enable cfgSrvs
let enbldSrvs = L.filter (\ServerCfg {enabled} -> enabled) srvs
toUse `shouldBe` n
length enbldSrvs `shouldBe` n
pure enbldSrvs
where
server' UserServer {server = ProtoServerWithAuth srv _} = srv
enable :: forall p. NewUserServer p -> NewUserServer p
enable srv = (srv :: NewUserServer p) {enabled = False}
server' ServerCfg {server = ProtoServerWithAuth srv _} = srv
enable :: forall p. ServerCfg p -> ServerCfg p
enable srv = (srv :: ServerCfg p) {enabled = False}
+3 -1
View File
@@ -102,7 +102,9 @@ skipComparisonForDownMigrations =
-- table and indexes move down to the end of the file
"20231215_recreate_msg_deliveries",
-- on down migration idx_msg_deliveries_agent_ack_cmd_id index moves down to the end of the file
"20240313_drop_agent_ack_cmd_id"
"20240313_drop_agent_ack_cmd_id",
-- on down migration chat_item_autoincrement_id makes sequence table creation move down on the file
"20241023_chat_item_autoincrement_id"
]
getSchema :: FilePath -> FilePath -> IO String